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 # Inner window subprocess:
  34 #
  35 #  Caller that needs access to inner window should define
  36 #     proc innerwindow {} { ... }
  37 #  and run
  38 #     innerwindow
  39 #  This will create
  40 #     .i.i.b      frame to contain container
  41 #     .i.i.b.c    actual container
  42 #
  43 #  Button presses
  44 #
  45 #    Caller may bind .i.i <ButtonPress-$b>
  46 #
  47 #    Alternatively caller may call  applet::setup-button-menu $b
  48 #    which will generate a menu .m$b which the user can configure
  49 #    and which will automatically be posted and unposted etc.
  50
  51 wm withdraw .
  52
  53 tktray::icon .i -class example
  54 .i configure -docked 1
  55
  56
  57 namespace eval applet {
  58
  59
  60 # used by both menus and tooltips
  61 variable posted 0
  62
  63 #----- menus -----
  64
  65 proc setup-button-menu {b} {
  66     bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
  67     menu .m$b -tearoff 0
  68 }
  69
  70 proc menubuttonpressed {b x y} {
  71     variable posted
  72     tooltip-cancel
  73     if {$posted == $b} {
  74         puts "unpost $posted toggle"
  75         .m$posted unpost
  76         set posted 0
  77     } elseif {[winfo exists .m$b]} {
  78         if {$posted} {
  79             .m$posted unpost
  80             puts "unpost $posted other"
  81         }
  82         puts "post $b"
  83         set posted $b
  84         .m$b post $x $y
  85     }
  86 }
  87
  88 proc msel {} {
  89     variable posted
  90     set posted 0
  91 }
  92
  93 #----- tooltips -----
  94
  95 variable tooltip_on_vis {}
  96 variable tooltip_on_invis {}
  97
  98 proc tooltip-starttimer {state x y} {
  99     variable tooltip_after
 100     variable posted
 101     variable tooltip_inwindow
 102     if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
 103     catch { after cancel $tooltip_after }
 104     set tooltip_after [after 500 applet::tooltip-show $x $y]
 105 }
 106
 107 proc tooltip-cancel {} {
 108     variable tooltip_after
 109     variable tooltip_on_invis
 110     catch { after cancel $tooltip_after }
 111     catch { unset $tooltip_after }
 112     wm withdraw .tt
 113     uplevel #0 $tooltip_on_invis
 114 }
 115
 116 set tooltip_inwindow 0
 117
 118 proc tooltip-enter {state x y} {
 119     variable tooltip_inwindow
 120     set tooltip_inwindow 1
 121     tooltip-starttimer $state $x $y
 122 }
 123
 124 proc tooltip-leave {} {
 125     variable tooltip_inwindow
 126     set tooltip_inwindow 0
 127     tooltip-cancel
 128 }
 129
 130 proc setup-tooltip {on_vis on_invis} {
 131     foreach v {vis invis} {
 132         variable tooltip_on_$v [set on_$v]
 133     }
 134     bind .i <Enter> { applet::tooltip-enter %s %X %Y }
 135     bind .i <Leave> { applet::tooltip-leave }
 136     bind .i <ButtonRelease> {
 137         applet::tooltip-cancel
 138         applet::tooltip-starttimer %s %X %Y
 139     }
 140     bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
 141     toplevel .tt -background black
 142     wm withdraw .tt
 143     wm overrideredirect .tt 1
 144     label .tt.t -justify left -background {#EEE1B3}
 145     pack .tt.t -padx 1 -pady 1
 146     tooltip-set {}
 147 }
 148
 149 proc tooltip-set {s} {
 150     .tt.t configure -text $s
 151 }
 152
 153 proc tooltip-show {x y} {
 154     variable tooltip_on_vis
 155     incr x 9
 156     incr y 9
 157     wm geometry .tt +$x+$y
 158     wm deiconify .tt
 159     uplevel #0 $tooltip_on_vis
 160 }
 161
 162 }
 163
 164
 165 proc innerwindow-resetup-required {why} {
 166     variable innerwindow_after
 167 puts "IW-EVENT $why"
 168     if {[info exists innerwindow_after]} return
 169     set innerwindow_after [after idle innerwindow-resetup]
 170 }
 171
 172 proc innerwindow-resetup {} {
 173     variable innerwindow_after
 174     unset innerwindow_after
 175
 176 puts RESETUP
 177
 178     innerwindow-destroying
 179
 180     catch { destroy .i.i.c }
 181     if {![winfo exists .i.i]} return
 182     destroy [frame .i.i.make-exist]
 183     catch { destroy .i.i.b.c }
 184     catch { destroy .i.i.b }
 185     frame .i.i.b
 186     pack .i.i.b -fill both -side left -expand 1
 187     frame .i.i.b.c -container 1 -background orange
 188     pack .i.i.b.c -fill both -side left -expand 1
 189 #
 190     global inner_lastw inner_lasth
 191     #set w [winfo width .i.i]
 192 #    set w [winfo width .i.i]
 193 #    set h [winfo height .i.i]
 194
 195 #    if {$w != $inner_lastw || $h != $inner_lasth} {
 196 #       set inner_lastw $w
 197 #       set inner_lasth $h
 198 #       innerwindow-ph-dummy configure -width $w -height 2
 199         innerwindow-ready
 200 #    }
 201 }
 202
 203 proc setupinnerwindow {w} {
 204     global inner_lastw inner_lasth
 205     set inner_lastw -2
 206     set inner_lasth -2
 207
 208     image create photo innerwindow-ph-dummy -width $w -height 2
 209     .i configure -image innerwindow-ph-dummy
 210
 211     destroy [frame .i.make-exist]
 212     destroy [frame .i.i.make-exist]
 213     bind .i <<IconConfigure>> { innerwindow-resetup-required IconConfigure }
 214 }
 215
 216
 217
 218 proc setimage {image} {
 219     .i configure -image $image
 220 }
 221
 222 proc fork-then {ondeath inchild} {
 223     global children errorCode errorInfo
 224     foreach f {stdout stderr} {
 225         if {[catch { flush $f } emsg]} {
 226             catch { bgerror $emsg }
 227         }
 228     }
 229     set pid [fork]
 230     if {!$pid} {
 231         if {[catch {
 232             uplevel 1 $inchild
 233         } emsg]} {
 234             puts stderr "CHILD ERROR $emsg\n$errorCode\n$errorInfo\n"
 235         }
 236         kill KILL [id process]
 237     }
 238     set children($pid) $ondeath
 239     return $pid
 240 }
 241
 242 proc chld-handler {} {
 243     global children
 244     while 1 {
 245         if {[catch { set got [wait -nohang] }]} break
 246         if {![llength $got]} break
 247         manyset $got pid how how2
 248         if {[info exists children($pid)]} {
 249             set l $children($pid)
 250             unset children($pid)
 251             if {[catch {
 252                 uplevel #0 [concat [list $l] $how $how2]
 253             } emsg]} {
 254                 catch { bgerror $emsg }
 255             }
 256         }
 257     }
 258 }
 259
 260 signal -restart trap CHLD { after idle chld-handler }