chiark / gitweb /
mention msel
[chiark-tcl-applet.git] / 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