File: applet.tcl

package info (click to toggle)
chiark-tcl-applet 1.0-2
  • links: PTS
  • area: main
  • in suites: bullseye, sid
  • size: 144 kB
  • sloc: tcl: 860; makefile: 32
file content (366 lines) | stat: -rw-r--r-- 9,061 bytes parent folder | download
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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
# General purpose code for being a tray applet

# Copyright 2016,2020 Ian Jackson
# SPDX-License-Identifier: GPL-3.0-or-later
# There is NO WARRANTY.

package require Tclx
package require tktray

#----- general machinery -----

# Interface:
#
#  tk::tktray widget is called .i
#
# Tooltip:
#
#   Caller may call
#      applet::setup-tooltip ON-VISIBLE ON-INVISIBLE
#   to make applet have a tooltip.
#
#   ON-VISIBLE and ON-INVISIBLE will be globally eval'd
#   when the tooltip becomes visible and invisible.
#
#   Caller should call
#      applet::tooltip-set TEXT-MAYBE-MULTILINE
#   whenever they like.
# 
# Button presses
#
#    Caller may bind .i.i <ButtonPress-$b>
#
#    Alternatively caller may call  applet::setup-button-menu $b
#    which will generate a menu .m$b which the user can configure
#    and which will automatically be posted and unposted etc.
#    In this case the caller should arrange that all of their
#    menus, when an item is selected, call
#      applet::msel
#
# Icon:
#
#  Caller should call:
#      applet::setimage IMAGE
#  as necessary.
#
# Alternatively of icon, it may provide other arrangements for
# using the provided subwindow.  Such a caller should call
#      applet::setup-subwindow ON-DESTROYING ON-READY
#  Then the main code will call ON-DESTROYING just before
#  destroying the inner window and recreating it, and
#  [concat ON-READY [list ORIENTATION]]
#  just after.  The inner window to use is called .i.i.b.
#
#  This uses variables, in the applet namespace,
#      w h border_colour border_width deforient
#  These should be set before setup-subwindow is called and not
#  modified thereafter.
#
#  The user of the subwindow machinery may call
#      applet::subwindow-need-recreate
#  if for any reason the inner window should be destroyed and recreated.
#
# Alternatively, it may request that a subprocess be spawned
# repeatedly with the xid of a suitable window.
#      applet::setup-subproc GET-CMDLINE
#  Then the main code will call [concat GET_CMDLINE [list XID ORIENTATION]]
#  to get the command line to run.
#
#  This also uses the same variables as setup-subwindow.

namespace eval applet {

proc become {} {
    wm withdraw .

    tktray::icon .i -class example
    .i configure -docked 1

    fconfigure stdout -buffering none
    fconfigure stderr -buffering none
}

# used by both menus and tooltips
variable posted 0
variable tooltip_offset {9 9}

#----- menus -----

proc setup-button-menu {b} {
    bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
    menu .m$b -tearoff 0
}

proc menubuttonpressed {b x y} {
    variable posted
    tooltip-cancel
    if {$posted == $b} {
	debug::debug "unpost $posted toggle"
     	.m$posted unpost
	set posted 0
    } elseif {[winfo exists .m$b]} {
	if {$posted} {
	    .m$posted unpost
	    debug::debug "unpost $posted other"
	}
	debug::debug "post $b"
	set posted $b
	.m$b post $x $y
    }
}

proc msel {} {
    variable posted
    set posted 0
}

#----- tooltips -----

variable tooltip_on_vis {}
variable tooltip_on_invis {}

proc tooltip-starttimer {state x y} {
    variable tooltip_after
    variable posted
    variable tooltip_inwindow
    if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
    catch { after cancel $tooltip_after }
    set tooltip_after [after 500 applet::tooltip-show $x $y]
}

proc tooltip-cancel {} {
    variable tooltip_after
    variable tooltip_on_invis
    catch { after cancel $tooltip_after }
    catch { unset $tooltip_after }
    wm withdraw .tt
    uplevel #0 $tooltip_on_invis
}

set tooltip_inwindow 0

proc tooltip-enter {state x y} {
    variable tooltip_inwindow
    set tooltip_inwindow 1
    tooltip-starttimer $state $x $y
}

proc tooltip-leave {} {
    variable tooltip_inwindow
    set tooltip_inwindow 0
    tooltip-cancel
}

proc setup-tooltip {on_vis on_invis} {
    foreach v {vis invis} {
	variable tooltip_on_$v [set on_$v]
    }
    bind .i <Enter> { applet::tooltip-enter %s %X %Y }
    bind .i <Leave> { applet::tooltip-leave }
    bind .i <ButtonRelease> { 
	applet::tooltip-cancel
	applet::tooltip-starttimer %s %X %Y
    }
    bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
    toplevel .tt -background black
    wm withdraw .tt
    wm overrideredirect .tt 1
    label .tt.t -justify left -background {#EEE1B3}
    pack .tt.t -padx 1 -pady 1
    tooltip-set {}
}

proc tooltip-set {s} {
    .tt.t configure -text $s
}

proc tooltip-show {x y} {
    variable tooltip_on_vis
    variable tooltip_offset
    incr x [lindex $tooltip_offset 0]
    incr y [lindex $tooltip_offset 1]
    wm geometry .tt +$x+$y
    wm deiconify .tt
    raise .tt
    uplevel #0 $tooltip_on_vis
}

#----- simple images -----

proc setimage {image} {
    .i configure -image $image
}

#----- subwindow -----

variable subwindow_on_destroying
variable subwindow_on_ready

variable w 50
variable h 50
variable deforient horizontal
variable border_colour darkblue
variable border_width 1
variable tray_width X
variable tray_height X
variable orientation vertical

proc subwindow-need-recreate {evtype why} {
    variable orientation
    variable innerwindow_after
    variable tray_width
    variable tray_height
    debug::debug "IW-EVENT $evtype $why [winfo reqwidth .i] [winfo reqheight .i] [winfo width .i] [winfo height .i] $orientation"
    switch -exact $orientation {
	horizontal { set szv height }
	vertical { set szv width }
	unknown { return }
    }
    set new_sz [winfo req$szv .i]
    if {![string compare $new_sz [set tray_$szv]]} {
	return
    }
    set tray_$szv $new_sz
#    switch -exact -- $evtype 35 { return }
    if {[info exists innerwindow_after]} return
    set innerwindow_after [after idle applet::innerwindow-resetup]
}

proc innerwindow-resetup {} {
    variable innerwindow_after
    variable subwindow_on_destroying
    variable subwindow_on_ready
    variable border_colour
    variable border_width
    variable deforient
    variable orientation
    unset innerwindow_after

    debug::debug RESETUP

    if {![winfo exists .i.i]} return
    destroy [frame .i.i.make-exist]

    uplevel #0 $subwindow_on_destroying
    catch { destroy .i.i.b }

    set orientation [.i orientation]
    debug::debug "orientation $orientation"
    if {![string compare $orientation unknown]} {
	set orientation $deforient
    }
    .i configure -image applet::innerwindow-ph-$orientation

    frame .i.i.b -background $border_colour -bd $border_width
    pack .i.i.b -fill both -side left -expand 1

    uplevel #0 $subwindow_on_ready [list $orientation]
}

proc setup-subwindow {on_destroying on_ready} {
    variable w
    variable h

    foreach v {on_destroying on_ready} {
	variable subwindow_$v [set $v]
    }

    image create photo applet::innerwindow-ph-horizontal -width $w -height 2
    image create photo applet::innerwindow-ph-vertical -width 2 -height $h
    .i configure -image applet::innerwindow-ph-horizontal

    destroy [frame .i.make-exist]
    #destroy [frame .i.i.make-exist]
    bind .i <<IconConfigure>> { 
	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"
    }
}

#----- subprocess -----

variable subproc none
variable ratelimit {}

proc setup-subproc {get_cmdline} {
    variable subproc_get_cmdline $get_cmdline
    setup-subwindow applet::subproc-destroying applet::subproc-ready
}

proc subproc-destroying {} {
    variable subproc
    debug::debug "DESTROYING $subproc"

    catch { destroy .i.i.b.c }

    switch -exact $subproc {
	none { }
	old { }
	default { kill $subproc; set subproc old }
    }
}

proc subproc-ready {orientation} {
    variable subproc
    variable subproc_orientation $orientation
    debug::debug "READY $subproc"

    frame .i.i.b.c -container 1 -background orange
    pack .i.i.b.c -fill both -side left -expand 1

    switch -exact $subproc {
	none {
	    run-child
	}
	old {
	    # wait for it to die
	}
	default {
	    error "unexpected state $subproc"
	}
    }
    debug::debug "READY-done $subproc"
}

proc run-child {} {
    variable subproc
    variable ratelimit
    variable subproc_get_cmdline
    variable subproc_orientation

    set id [winfo id .i.i.b.c]
    set cmd [uplevel #0 $subproc_get_cmdline [list $id $subproc_orientation]]

    debug::debug "RUN-CHILD $subproc"
    set now [clock seconds]
    lappend ratelimit $now
    while {[lindex $ratelimit 0] < {$now - 10}} {
	set ratelimit [lrange $ratelimit 1 end]
    }
    if {[llength $ratelimit] > 10} {
	puts stderr "crashing repeatedly, quitting $ratelimit"
	exit 127
    }

    set subproc none
    set subproc [subproc::fork applet::child-died {
	execl [lindex $cmd 0] [lrange $cmd 1 end]
    }]
    debug::debug "FORKED $subproc"
}

proc child-died {how how2} {
    debug::debug "DIED $how $how2"
    variable subproc
    switch -exact $subproc {
	old {
	    set subproc none
	    run-child
	}
	default {
	    set subproc none
	    subwindow-need-recreate child-died child-died
	}
    }
}

}