blob: d7acf06f7e8d4fa33722e227b467623405ba10da (
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
|
(***********************************************************************)
(* *)
(* MLTk, Tcl/Tk interface of Objective Caml *)
(* *)
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
(* projet Cristal, INRIA Rocquencourt *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique and Kyoto University. All rights reserved. *)
(* This file is distributed under the terms of the GNU Library *)
(* General Public License, with the special exception on linking *)
(* described in file LICENSE found in the Objective Caml source tree. *)
(* *)
(***********************************************************************)
(* Some notion of synthetic events *)
open Camltk
open Widget
open Protocol
(* To each event is associated a table of (widget, callback) *)
let events = Hashtbl.create 37
(* Notes:
* "cascading" events (on the same event) are not supported
* Only one binding active at a time for each event on each widget.
*)
(* Get the callback table associated with <name>. Initializes if required *)
let get_event name =
try Hashtbl.find events name
with
Not_found ->
let h = Hashtbl.create 37 in
Hashtbl.add events name h;
(* Initialize the callback invocation mechanism, based on
variable trace
*)
let var = "camltk_events(" ^ name ^")" in
let tkvar = Textvariable.coerce var in
let rec set () =
Textvariable.handle tkvar
(fun () ->
begin match Textvariable.get tkvar with
"all" -> (* Invoke all callbacks *)
Hashtbl.iter
(fun p f ->
try
f (cTKtoCAMLwidget p)
with _ -> ())
h
| p -> (* Invoke callback for p *)
try
let w = cTKtoCAMLwidget p
and f = Hashtbl.find h p in
f w
with
_ -> ()
end;
set ()(* reactivate the callback *)
) in
set();
h
(* Remove binding for event <name> on widget <w> *)
let remove w name =
Hashtbl.remove (get_event name) (Widget.name w)
(* Adds <f> as callback for widget <w> on event <name> *)
let bind w name f =
remove w name;
Hashtbl.add (get_event name) (Widget.name w) f
(* Sends event <name> to all widgets *)
let broadcast name =
Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all"
(* Sends event <name> to widget <w> *)
let send name w =
Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")"))
(Widget.name w)
(* Remove all callbacks associated to widget <w> *)
let remove_callbacks w =
Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events
let _ =
add_destroy_hook remove_callbacks
|
