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