applet.tcl

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