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