blob: 6da2a1daade8533adc182a29972d4864d1be1450 (
plain)
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
(* $Id$ *)
open Widget
type callback_buffer = string list
(* Buffer for reading callback arguments *)
type tkArgs =
TkToken of string
| TkTokenList of tkArgs list (* to be expanded *)
| TkQuote of tkArgs (* mapped to Tcl list *)
type cbid = int
external opentk : string -> string -> unit
= "camltk_opentk"
external tcl_eval : string -> string
= "camltk_tcl_eval"
external tk_mainloop : unit -> unit
= "camltk_tk_mainloop"
external tcl_direct_eval : tkArgs array -> string
= "camltk_tcl_direct_eval"
external splitlist : string -> string list
= "camltk_splitlist"
external tkreturn : string -> unit
= "camltk_return"
external callback_init : unit -> unit
= "camltk_init"
exception TkError of string
(* Raised by the communication functions *)
let _ = Callback.register_exception "tkerror" (TkError "")
(* Debugging support *)
let debug =
ref (try Sys.getenv "CAMLTKDEBUG"; true
with Not_found -> false)
(* This is approximative, since we don't quote what needs to be quoted *)
let dump_args args =
let rec print_arg = function
TkToken s -> prerr_string s; prerr_string " "
| TkTokenList l -> List.iter fun:print_arg l
| TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
in
Array.iter fun:print_arg args;
prerr_newline()
(*
* Evaluating Tcl code
* debugging support should not affect performances...
*)
let tkEval args =
if !debug then dump_args args;
let res = tcl_direct_eval args in
if !debug then begin
prerr_string "->>";
prerr_endline res
end;
res
(*
* Callbacks
*)
let cCAMLtoTKwidget w =
TkToken (Widget.name w)
let cTKtoCAMLwidget = function
"" -> raise (Invalid_argument "cTKtoCAMLwidget")
| s -> Widget.get_atom s
let callback_naming_table =
(Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
let callback_memo_table =
(Hashtbl.create 401 : (any widget, int) Hashtbl.t)
let new_function_id =
let counter = ref 0 in
function () -> incr counter; !counter
let string_of_cbid = string_of_int
(* Add a new callback, associated to widget w *)
(* The callback should be cleared when w is destroyed *)
let register_callback w callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table key:id data:f;
if (forget_type w) <> (forget_type Widget.dummy) then
Hashtbl.add callback_memo_table key:(forget_type w) data:id;
(string_of_cbid id)
let clear_callback id =
Hashtbl.remove callback_naming_table key:id
(* Clear callbacks associated to a given widget *)
let remove_callbacks w =
let w = forget_type w in
let cb_ids = Hashtbl.find_all callback_memo_table key:w in
List.iter fun:clear_callback cb_ids;
for i = 1 to List.length cb_ids do
Hashtbl.remove callback_memo_table key:w
done
(* Hand-coded callback for destroyed widgets
* This may be extended by the application, or by other layers of Camltk.
* Could use bind + of Tk, but I'd rather give an alternate mechanism so
* that hooks can be set up at load time (i.e. before openTk)
*)
let destroy_hooks = ref []
let add_destroy_hook f =
destroy_hooks := f :: !destroy_hooks
let _ =
add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w)
let install_cleanup () =
let call_destroy_hooks = function
[wname] ->
let w = cTKtoCAMLwidget wname in
List.iter fun:(fun f -> f w) !destroy_hooks
| _ -> raise (TkError "bad cleanup callback") in
let fid = new_function_id () in
Hashtbl.add callback_naming_table key:fid data:call_destroy_hooks;
(* setup general destroy callback *)
tcl_eval ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}")
let prerr_cbid id =
prerr_string "camlcb "; prerr_int id
(* The callback dispatch function *)
let dispatch_callback id args =
if !debug then begin
prerr_cbid id;
List.iter fun:(fun x -> prerr_string " "; prerr_string x) args;
prerr_newline()
end;
(Hashtbl.find callback_naming_table key:id) args;
if !debug then prerr_endline "<<-"
let protected_dispatch id args =
try
Printexc.print (dispatch_callback id) args
with
Out_of_memory -> raise Out_of_memory
| Sys.Break -> raise Sys.Break
| e -> flush Pervasives.stderr
let _ = Callback.register "camlcb" protected_dispatch
(* Make sure the C variables are initialised *)
let _ = callback_init ()
(* Different version of initialisation functions *)
(* Native opentk is [opentk display class] *)
let openTk () =
opentk "" "LablTk";
install_cleanup();
Widget.default_toplevel
let openTkClass s =
opentk "" s;
install_cleanup();
Widget.default_toplevel
let openTkDisplayClass display:disp cl =
opentk disp cl;
install_cleanup();
Widget.default_toplevel
(* Destroy all widgets, thus cleaning up table and exiting the loop *)
let closeTk () =
tcl_eval "destroy ."; ()
let mainLoop =
tk_mainloop
(* [register tclname f] makes [f] available from Tcl with
name [tclname] *)
let register tclname callback:cb =
let s = register_callback Widget.default_toplevel callback:cb in
tcl_eval (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
tclname s);
()
|
