# General purpose code for being a tray applet proc manyset {list args} { foreach val $list var $args { upvar 1 $var my set my $val } } 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 # # 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 # # Debug: # # Caller may call # applet::setup-debug ON-DEBUG # which will result in calls to [concat ON-DEBUG [list MESSAGE]] # (or ON-DEBUG may be "" in which case messages are discarded) # # 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 \ # WIDTH HEIGHT DEFAULT-ORIENTATION BORDER-COLOUR BORDER-WIDTH \ # 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. # # 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 \ # WIDTH HEIGHT DEFAULT-ORIENTATION BORDER-COLOUR BORDER-WIDTH \ # GET-CMDLINE # Then the main code will call [concat GET_CMDLINE [list XID ORIENTATION]] # to get the command line to run. wm withdraw . tktray::icon .i -class example .i configure -docked 1 fconfigure stdout -buffering none fconfigure stderr -buffering none namespace eval applet { variable debug {} proc debug {m} { variable debug if {![llength $debug]} return uplevel #0 $debug [list $m] } proc setup-debug {d} { variable debug $d } # used by both menus and tooltips variable posted 0 #----- menus ----- proc setup-button-menu {b} { bind .i.i { applet::menubuttonpressed %b %X %Y } menu .m$b -tearoff 0 } proc menubuttonpressed {b x y} { variable posted tooltip-cancel if {$posted == $b} { debug "unpost $posted toggle" .m$posted unpost set posted 0 } elseif {[winfo exists .m$b]} { if {$posted} { .m$posted unpost debug "unpost $posted other" } 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 { applet::tooltip-enter %s %X %Y } bind .i { applet::tooltip-leave } bind .i { applet::tooltip-cancel applet::tooltip-starttimer %s %X %Y } bind .i { 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 incr x 9 incr y 9 wm geometry .tt +$x+$y wm deiconify .tt uplevel #0 $tooltip_on_vis } #----- simple images ----- proc setimage {image} { .i configure -image $image } #----- subwindow ----- variable subwindow_on_destroying variable subwindow_on_ready proc subwindow-need-recreate {} { variable innerwindow_after debug "IW-EVENT" 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 subwindow_border_colour variable subwindow_border_width variable subwindow_default_orientation unset innerwindow_after 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 "orientation $orientation" if {![string compare $orientation unknown]} { set orientation $subwindow_default_orientation } .i configure -image applet::innerwindow-ph-$orientation frame .i.i.b -background darkblue -bd 1 pack .i.i.b -fill both -side left -expand 1 uplevel #0 $subwindow_on_ready [list $orientation] } proc setup-subwindow { w h default_orientation border_colour border_width on_destroying on_ready } { foreach v { default_orientation border_width border_colour 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 <> { applet::subwindow-need-recreate } } #----- subprocess ----- variable subproc none variable ratelimit {} proc setup-subproc {w h deforient border_colour border_width get_cmdline} { variable subproc_get_cmdline $get_cmdline setup-subwindow $w $h $deforient $border_colour $border_width \ applet::subproc-destroying applet::subproc-ready } proc subproc-destroying {} { variable subproc 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 "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 "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 "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} { debug 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 "FORKED $subproc" } proc child-died {how how2} { debug "DIED $how $how2" variable subproc switch -exact $subproc { old { set subproc none run-child } default { set subproc none subwindow-need-recreate } } } }