applet.tcl

   1 # General purpose code for being a tray applet
   2
   3 package require Tclx
   4 package require tktray
   5
   6 #----- general machinery -----
   7
   8 # Interface:
   9 #
  10 #  tk::tktray widget is called .i
  11 #
  12 # Tooltip:
  13 #
  14 #   Caller may call
  15 #      applet::setup-tooltip ON-VISIBLE ON-INVISIBLE
  16 #   to make applet have a tooltip.
  17 #
  18 #   ON-VISIBLE and ON-INVISIBLE will be globally eval'd
  19 #   when the tooltip becomes visible and invisible.
  20 #
  21 #   Caller should call
  22 #      applet::tooltip-set TEXT-MAYBE-MULTILINE
  23 #   whenever they like.
  24 #
  25 # Button presses
  26 #
  27 #    Caller may bind .i.i <ButtonPress-$b>
  28 #
  29 #    Alternatively caller may call  applet::setup-button-menu $b
  30 #    which will generate a menu .m$b which the user can configure
  31 #    and which will automatically be posted and unposted etc.
  32 #    In this case the caller should arrange that all of their
  33 #    menus, when an item is selected, call
  34 #      applet::msel
  35 #
  36 # Icon:
  37 #
  38 #  Caller should call:
  39 #      applet::setimage IMAGE
  40 #  as necessary.
  41 #
  42 # Alternatively of icon, it may provide other arrangements for
  43 # using the provided subwindow.  Such a caller should call
  44 #      applet::setup-subwindow ON-DESTROYING ON-READY
  45 #  Then the main code will call ON-DESTROYING just before
  46 #  destroying the inner window and recreating it, and
  47 #  [concat ON-READY [list ORIENTATION]]
  48 #  just after.  The inner window to use is called .i.i.b.
  49 #
  50 #  This uses variables, in the applet namespace,
  51 #      w h border_colour border_width deforient
  52 #  These should be set before setup-subwindow is called and not
  53 #  modified thereafter.
  54 #
  55 #  The user of the subwindow machinery may call
  56 #      applet::subwindow-need-recreate
  57 #  if for any reason the inner window should be destroyed and recreated.
  58 #
  59 # Alternatively, it may request that a subprocess be spawned
  60 # repeatedly with the xid of a suitable window.
  61 #      applet::setup-subproc GET-CMDLINE
  62 #  Then the main code will call [concat GET_CMDLINE [list XID ORIENTATION]]
  63 #  to get the command line to run.
  64 #
  65 #  This also uses the same variables as setup-subwindow.
  66
  67 wm withdraw .
  68
  69 tktray::icon .i -class example
  70 .i configure -docked 1
  71
  72 fconfigure stdout -buffering none
  73 fconfigure stderr -buffering none
  74
  75
  76 namespace eval applet {
  77
  78 # used by both menus and tooltips
  79 variable posted 0
  80
  81 #----- menus -----
  82
  83 proc setup-button-menu {b} {
  84     bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
  85     menu .m$b -tearoff 0
  86 }
  87
  88 proc menubuttonpressed {b x y} {
  89     variable posted
  90     tooltip-cancel
  91     if {$posted == $b} {
  92         debug::debug "unpost $posted toggle"
  93         .m$posted unpost
  94         set posted 0
  95     } elseif {[winfo exists .m$b]} {
  96         if {$posted} {
  97             .m$posted unpost
  98             debug::debug "unpost $posted other"
  99         }
 100         debug::debug "post $b"
 101         set posted $b
 102         .m$b post $x $y
 103     }
 104 }
 105
 106 proc msel {} {
 107     variable posted
 108     set posted 0
 109 }
 110
 111 #----- tooltips -----
 112
 113 variable tooltip_on_vis {}
 114 variable tooltip_on_invis {}
 115
 116 proc tooltip-starttimer {state x y} {
 117     variable tooltip_after
 118     variable posted
 119     variable tooltip_inwindow
 120     if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
 121     catch { after cancel $tooltip_after }
 122     set tooltip_after [after 500 applet::tooltip-show $x $y]
 123 }
 124
 125 proc tooltip-cancel {} {
 126     variable tooltip_after
 127     variable tooltip_on_invis
 128     catch { after cancel $tooltip_after }
 129     catch { unset $tooltip_after }
 130     wm withdraw .tt
 131     uplevel #0 $tooltip_on_invis
 132 }
 133
 134 set tooltip_inwindow 0
 135
 136 proc tooltip-enter {state x y} {
 137     variable tooltip_inwindow
 138     set tooltip_inwindow 1
 139     tooltip-starttimer $state $x $y
 140 }
 141
 142 proc tooltip-leave {} {
 143     variable tooltip_inwindow
 144     set tooltip_inwindow 0
 145     tooltip-cancel
 146 }
 147
 148 proc setup-tooltip {on_vis on_invis} {
 149     foreach v {vis invis} {
 150         variable tooltip_on_$v [set on_$v]
 151     }
 152     bind .i <Enter> { applet::tooltip-enter %s %X %Y }
 153     bind .i <Leave> { applet::tooltip-leave }
 154     bind .i <ButtonRelease> {
 155         applet::tooltip-cancel
 156         applet::tooltip-starttimer %s %X %Y
 157     }
 158     bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
 159     toplevel .tt -background black
 160     wm withdraw .tt
 161     wm overrideredirect .tt 1
 162     label .tt.t -justify left -background {#EEE1B3}
 163     pack .tt.t -padx 1 -pady 1
 164     tooltip-set {}
 165 }
 166
 167 proc tooltip-set {s} {
 168     .tt.t configure -text $s
 169 }
 170
 171 proc tooltip-show {x y} {
 172     variable tooltip_on_vis
 173     incr x 9
 174     incr y 9
 175     wm geometry .tt +$x+$y
 176     wm deiconify .tt
 177     raise .tt
 178     uplevel #0 $tooltip_on_vis
 179 }
 180
 181 #----- simple images -----
 182
 183 proc setimage {image} {
 184     .i configure -image $image
 185 }
 186
 187 #----- subwindow -----
 188
 189 variable subwindow_on_destroying
 190 variable subwindow_on_ready
 191
 192 variable w 50
 193 variable h 50
 194 variable deforient horizontal
 195 variable border_colour darkblue
 196 variable border_width 1
 197 variable tray_width X
 198 variable tray_height X
 199 variable orientation vertical
 200
 201 proc subwindow-need-recreate {evtype why} {
 202     variable orientation
 203     variable innerwindow_after
 204     variable tray_width
 205     variable tray_height
 206     debug::debug "IW-EVENT $evtype $why [winfo reqwidth .i] [winfo reqheight .i] [winfo width .i] [winfo height .i] $orientation"
 207     switch -exact $orientation {
 208         horizontal { set szv height }
 209         vertical { set szv width }
 210         unknown { return }
 211     }
 212     set new_sz [winfo req$szv .i]
 213     if {![string compare $new_sz [set tray_$szv]]} {
 214         return
 215     }
 216     set tray_$szv $new_sz
 217 #    switch -exact -- $evtype 35 { return }
 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 border_colour
 227     variable border_width
 228     variable deforient
 229     variable orientation
 230     unset innerwindow_after
 231
 232     debug::debug RESETUP
 233
 234     if {![winfo exists .i.i]} return
 235     destroy [frame .i.i.make-exist]
 236
 237     uplevel #0 $subwindow_on_destroying
 238     catch { destroy .i.i.b }
 239
 240     set orientation [.i orientation]
 241     debug::debug "orientation $orientation"
 242     if {![string compare $orientation unknown]} {
 243         set orientation $deforient
 244     }
 245     .i configure -image applet::innerwindow-ph-$orientation
 246
 247     frame .i.i.b -background $border_colour -bd $border_width
 248     pack .i.i.b -fill both -side left -expand 1
 249
 250     uplevel #0 $subwindow_on_ready [list $orientation]
 251 }
 252
 253 proc setup-subwindow {on_destroying on_ready} {
 254     variable w
 255     variable h
 256
 257     foreach v {on_destroying on_ready} {
 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 %T "%T i=%i k=%K N=%N R=%R S=%S k=%k m=%m d=%d s=%s a=%a b=%b c=%c f=%f w,h=%w,%h o=%o p=%p t=%t x,y=%x,%y B=%B D=%D E=%E P=%P W=%W X,Y=%X,%Y"
 269     }
 270 }
 271
 272 #----- subprocess -----
 273
 274 variable subproc none
 275 variable ratelimit {}
 276
 277 proc setup-subproc {get_cmdline} {
 278     variable subproc_get_cmdline $get_cmdline
 279     setup-subwindow applet::subproc-destroying applet::subproc-ready
 280 }
 281
 282 proc subproc-destroying {} {
 283     variable subproc
 284     debug::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 {orientation} {
 296     variable subproc
 297     variable subproc_orientation $orientation
 298     debug::debug "READY $subproc"
 299
 300     frame .i.i.b.c -container 1 -background orange
 301     pack .i.i.b.c -fill both -side left -expand 1
 302
 303     switch -exact $subproc {
 304         none {
 305             run-child
 306         }
 307         old {
 308             # wait for it to die
 309         }
 310         default {
 311             error "unexpected state $subproc"
 312         }
 313     }
 314     debug::debug "READY-done $subproc"
 315 }
 316
 317 proc run-child {} {
 318     variable subproc
 319     variable ratelimit
 320     variable subproc_get_cmdline
 321     variable subproc_orientation
 322
 323     set id [winfo id .i.i.b.c]
 324     set cmd [uplevel #0 $subproc_get_cmdline [list $id $subproc_orientation]]
 325
 326     debug::debug "RUN-CHILD $subproc"
 327     set now [clock seconds]
 328     lappend ratelimit $now
 329     while {[lindex $ratelimit 0] < {$now - 10}} {
 330         set ratelimit [lrange $ratelimit 1 end]
 331     }
 332     if {[llength $ratelimit] > 10} {
 333         puts stderr "crashing repeatedly, quitting $ratelimit"
 334         exit 127
 335     }
 336
 337     set subproc none
 338     set subproc [subproc::fork applet::child-died {
 339         execl [lindex $cmd 0] [lrange $cmd 1 end]
 340     }]
 341     debug::debug "FORKED $subproc"
 342 }
 343
 344 proc child-died {how how2} {
 345     debug::debug "DIED $how $how2"
 346     variable subproc
 347     switch -exact $subproc {
 348         old {
 349             set subproc none
 350             run-child
 351         }
 352         default {
 353             set subproc none
 354             subwindow-need-recreate child-died child-died
 355         }
 356     }
 357 }
 358
 359 }