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