File: LiveRosterImage.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (170 lines) | stat: -rw-r--r-- 4,992 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
# LiveRosterImage.tcl --
# 
#       Makes a custom overlay to any roster background image.
#
#  Copyright (c) 2007 Mats Bengtsson
#  
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#  
#  $Id: LiveRosterImage.tcl,v 1.6 2008-04-26 05:47:30 matben Exp $

namespace eval ::LiveRosterImage {

    if {[tk windowingsystem] ne "aqua"} {
	return
    }
    if {[catch {package require tkpath 0.3.0}]} {
	return
    }
    component::define LiveRosterImage "Draw an overlay to the roster background image"
}

proc ::LiveRosterImage::Init {} {
    
    component::register LiveRosterImage

    # Add event hooks.
    ::hooks::register setPresenceHook [namespace code PresenceHook]
    if {0 && [info tclversion] >= 8.5 && [tk windowingsystem] eq "aqua"} {
	::hooks::register connectInitHook [namespace code ConnectInitHook]
	::hooks::register connectHook     [namespace code ConnectHook]
	::hooks::register disconnectHook  [namespace code DisconnectHook]
    }
}

proc ::LiveRosterImage::PresenceHook {type args} {
    Draw
}

proc ::LiveRosterImage::Draw {} {

    set orig [::RosterTree::BackgroundImageGet]
    if {$orig eq ""} {
	return
    }
    set width  [image width $orig]
    set height [image height $orig]
    if {($width < 100) || ($height < 100)} {
	return
    }

    set show [::Jabber::Jlib mypresence]
    set status [::Jabber::Jlib mypresencestatus]
    set showStr [::Roster::MapShowToText $show]

    # Find size for each line and adjust the font size.
    set family {Lucida Grande}
    set size 16
    set maxSize 52
    set font [list $family $size]
    
    # Scale font size to fit.
    set len [font measure $font $showStr]
    set size1 [min [expr {$size*($width - 40)/$len}] $maxSize]
    set font1 [list $family $size1]
    set linespace1 [font metrics $font1 -linespace]
    set descent1 [font metrics $font1 -descent]
    set y1 [expr {$linespace1 + 20}]
    
    set str2L [list]
    if {$status ne ""} {
	set str2L [list $status]
	set n [string length $status]
	set len [font measure $font $status]

	# Split status message into two lines if long.
	if {$len >= $width} {
	    set idx [string first " " $status [expr {$n/2}]]
	    if {$idx >= 0} {
		set str2L [list \
		  [string range $status 0 [expr {$idx-1}]] \
		  [string range $status [expr {$idx+1}] end]]
		set len [font measure $font [lindex $str2L 0]]
	    }
	}
	set size2 [min [expr {$size*($width - 20)/$len}] $maxSize]
	set font2 [list $family $size2]
	set linespace2 [font metrics $font2 -linespace]
	set y2 [expr {$y1 + $descent1 + $linespace2}]
    }
    
    set S [::tkp::surface new $width $height]
    $S create pimage 0 0 -image $orig
    
    if {0} {
	set avatar [::Avatar::GetMyPhoto]
	if {$avatar ne ""} {
	    $S create pimage 10 10 -image $avatar -matrix {{3 0} {0 3} {0 0}}
	}
    }
    
    # Get from resources.
    set opacity 0.7
    set fill white
    set width2 [expr {$width/2}]
    $S create ptext $width2 $y1 -text $showStr -textanchor middle \
      -fontfamily $family -fontsize $size1 -fill $fill -fillopacity $opacity
    foreach str $str2L {
	$S create ptext $width2 $y2 -text $str -textanchor middle \
	  -fontfamily $family -fontsize $size2 -fill $fill -fillopacity $opacity
	incr y2 $linespace2
    }
    set new [$S copy [image create photo]]
    $S destroy
    image delete $orig
    
    ::RosterTree::BackgroundImageConfig $new
}

# Experimental!

namespace eval ::LiveRosterImage {
    
    variable woverlay -
}

# This suffers from a BUG in tkpath!
# It seems it doesn't redraw background with systemTransparent?

proc ::LiveRosterImage::ConnectInitHook {} {
    variable woverlay
    
    set win [::JUI::GetRosterFrame]
    set width [winfo width $win]
    set height [winfo height $win]
    set w2 [expr {$width/2}]
    set h2 [expr {$height/2}]
    
    set woverlay $win.overlay
    tkp::canvas $woverlay -bg systemTransparent -highlightthickness 0 -bd 0
    place $woverlay -x 0 -y 0 -relwidth 1 -relheight 1
    
    $woverlay create prect 0 0 2000 2000 \
      -fill gray20 -fillopacity 0.2 -stroke ""
    $woverlay create ptext $w2 $h2 -textanchor middle -text "Connecting..." \
      -fontfamily {Lucida Grande} -fontsize 24 -fill gray50 \
      -fillopacity 0.6
}

proc ::LiveRosterImage::ConnectHook {} {
    variable woverlay
    destroy $woverlay
}

proc ::LiveRosterImage::DisconnectHook {} {
    variable woverlay
    destroy $woverlay
}