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
50
51
52
53
54
55
56
57
|
##ifdef CAMLTK
let tag_bind widget tag eventsequence action =
check_class widget widget_text_table;
tkCommand [|
cCAMLtoTKwidget widget_text_table widget;
TkToken "tag";
TkToken "bind";
cCAMLtoTKtextTag tag;
cCAMLtoTKeventSequence eventsequence;
let register f what =
register_callback widget ~callback:(wrapeventInfo f what) in
begin match action with
| BindRemove -> TkToken ""
| BindSet (what, f) ->
let cbId = register f what in
TkToken ("camlcb " ^ cbId ^ (writeeventField what))
| BindSetBreakable (what, f) ->
let cbId = register f what in
TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
" ; if { $BreakBindingsSequence == 1 } then { break ;} ; \
set BreakBindingsSequence 0")
| BindExtend (what, f) ->
let cbId = register f what in
TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
end
|]
;;
##else
let tag_bind ~tag ~events ?(extend = false) ?(breakable = false)
?(fields = []) ?action widget =
tkCommand [|
cCAMLtoTKwidget widget;
TkToken "tag";
TkToken "bind";
cCAMLtoTKtextTag tag;
cCAMLtoTKeventSequence events;
begin match action with
| None -> TkToken ""
| Some f ->
let cbId =
register_callback widget ~callback: (wrapeventInfo f fields) in
let cb = if extend then "+camlcb " else "camlcb " in
let cb = cb ^ cbId ^ writeeventField fields in
let cb =
if breakable then
cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
^ " ; set BreakBindingsSequence 0"
else cb in
TkToken cb
end
|]
;;
##endif
|
