summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/support/protocol.ml
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>1999-11-16 10:29:03 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>1999-11-16 10:29:03 +0000
commit27c082c04663ff18459777e111aca4cde20df265 (patch)
treed74a2991f4712aa20929a763bb65997c16da94ff /otherlibs/labltk/support/protocol.ml
parent8f492b2886fb03a3c23f0d2581222445285d6d28 (diff)
leave labltk only in olabl branch
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2536 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'otherlibs/labltk/support/protocol.ml')
-rw-r--r--otherlibs/labltk/support/protocol.ml190
1 files changed, 0 insertions, 190 deletions
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
deleted file mode 100644
index 6da2a1daa..000000000
--- a/otherlibs/labltk/support/protocol.ml
+++ /dev/null
@@ -1,190 +0,0 @@
-(* $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);
- ()
-