chiark / gitweb /
c3c4c4e463a437f6fc4edc1ec64f1c569bcd5057
[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 # Button presses
34 #
35 #    Caller may bind .i.i <ButtonPress-$b>
36 #
37 #    Alternatively caller may call  applet::setup-button-menu $b
38 #    which will generate a menu .m$b which the user can configure
39 #    and which will automatically be posted and unposted etc.
40 #    In this case the caller should arrange that all of their
41 #    menus, when an item is selected, call
42 #      applet::msel
43 #
44 # Debug:
45
46 #    Caller may call
47 #       applet::setup-debug ON-DEBUG
48 #    which will result in calls to [concat ON-DEBUG [list MESSAGE]]
49 #    (or ON-DEBUG may be "" in which case messages are discarded)
50 #
51 # Icon:
52 #
53 #  Caller should call:
54 #      applet::setimage IMAGE
55 #  as necessary.
56 #
57 # Alternatively of icon, it may provide other arrangements for
58 # using the provided subwindow.  Such a caller should call
59 #      applet::setup-subwindow ON-DESTROYING ON-READY
60 #  Then the main code will call ON-DESTROYING just before
61 #  destroying the inner window and recreating it, and
62 #  [concat ON-READY [list ORIENTATION]]
63 #  just after.  The inner window to use is called .i.i.b.
64 #
65 #  This uses variables, in the applet namespace,
66 #      w h border_colour border_width deforient
67 #  These should be set before setup-subwindow is called and not
68 #  modified thereafter.
69 #
70 #  The user of the subwindow machinery may call
71 #      applet::subwindow-need-recreate
72 #  if for any reason the inner window should be destroyed and recreated.
73 #
74 # Alternatively, it may request that a subprocess be spawned
75 # repeatedly with the xid of a suitable window.
76 #      applet::setup-subproc GET-CMDLINE
77 #  Then the main code will call [concat GET_CMDLINE [list XID ORIENTATION]]
78 #  to get the command line to run.
79 #
80 #  This also uses the same variables as setup-subwindow.
81
82 wm withdraw .
83
84 tktray::icon .i -class example
85 .i configure -docked 1
86
87 fconfigure stdout -buffering none
88 fconfigure stderr -buffering none
89
90
91 namespace eval applet {
92
93 variable debug {}
94
95 proc debug {m} {
96     variable debug
97     if {![llength $debug]} return
98     uplevel #0 $debug [list $m]
99 }
100
101 proc setup-debug {d} {
102     variable debug $d
103 }
104
105 # used by both menus and tooltips
106 variable posted 0
107
108 #----- menus -----
109
110 proc setup-button-menu {b} {
111     bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
112     menu .m$b -tearoff 0
113 }
114
115 proc menubuttonpressed {b x y} {
116     variable posted
117     tooltip-cancel
118     if {$posted == $b} {
119         debug "unpost $posted toggle"
120         .m$posted unpost
121         set posted 0
122     } elseif {[winfo exists .m$b]} {
123         if {$posted} {
124             .m$posted unpost
125             debug "unpost $posted other"
126         }
127         debug "post $b"
128         set posted $b
129         .m$b post $x $y
130     }
131 }
132
133 proc msel {} {
134     variable posted
135     set posted 0
136 }
137
138 #----- tooltips -----
139
140 variable tooltip_on_vis {}
141 variable tooltip_on_invis {}
142
143 proc tooltip-starttimer {state x y} {
144     variable tooltip_after
145     variable posted
146     variable tooltip_inwindow
147     if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
148     catch { after cancel $tooltip_after }
149     set tooltip_after [after 500 applet::tooltip-show $x $y]
150 }
151
152 proc tooltip-cancel {} {
153     variable tooltip_after
154     variable tooltip_on_invis
155     catch { after cancel $tooltip_after }
156     catch { unset $tooltip_after }
157     wm withdraw .tt
158     uplevel #0 $tooltip_on_invis
159 }
160
161 set tooltip_inwindow 0
162
163 proc tooltip-enter {state x y} {
164     variable tooltip_inwindow
165     set tooltip_inwindow 1
166     tooltip-starttimer $state $x $y
167 }
168
169 proc tooltip-leave {} {
170     variable tooltip_inwindow
171     set tooltip_inwindow 0
172     tooltip-cancel
173 }
174
175 proc setup-tooltip {on_vis on_invis} {
176     foreach v {vis invis} {
177         variable tooltip_on_$v [set on_$v]
178     }
179     bind .i <Enter> { applet::tooltip-enter %s %X %Y }
180     bind .i <Leave> { applet::tooltip-leave }
181     bind .i <ButtonRelease> { 
182         applet::tooltip-cancel
183         applet::tooltip-starttimer %s %X %Y
184     }
185     bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
186     toplevel .tt -background black
187     wm withdraw .tt
188     wm overrideredirect .tt 1
189     label .tt.t -justify left -background {#EEE1B3}
190     pack .tt.t -padx 1 -pady 1
191     tooltip-set {}
192 }
193
194 proc tooltip-set {s} {
195     .tt.t configure -text $s
196 }
197
198 proc tooltip-show {x y} {
199     variable tooltip_on_vis
200     incr x 9
201     incr y 9
202     wm geometry .tt +$x+$y
203     wm deiconify .tt
204     uplevel #0 $tooltip_on_vis
205 }
206
207 #----- simple images -----
208
209 proc setimage {image} {
210     .i configure -image $image
211 }
212
213 #----- subwindow -----
214
215 variable subwindow_on_destroying
216 variable subwindow_on_ready
217
218 variable w 50
219 variable h 50
220 variable deforient horizontal
221 variable border_colour darkblue
222 variable border_width 1
223
224 proc subwindow-need-recreate {} {
225     variable innerwindow_after
226     debug "IW-EVENT"
227     if {[info exists innerwindow_after]} return
228     set innerwindow_after [after idle applet::innerwindow-resetup]
229 }
230
231 proc innerwindow-resetup {} {
232     variable innerwindow_after
233     variable subwindow_on_destroying
234     variable subwindow_on_ready
235     variable border_colour
236     variable border_width
237     variable deforient
238     unset innerwindow_after
239
240     debug RESETUP
241
242     if {![winfo exists .i.i]} return
243     destroy [frame .i.i.make-exist]
244
245     uplevel #0 $subwindow_on_destroying
246     catch { destroy .i.i.b }
247
248     set orientation [.i orientation]
249     debug "orientation $orientation"
250     if {![string compare $orientation unknown]} {
251         set orientation $deforient
252     }
253     .i configure -image applet::innerwindow-ph-$orientation
254
255     frame .i.i.b -background $border_colour -bd $border_width
256     pack .i.i.b -fill both -side left -expand 1
257
258     uplevel #0 $subwindow_on_ready [list $orientation]
259 }
260
261 proc setup-subwindow {on_destroying on_ready} {
262     variable w
263     variable h
264
265     foreach v {on_destroying on_ready} {
266         variable subwindow_$v [set $v]
267     }
268
269     image create photo applet::innerwindow-ph-horizontal -width $w -height 2
270     image create photo applet::innerwindow-ph-vertical -width 2 -height $h
271     .i configure -image applet::innerwindow-ph-horizontal
272
273     destroy [frame .i.make-exist]
274     destroy [frame .i.i.make-exist]
275     bind .i <<IconConfigure>> { 
276         applet::subwindow-need-recreate
277     }
278 }
279
280 #----- subprocess -----
281
282 variable subproc none
283 variable ratelimit {}
284
285 proc setup-subproc {get_cmdline} {
286     variable subproc_get_cmdline $get_cmdline
287     setup-subwindow applet::subproc-destroying applet::subproc-ready
288 }
289
290 proc subproc-destroying {} {
291     variable subproc
292     debug "DESTROYING $subproc"
293
294     catch { destroy .i.i.b.c }
295
296     switch -exact $subproc {
297         none { }
298         old { }
299         default { kill $subproc; set subproc old }
300     }
301 }
302
303 proc subproc-ready {orientation} {
304     variable subproc
305     variable subproc_orientation $orientation
306     debug "READY $subproc"
307
308     frame .i.i.b.c -container 1 -background orange
309     pack .i.i.b.c -fill both -side left -expand 1
310
311     switch -exact $subproc {
312         none {
313             run-child
314         }
315         old {
316             # wait for it to die
317         }
318         default {
319             error "unexpected state $subproc"
320         }
321     }
322     debug "READY-done $subproc"
323 }
324
325 proc run-child {} {
326     variable subproc
327     variable ratelimit
328     variable subproc_get_cmdline
329     variable subproc_orientation
330
331     set id [winfo id .i.i.b.c]
332     set cmd [uplevel #0 $subproc_get_cmdline [list $id $subproc_orientation]]
333
334     debug "RUN-CHILD $subproc"
335     set now [clock seconds]
336     lappend ratelimit $now
337     while {[lindex $ratelimit 0] < {$now - 10}} {
338         set ratelimit [lrange $ratelimit 1 end]
339     }
340     if {[llength $ratelimit] > 10} {
341         debug stderr "crashing repeatedly, quitting $ratelimit"
342         exit 127
343     }
344
345     set subproc none
346     set subproc [subproc::fork applet::child-died {
347         execl [lindex $cmd 0] [lrange $cmd 1 end]
348     }]
349     debug "FORKED $subproc"
350 }
351
352 proc child-died {how how2} {
353     debug "DIED $how $how2"
354     variable subproc
355     switch -exact $subproc {
356         old {
357             set subproc none
358             run-child
359         }
360         default {
361             set subproc none
362             subwindow-need-recreate
363         }
364     }
365 }
366
367 }