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