example

   1 #!/usr/bin/wish8.4 -f
   2 # -*- Tcl -*-
   3
   4 source applet.tcl
   5 source subproc.tcl
   6
   7 #----- menu -----
   8
   9 foreach b {1 3} {
  10     applet::setup-button-menu $b
  11 }
  12
  13 .m1 add command -command { applet::msel; puts hi } -label hi
  14 .m3 add command -command { applet::msel; puts boo } -label boo
  15
  16 #image create bitmap ims -file gs_s.xbm
  17 #image create bitmap ims -file /usr/share/ghostscript/8.71/lib/gs_s.xbm
  18 #setimage ims
  19 #setimage ims
  20
  21 applet::setup-tooltip { puts VIS } { puts INVIS }
  22 applet::tooltip-set "line\nanother"
  23
  24 fconfigure stdout -buffering line
  25
  26 set status none
  27
  28 proc innerwindow-destroying {} {
  29     global status
  30     puts "DESTROYING $status"
  31     switch -exact $status {
  32         none { }
  33         old { }
  34         default { kill $status; set status old }
  35     }
  36 }
  37
  38 proc innerwindow-ready {} {
  39     global status
  40     puts "READY $status"
  41     switch -exact $status {
  42         none {
  43             run-child
  44         }
  45         old {
  46             # wait for it to die
  47         }
  48         default {
  49             error "unexpected state $status"
  50         }
  51     }
  52     puts "READY-done $status"
  53 }
  54
  55 set ratelimit 0
  56
  57 proc run-child {} {
  58     global status ratelimit
  59
  60     puts "RUN-CHILD $status"
  61     set now [clock seconds]
  62     lappend ratelimit $now
  63     while {[lindex $ratelimit 0] < {$now - 10}} {
  64         set ratelimit [lrange $ratelimit 1 end]
  65     }
  66     if {[llength $ratelimit] > 10} {
  67         puts stderr "crashing repeatedly, quitting $ratelimit"
  68         exit 127
  69     }
  70
  71     set status none
  72     set status [subproc::fork child-died {
  73         execl xacpi-simple [list -into [winfo id .i.i.b.c]]
  74     }]
  75     puts "FORKED $status"
  76 }
  77
  78 proc child-died {how how2} {
  79     puts "DIED $how $how2"
  80     global status
  81     switch -exact $status {
  82         old {
  83             set status none
  84             run-child
  85         }
  86         default {
  87             set status none
  88             innerwindow-resetup-required "child died"
  89         }
  90     }
  91 }
  92
  93 setupinnerwindow 40