X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl-applet.git;a=blobdiff_plain;f=applet.tcl;h=5d9a65dc1c4fe487b8191837889d063414456028;hp=c68d6e91de0ea60c6971f91cec1c34880d214b36;hb=80b7c5d7160f63b9f16fd62534352b15e4c9ec6f;hpb=19512a7a55f2f18b3731702c0b63cfdbdd4fad04 diff --git a/applet.tcl b/applet.tcl index c68d6e9..5d9a65d 100644 --- a/applet.tcl +++ b/applet.tcl @@ -29,18 +29,8 @@ package require tktray # Caller should call # applet::tooltip-set TEXT-MAYBE-MULTILINE # whenever they like. -# -# Inner window subprocess: -# -# Caller that needs access to inner window should define -# proc innerwindow {} { ... } -# and run -# innerwindow -# This will create -# .i.i.b frame to contain container -# .i.i.b.c actual container # -# Button presses +# Button presses # # Caller may bind .i.i # @@ -50,15 +40,64 @@ package require tktray # 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 @@ -74,15 +113,15 @@ proc menubuttonpressed {b x y} { variable posted tooltip-cancel if {$posted == $b} { - puts "unpost $posted toggle" + debug "unpost $posted toggle" .m$posted unpost set posted 0 } elseif {[winfo exists .m$b]} { if {$posted} { .m$posted unpost - puts "unpost $posted other" + debug "unpost $posted other" } - puts "post $b" + debug "post $b" set posted $b .m$b post $x $y } @@ -162,62 +201,160 @@ proc tooltip-show {x y} { uplevel #0 $tooltip_on_vis } +#----- simple images ----- + +proc setimage {image} { + .i configure -image $image } +#----- subwindow ----- + +variable subwindow_on_destroying +variable subwindow_on_ready -proc innerwindow-resetup-required {why} { +proc subwindow-need-recreate {} { variable innerwindow_after -puts "IW-EVENT $why" + debug "IW-EVENT" if {[info exists innerwindow_after]} return - set innerwindow_after [after idle innerwindow-resetup] + 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 -puts RESETUP + debug RESETUP - innerwindow-destroying - - catch { destroy .i.i.c } if {![winfo exists .i.i]} return destroy [frame .i.i.make-exist] - catch { destroy .i.i.b.c } + + uplevel #0 $subwindow_on_destroying catch { destroy .i.i.b } - frame .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 - frame .i.i.b.c -container 1 -background orange - pack .i.i.b.c -fill both -side left -expand 1 -# - global inner_lastw inner_lasth - #set w [winfo width .i.i] -# set w [winfo width .i.i] -# set h [winfo height .i.i] -# if {$w != $inner_lastw || $h != $inner_lasth} { -# set inner_lastw $w -# set inner_lasth $h -# innerwindow-ph-dummy configure -width $w -height 2 - innerwindow-ready -# } + uplevel #0 $subwindow_on_ready [list $orientation] } -proc setupinnerwindow {w} { - global inner_lastw inner_lasth - set inner_lastw -2 - set inner_lasth -2 +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 innerwindow-ph-dummy -width $w -height 2 - .i configure -image innerwindow-ph-dummy + 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 <> { innerwindow-resetup-required IconConfigure } + 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 + } + } +} -proc setimage {image} { - .i configure -image $image }