chiark / gitweb /
subproc
[chiark-tcl-applet.git] / applet.tcl
1 # General purpose code for being a tray applet
2
3 proc manyset {list args} {
4     foreach val $list var $args {
5         upvar 1 $var my
6         set my $val
7     }
8 }
9
10
11 package require Tclx
12 package require tktray
13
14 #----- general machinery -----
15
16 # Interface:
17 #
18 #  tk::tktray widget is called .i
19 #
20 # Tooltip:
21 #
22 #   Caller may call
23 #      applet::setup-tooltip ON-VISIBLE ON-INVISIBLE
24 #   to make applet have a tooltip.
25 #
26 #   ON-VISIBLE and ON-INVISIBLE will be globally eval'd
27 #   when the tooltip becomes visible and invisible.
28 #
29 #   Caller should call
30 #      applet::tooltip-set TEXT-MAYBE-MULTILINE
31 #   whenever they like.
32 #
33 # Inner window subprocess:
34 #
35 #  Caller that needs access to inner window should define
36 #     proc innerwindow {} { ... }
37 #  and run
38 #     innerwindow
39 #  This will create
40 #     .i.i.b      frame to contain container
41 #     .i.i.b.c    actual container
42
43 #  Button presses
44 #
45 #    Caller may bind .i.i <ButtonPress-$b>
46 #
47 #    Alternatively caller may call  applet::setup-button-menu $b
48 #    which will generate a menu .m$b which the user can configure
49 #    and which will automatically be posted and unposted etc.
50
51 wm withdraw .
52
53 tktray::icon .i -class example
54 .i configure -docked 1
55
56
57 namespace eval applet {
58
59
60 # used by both menus and tooltips
61 variable posted 0
62
63 #----- menus -----
64
65 proc setup-button-menu {b} {
66     bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
67     menu .m$b -tearoff 0
68 }
69
70 proc menubuttonpressed {b x y} {
71     variable posted
72     tooltip-cancel
73     if {$posted == $b} {
74         puts "unpost $posted toggle"
75         .m$posted unpost
76         set posted 0
77     } elseif {[winfo exists .m$b]} {
78         if {$posted} {
79             .m$posted unpost
80             puts "unpost $posted other"
81         }
82         puts "post $b"
83         set posted $b
84         .m$b post $x $y
85     }
86 }
87
88 proc msel {} {
89     variable posted
90     set posted 0
91 }
92
93 #----- tooltips -----
94
95 variable tooltip_on_vis {}
96 variable tooltip_on_invis {}
97
98 proc tooltip-starttimer {state x y} {
99     variable tooltip_after
100     variable posted
101     variable tooltip_inwindow
102     if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
103     catch { after cancel $tooltip_after }
104     set tooltip_after [after 500 applet::tooltip-show $x $y]
105 }
106
107 proc tooltip-cancel {} {
108     variable tooltip_after
109     variable tooltip_on_invis
110     catch { after cancel $tooltip_after }
111     catch { unset $tooltip_after }
112     wm withdraw .tt
113     uplevel #0 $tooltip_on_invis
114 }
115
116 set tooltip_inwindow 0
117
118 proc tooltip-enter {state x y} {
119     variable tooltip_inwindow
120     set tooltip_inwindow 1
121     tooltip-starttimer $state $x $y
122 }
123
124 proc tooltip-leave {} {
125     variable tooltip_inwindow
126     set tooltip_inwindow 0
127     tooltip-cancel
128 }
129
130 proc setup-tooltip {on_vis on_invis} {
131     foreach v {vis invis} {
132         variable tooltip_on_$v [set on_$v]
133     }
134     bind .i <Enter> { applet::tooltip-enter %s %X %Y }
135     bind .i <Leave> { applet::tooltip-leave }
136     bind .i <ButtonRelease> { 
137         applet::tooltip-cancel
138         applet::tooltip-starttimer %s %X %Y
139     }
140     bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
141     toplevel .tt -background black
142     wm withdraw .tt
143     wm overrideredirect .tt 1
144     label .tt.t -justify left -background {#EEE1B3}
145     pack .tt.t -padx 1 -pady 1
146     tooltip-set {}
147 }
148
149 proc tooltip-set {s} {
150     .tt.t configure -text $s
151 }
152
153 proc tooltip-show {x y} {
154     variable tooltip_on_vis
155     incr x 9
156     incr y 9
157     wm geometry .tt +$x+$y
158     wm deiconify .tt
159     uplevel #0 $tooltip_on_vis
160 }
161
162 }
163
164
165 proc innerwindow-resetup-required {why} {
166     variable innerwindow_after
167 puts "IW-EVENT $why"
168     if {[info exists innerwindow_after]} return
169     set innerwindow_after [after idle innerwindow-resetup]
170 }
171
172 proc innerwindow-resetup {} {
173     variable innerwindow_after
174     unset innerwindow_after
175
176 puts RESETUP
177
178     innerwindow-destroying
179
180     catch { destroy .i.i.c }
181     if {![winfo exists .i.i]} return
182     destroy [frame .i.i.make-exist]
183     catch { destroy .i.i.b.c }
184     catch { destroy .i.i.b }
185     frame .i.i.b
186     pack .i.i.b -fill both -side left -expand 1
187     frame .i.i.b.c -container 1 -background orange
188     pack .i.i.b.c -fill both -side left -expand 1
189 #
190     global inner_lastw inner_lasth
191     #set w [winfo width .i.i]
192 #    set w [winfo width .i.i]
193 #    set h [winfo height .i.i]
194
195 #    if {$w != $inner_lastw || $h != $inner_lasth} {
196 #       set inner_lastw $w
197 #       set inner_lasth $h
198 #       innerwindow-ph-dummy configure -width $w -height 2
199         innerwindow-ready
200 #    }
201 }
202
203 proc setupinnerwindow {w} {
204     global inner_lastw inner_lasth
205     set inner_lastw -2
206     set inner_lasth -2
207
208     image create photo innerwindow-ph-dummy -width $w -height 2
209     .i configure -image innerwindow-ph-dummy
210
211     destroy [frame .i.make-exist]
212     destroy [frame .i.i.make-exist]
213     bind .i <<IconConfigure>> { innerwindow-resetup-required IconConfigure }
214 }
215
216
217
218 proc setimage {image} {
219     .i configure -image $image
220 }