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