summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/support/protocol.ml
diff options
context:
space:
mode:
authorJun FURUSE / 古瀬 淳 <jun.furuse@gmail.com>2002-02-26 12:12:07 +0000
committerJun FURUSE / 古瀬 淳 <jun.furuse@gmail.com>2002-02-26 12:12:07 +0000
commit66a5137082351df02cc58b7afed0dd73fa5d1bad (patch)
tree4354ddf4ba638b4b72ccbe6936f45711f3992b17 /otherlibs/labltk/support/protocol.ml
parentf3a1293b03bea85d83213abb8a8824d32f93d02f (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.ml144
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 ."
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-18 17:35:31 +0000