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