276 lines
8.6 KiB
OCaml
276 lines
8.6 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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 Support
|
|
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_low : string list -> 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"
|
|
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);;
|
|
|
|
exception TkError of string
|
|
(* Raised by the communication functions *)
|
|
let _ = Callback.register_exception "tkerror" (TkError "")
|
|
|
|
(* Debugging support *)
|
|
let debug =
|
|
ref (try ignore (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 print_arg l
|
|
| TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
|
|
in
|
|
Array.iter 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
|
|
|
|
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)
|
|
|
|
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 id f;
|
|
if (forget_type w) <> (forget_type Widget.dummy) then
|
|
Hashtbl.add callback_memo_table (forget_type w) id;
|
|
(string_of_cbid id)
|
|
|
|
let clear_callback id =
|
|
Hashtbl.remove callback_naming_table 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 w in
|
|
List.iter clear_callback cb_ids;
|
|
for i = 1 to List.length cb_ids do
|
|
Hashtbl.remove callback_memo_table 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 f -> f w) !destroy_hooks
|
|
| _ -> raise (TkError "bad cleanup callback") in
|
|
let fid = new_function_id () in
|
|
Hashtbl.add callback_naming_table fid call_destroy_hooks;
|
|
(* setup general destroy callback *)
|
|
tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}");
|
|
at_exit finalizeTk
|
|
|
|
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 x -> prerr_string " "; prerr_string x) args;
|
|
prerr_newline()
|
|
end;
|
|
(Hashtbl.find callback_naming_table id) args;
|
|
if !debug then prerr_endline "<<-"
|
|
|
|
let protected_dispatch id args =
|
|
try
|
|
dispatch_callback id args
|
|
with
|
|
| 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
|
|
|
|
(* Make sure the C variables are initialised *)
|
|
let _ = callback_init ()
|
|
|
|
(* Different version of initialisation functions *)
|
|
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 ."
|
|
|
|
let mainLoop =
|
|
tk_mainloop
|
|
|
|
|
|
(* [register tclname f] makes [f] available from Tcl with
|
|
name [tclname] *)
|
|
let register tclname ~callback =
|
|
let s = register_callback Widget.default_toplevel ~callback in
|
|
tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
|
|
tclname s)
|
|
|