diff options
author | Jun FURUSE / 古瀬 淳 <jun.furuse@gmail.com> | 2002-02-26 12:12:07 +0000 |
---|---|---|
committer | Jun FURUSE / 古瀬 淳 <jun.furuse@gmail.com> | 2002-02-26 12:12:07 +0000 |
commit | 66a5137082351df02cc58b7afed0dd73fa5d1bad (patch) | |
tree | 4354ddf4ba638b4b72ccbe6936f45711f3992b17 /otherlibs/labltk/support/protocol.ml | |
parent | f3a1293b03bea85d83213abb8a8824d32f93d02f (diff) |
opentk
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4439 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'otherlibs/labltk/support/protocol.ml')
-rw-r--r-- | otherlibs/labltk/support/protocol.ml | 144 |
1 files changed, 109 insertions, 35 deletions
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index cb8bcbb33..e6c378504 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -1,22 +1,21 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) -open StdLabels open Support open Widget @@ -30,7 +29,7 @@ type tkArgs = type cbid = int -external opentk : display:string -> clas:string -> unit +external opentk_low : string list -> unit = "camltk_opentk" external tcl_eval : string -> string = "camltk_tcl_eval" @@ -44,6 +43,11 @@ external tkreturn : string -> unit = "camltk_return" external callback_init : unit -> unit = "camltk_init" +external finalizeTk : unit -> unit + = "camltk_finalize" + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] (This is installed at + [install_cleanup ()] *) let tcl_command s = ignore (tcl_eval s);; @@ -60,10 +64,10 @@ let debug = let dump_args args = let rec print_arg = function TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter ~f:print_arg l + | TkTokenList l -> List.iter print_arg l | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " in - Array.iter ~f:print_arg args; + Array.iter print_arg args; prerr_newline() (* @@ -86,14 +90,15 @@ let tkCommand args = ignore (tkEval args) * Callbacks *) +(* LablTk only *) let cCAMLtoTKwidget w = + (* Widget.check_class w table; (* with subtyping, it is redundant *) *) 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) @@ -110,9 +115,9 @@ let string_of_cbid = string_of_int (* 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; + Hashtbl.add callback_naming_table id f; if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl'.add callback_memo_table ~key:(forget_type w) ~data:id; + Hashtbl.add callback_memo_table (forget_type w) id; (string_of_cbid id) let clear_callback id = @@ -122,7 +127,7 @@ let clear_callback id = let remove_callbacks w = let w = forget_type w in let cb_ids = Hashtbl.find_all callback_memo_table w in - List.iter ~f:clear_callback cb_ids; + List.iter clear_callback cb_ids; for i = 1 to List.length cb_ids do Hashtbl.remove callback_memo_table w done @@ -143,13 +148,13 @@ let install_cleanup () = let call_destroy_hooks = function [wname] -> let w = cTKtoCAMLwidget wname in - List.iter ~f:(fun f -> f w) !destroy_hooks + List.iter (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; + Hashtbl.add callback_naming_table fid call_destroy_hooks; (* setup general destroy callback *) - tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}") - + tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}"); + at_exit finalizeTk let prerr_cbid id = prerr_string "camlcb "; prerr_int id @@ -158,7 +163,7 @@ let prerr_cbid id = let dispatch_callback id args = if !debug then begin prerr_cbid id; - List.iter ~f:(fun x -> prerr_string " "; prerr_string x) args; + List.iter (fun x -> prerr_string " "; prerr_string x) args; prerr_newline() end; (Hashtbl.find callback_naming_table id) args; @@ -166,11 +171,16 @@ let dispatch_callback id args = let protected_dispatch id args = try - Printexc.print (dispatch_callback id) args + dispatch_callback id args with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break - | e -> flush Pervasives.stderr + | e -> + try + Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); + flush stderr; + (* raise x *) + with + Out_of_memory -> raise Out_of_memory + | Sys.Break -> raise Sys.Break let _ = Callback.register "camlcb" protected_dispatch @@ -178,12 +188,76 @@ let _ = Callback.register "camlcb" protected_dispatch let _ = callback_init () (* Different version of initialisation functions *) -(* Native opentk is [opentk display class] *) -let openTk ?(display = "") ?(clas = "LablTk") () = - opentk ~display ~clas; +let default_display_name = ref "" +let default_display () = !default_display_name + +let camltk_argv = ref [] + +(* options for Arg.parse *) +let keywords = [ + "-display", Arg.String (fun s -> + camltk_argv := "-display" :: s :: !camltk_argv), + "<disp> : X server to contact (CamlTk)"; + "-colormap", Arg.String (fun s -> + camltk_argv := "-colormap" :: s :: !camltk_argv), + "<colormap> : colormap to use (CamlTk)"; + "-geometry", Arg.String (fun s -> + camltk_argv := "-geometry" :: s :: !camltk_argv), + "<geom> : size and position (CamlTk)"; + "-name", Arg.String (fun s -> + camltk_argv := "-name" :: s :: !camltk_argv), + "<name> : application class (CamlTk)"; + "-sync", Arg.Unit (fun () -> + camltk_argv := "-sync" :: !camltk_argv), + ": sync mode (CamlTk)"; + "-use", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + "<id> : parent window id (CamlTk)"; + "-window", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + "<id> : parent window id (CamlTk)"; + "-visual", Arg.String (fun s -> + camltk_argv := "-visual" :: s :: !camltk_argv), + "<visual> : visual to use (CamlTk)" ] + +let opentk_with_args argv (* = [argv1;..;argvn] *) = + (* argv must be command line for wish *) + let argv0 = Sys.argv.(0) in + let rec find_display = function + | "-display" :: s :: xs -> s + | "-colormap" :: s :: xs -> find_display xs + | "-geometry" :: s :: xs -> find_display xs + | "-name" :: s :: xs -> find_display xs + | "-sync" :: xs -> find_display xs + | "-use" :: s :: xs -> find_display xs + | "-window" :: s :: xs -> find_display xs + | "-visual" :: s :: xs -> find_display xs + | "--" :: _ -> "" + | _ :: xs -> find_display xs + | [] -> "" + in + default_display_name := find_display argv; + opentk_low (argv0 :: argv); install_cleanup(); Widget.default_toplevel +let opentk () = + let argv0 = Sys.argv.(0) in + Arg.parse keywords (fun _ -> ()) argv0; + opentk_with_args !camltk_argv + +let openTkClass s = opentk_with_args ["-name"; s] +let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] + +(*JPF CAMLTK/LABLTK? *) +let openTk ?(display = "") ?(clas = "LablTk") () = + let dispopt = + match display with + | "" -> [] + | _ -> ["-display"; display] + in + opentk_with_args (dispopt @ ["-name"; clas]) + (* Destroy all widgets, thus cleaning up table and exiting the loop *) let closeTk () = tcl_command "destroy ." |