1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
proc createContextMenu {w name} {
global _db
set _db(context,$name) $w
set m [menu $_db(context,$name).menu$name -tearoff 0]
bind $_db(context,$name) <Button-1> "+initContext $name %X %Y"
bind $_db(context,$name) <Control-Button-1> "+popupContext $name %X %Y"
bind $_db(context,$name) <Button-3> "+popupContext $name %X %Y"
bind $_db(context,$name) <ButtonRelease-1> "+unpopupContext $name"
return $m
}
proc initContext {name x y} {
global _db
set _db(context,delay) 500
set _db(afterid,$name) [after $_db(context,delay) "popupContext $name $x $y"]
set _db(anymotionbind,$name) [bind $_db(context,$name) <Any-Motion>]
bind $_db(context,$name) <Any-Motion> "+cancelContext $name"
}
proc cancelContext {name} {
global _db
catch {after cancel $_db(afterid,$name)}
catch {bind $_db(context,$name) <Any-Motion> $_db(anymotionbind,$name)}
}
proc popupContext {name x y} {
bug poping up name!
global _db
#$_db(context,$name).menu$name post $x $y
tk_popup $_db(context,$name).menu$name $x $y
}
proc unpopupContext {name} {
global _db
cancelContext $name
$_db(context,$name).menu$name unpost
}
# destroy .q
# toplevel .q
# pack [text .q.t]
# createContext .q.t test
# .q.t.menutest add command -label dfg
# .q.t.menutest add command -label dfgdfgdfg
|