chiark / gitweb /
split up
[chiark-tcl-applet.git] / applet.tcl
1
2 #----- general machinery -----
3
4 package require tktray
5
6 wm withdraw .
7
8 tktray::icon .i -class example
9 .i configure -docked 1
10
11 set posted 0
12
13 foreach b {1 3} {
14     menu .m$b -tearoff 0
15 }
16
17 proc pressed {b x y} {
18     global posted
19     tooltip_cancel
20     if {$posted == $b} {
21         puts "unpost $posted toggle"
22         .m$posted unpost
23         set posted 0
24     } elseif {[winfo exists .m$b]} {
25         if {$posted} {
26             .m$posted unpost
27             puts "unpost $posted other"
28         }
29         puts "post $b"
30         set posted $b
31         .m$b post $x $y
32     }
33 }
34
35 proc msel {} {
36     global posted
37     set posted 0
38 }
39
40 bind .i <ButtonPress> { pressed %b %X %Y }
41
42 proc tooltip_starttimer {state x y} {
43     global tooltip_after posted tooltip_inwindow
44     if {$state || $posted || !$tooltip_inwindow} { tooltip_cancel; return }
45     catch { after cancel $tooltip_after }
46     set tooltip_after [after 500 tooltip_show $x $y]
47 }
48
49 proc tooltip_cancel {} {
50     global tooltip_after
51     catch { after cancel $tooltip_after }
52     catch { unset $tooltip_after }
53     wm withdraw .tt
54 }
55
56 set tooltip_inwindow 0
57
58 proc tooltip_enter {state x y} {
59     global tooltip_inwindow
60     set tooltip_inwindow 1
61     tooltip_starttimer $state $x $y
62 }
63
64 proc tooltip_leave {} {
65     global tooltip_inwindow
66     set tooltip_inwindow 0
67     tooltip_cancel
68 }
69
70 proc setuptooltip {} {
71     bind .i <Enter> { tooltip_enter %s %X %Y }
72     bind .i <Leave> { tooltip_leave }
73     bind .i <ButtonRelease> { tooltip_cancel; tooltip_starttimer %s %X %Y }
74     bind .i <Motion> { tooltip_starttimer %s %X %Y }
75     toplevel .tt -background black
76     wm withdraw .tt
77     wm overrideredirect .tt 1
78     label .tt.t -justify left -background {#EEE1B3}
79     pack .tt.t -padx 1 -pady 1
80     settooltip {}
81 }
82
83 proc settooltip {s} {
84     .tt.t configure -text $s
85 }
86
87 proc tooltip_show {x y} {
88     incr x 9
89     incr y 9
90     wm geometry .tt +$x+$y
91     wm deiconify .tt
92 }
93
94 proc setimage {image} {
95     .i configure -image $image
96 }