Blame support/protocol.ml

Packit bd2e5d
(***********************************************************************)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
Packit bd2e5d
(*               projet Cristal, INRIA Rocquencourt                    *)
Packit bd2e5d
(*            Jacques Garrigue, Kyoto University RIMS                  *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
Packit bd2e5d
(*  en Automatique and Kyoto University.  All rights reserved.         *)
Packit bd2e5d
(*  This file is distributed under the terms of the GNU Library        *)
Packit bd2e5d
(*  General Public License, with the special exception on linking      *)
Packit bd2e5d
(*  described in file LICENSE found in the OCaml source tree.          *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(***********************************************************************)
Packit bd2e5d
Packit bd2e5d
(* $Id$ *)
Packit bd2e5d
Packit bd2e5d
open Widget
Packit bd2e5d
Packit bd2e5d
type callback_buffer = string list
Packit bd2e5d
      (* Buffer for reading callback arguments *)
Packit bd2e5d
Packit bd2e5d
type tkArgs =
Packit bd2e5d
    TkToken of string
Packit bd2e5d
  | TkTokenList of tkArgs list          (* to be expanded *)
Packit bd2e5d
  | TkQuote of tkArgs                   (* mapped to Tcl list *)
Packit bd2e5d
Packit bd2e5d
type cbid = int
Packit bd2e5d
Packit bd2e5d
external opentk_low : string list -> unit
Packit bd2e5d
        =  "camltk_opentk"
Packit bd2e5d
external tcl_eval : string -> string
Packit bd2e5d
        =  "camltk_tcl_eval"
Packit bd2e5d
external tk_mainloop : unit -> unit
Packit bd2e5d
        =  "camltk_tk_mainloop"
Packit bd2e5d
external tcl_direct_eval : tkArgs array -> string
Packit bd2e5d
        =  "camltk_tcl_direct_eval"
Packit bd2e5d
external splitlist : string -> string list
Packit bd2e5d
        = "camltk_splitlist"
Packit bd2e5d
external tkreturn : string -> unit
Packit bd2e5d
        = "camltk_return"
Packit bd2e5d
external callback_init : unit -> unit
Packit bd2e5d
        = "camltk_init"
Packit bd2e5d
external finalizeTk : unit -> unit
Packit bd2e5d
        = "camltk_finalize"
Packit bd2e5d
    (* Finalize tcl/tk before exiting. This function will be automatically
Packit bd2e5d
       called when you call [Pervasives.exit ()] (This is installed at
Packit bd2e5d
       [install_cleanup ()] *)
Packit bd2e5d
Packit bd2e5d
let tcl_command s = ignore (tcl_eval s);;
Packit bd2e5d
Packit bd2e5d
type event_flag =
Packit bd2e5d
  DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS
Packit bd2e5d
external do_one_event : event_flag list -> bool = "camltk_dooneevent"
Packit bd2e5d
Packit bd2e5d
let do_pending () = while do_one_event [DONT_WAIT] do () done
Packit bd2e5d
Packit bd2e5d
exception TkError of string
Packit bd2e5d
      (* Raised by the communication functions *)
Packit bd2e5d
let () = Callback.register_exception "tkerror" (TkError "")
Packit bd2e5d
Packit bd2e5d
let cltclinterp = ref Nativeint.zero
Packit bd2e5d
      (* For use in other extensions *)
Packit bd2e5d
let () = Callback.register "cltclinterp" cltclinterp
Packit bd2e5d
Packit bd2e5d
(* Debugging support *)
Packit bd2e5d
let debug =
Packit bd2e5d
 ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true
Packit bd2e5d
      with Not_found -> false)
Packit bd2e5d
Packit bd2e5d
(* This is approximative, since we don't quote what needs to be quoted *)
Packit bd2e5d
let dump_args args =
Packit bd2e5d
  let rec print_arg = function
Packit bd2e5d
    TkToken s -> prerr_string s; prerr_string " "
Packit bd2e5d
  | TkTokenList l -> List.iter print_arg l
Packit bd2e5d
  | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
Packit bd2e5d
 in
Packit bd2e5d
  Array.iter print_arg args;
Packit bd2e5d
  prerr_newline()
Packit bd2e5d
Packit bd2e5d
(*
Packit bd2e5d
 * Evaluating Tcl code
Packit bd2e5d
 *   debugging support should not affect performances...
Packit bd2e5d
 *)
Packit bd2e5d
Packit bd2e5d
let tkEval args =
Packit bd2e5d
  if !debug then dump_args args;
Packit bd2e5d
  let res = tcl_direct_eval args in
Packit bd2e5d
  if !debug then begin
Packit bd2e5d
    prerr_string "->>";
Packit bd2e5d
    prerr_endline res
Packit bd2e5d
    end;
Packit bd2e5d
  res
Packit bd2e5d
Packit bd2e5d
let tkCommand args = ignore (tkEval args)
Packit bd2e5d
Packit bd2e5d
(*
Packit bd2e5d
 * Callbacks
Packit bd2e5d
 *)
Packit bd2e5d
Packit bd2e5d
(* LablTk only *)
Packit bd2e5d
let cCAMLtoTKwidget w =
Packit bd2e5d
  (* Widget.check_class w table; (* with subtyping, it is redundant *) *)
Packit bd2e5d
  TkToken (Widget.name w)
Packit bd2e5d
Packit bd2e5d
let cTKtoCAMLwidget = function
Packit bd2e5d
   "" -> raise (Invalid_argument "cTKtoCAMLwidget")
Packit bd2e5d
 | s -> Widget.get_atom s
Packit bd2e5d
Packit bd2e5d
let callback_naming_table =
Packit bd2e5d
   (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
Packit bd2e5d
Packit bd2e5d
let callback_memo_table =
Packit bd2e5d
   (Hashtbl.create 401 : (any widget, int) Hashtbl.t)
Packit bd2e5d
Packit bd2e5d
let new_function_id =
Packit bd2e5d
  let counter = ref 0 in
Packit bd2e5d
  function () -> incr counter;  !counter
Packit bd2e5d
Packit bd2e5d
let string_of_cbid = string_of_int
Packit bd2e5d
Packit bd2e5d
(* Add a new callback, associated to widget w *)
Packit bd2e5d
(* The callback should be cleared when w is destroyed *)
Packit bd2e5d
let register_callback w ~callback:f =
Packit bd2e5d
  let id = new_function_id () in
Packit bd2e5d
    Hashtbl.add callback_naming_table id f;
Packit bd2e5d
    if (forget_type w) <> (forget_type Widget.dummy) then
Packit bd2e5d
      Hashtbl.add callback_memo_table (forget_type w) id;
Packit bd2e5d
    (string_of_cbid id)
Packit bd2e5d
Packit bd2e5d
let clear_callback id =
Packit bd2e5d
  Hashtbl.remove callback_naming_table id
Packit bd2e5d
Packit bd2e5d
(* Clear callbacks associated to a given widget *)
Packit bd2e5d
let remove_callbacks w =
Packit bd2e5d
  let w = forget_type w in
Packit bd2e5d
  let cb_ids = Hashtbl.find_all callback_memo_table w in
Packit bd2e5d
    List.iter clear_callback cb_ids;
Packit bd2e5d
    for i = 1 to List.length cb_ids do
Packit bd2e5d
      Hashtbl.remove callback_memo_table w
Packit bd2e5d
    done
Packit bd2e5d
Packit bd2e5d
(* Hand-coded callback for destroyed widgets
Packit bd2e5d
 * This may be extended by the application, or by other layers of Camltk.
Packit bd2e5d
 * Could use bind + of Tk, but I'd rather give an alternate mechanism so
Packit bd2e5d
 * that hooks can be set up at load time (i.e. before openTk)
Packit bd2e5d
 *)
Packit bd2e5d
let destroy_hooks = ref []
Packit bd2e5d
let add_destroy_hook f =
Packit bd2e5d
  destroy_hooks := f :: !destroy_hooks
Packit bd2e5d
Packit bd2e5d
let _ =
Packit bd2e5d
  add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w)
Packit bd2e5d
Packit bd2e5d
let install_cleanup () =
Packit bd2e5d
  let call_destroy_hooks = function
Packit bd2e5d
      [wname] ->
Packit bd2e5d
        let w = cTKtoCAMLwidget wname in
Packit bd2e5d
         List.iter (fun f -> f w) !destroy_hooks
Packit bd2e5d
    | _ -> raise (TkError "bad cleanup callback") in
Packit bd2e5d
  let fid = new_function_id () in
Packit bd2e5d
  Hashtbl.add callback_naming_table fid call_destroy_hooks;
Packit bd2e5d
  (* setup general destroy callback *)
Packit bd2e5d
  tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}");
Packit bd2e5d
  at_exit finalizeTk
Packit bd2e5d
Packit bd2e5d
let prerr_cbid id =
Packit bd2e5d
  prerr_string "camlcb "; prerr_int id
Packit bd2e5d
Packit bd2e5d
(* The callback dispatch function *)
Packit bd2e5d
let dispatch_callback id args =
Packit bd2e5d
  if !debug then begin
Packit bd2e5d
    prerr_cbid id;
Packit bd2e5d
    List.iter (fun x -> prerr_string " "; prerr_string x) args;
Packit bd2e5d
    prerr_newline()
Packit bd2e5d
    end;
Packit bd2e5d
  (Hashtbl.find callback_naming_table id) args;
Packit bd2e5d
  if !debug then prerr_endline "<<-"
Packit bd2e5d
Packit bd2e5d
let protected_dispatch id args =
Packit bd2e5d
  try
Packit bd2e5d
    dispatch_callback id args
Packit bd2e5d
  with e ->
Packit bd2e5d
    Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e);
Packit bd2e5d
    flush stderr
Packit bd2e5d
Packit bd2e5d
let _ = Callback.register "camlcb" protected_dispatch
Packit bd2e5d
Packit bd2e5d
(* Make sure the C variables are initialised *)
Packit bd2e5d
let _ = callback_init ()
Packit bd2e5d
Packit bd2e5d
(* Different version of initialisation functions *)
Packit bd2e5d
let default_display_name = ref ""
Packit bd2e5d
let default_display () = !default_display_name
Packit bd2e5d
Packit bd2e5d
let camltk_argv = ref []
Packit bd2e5d
Packit bd2e5d
(* options for Arg.parse *)
Packit bd2e5d
let keywords = [
Packit bd2e5d
  "-display", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-display" :: s :: !camltk_argv),
Packit bd2e5d
    "<disp> : X server to contact (CamlTk)";
Packit bd2e5d
  "-colormap", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-colormap" :: s :: !camltk_argv),
Packit bd2e5d
    "<colormap> : colormap to use (CamlTk)";
Packit bd2e5d
  "-geometry", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-geometry" :: s :: !camltk_argv),
Packit bd2e5d
    "<geom> : size and position (CamlTk)";
Packit bd2e5d
  "-name", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-name" :: s :: !camltk_argv),
Packit bd2e5d
    "<name> : application class (CamlTk)";
Packit bd2e5d
  "-sync", Arg.Unit (fun () ->
Packit bd2e5d
    camltk_argv := "-sync" :: !camltk_argv),
Packit bd2e5d
    ": sync mode (CamlTk)";
Packit bd2e5d
  "-use", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-use" :: s :: !camltk_argv),
Packit bd2e5d
    "<id> : parent window id (CamlTk)";
Packit bd2e5d
  "-window", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-use" :: s :: !camltk_argv),
Packit bd2e5d
    "<id> : parent window id (CamlTk)";
Packit bd2e5d
  "-visual", Arg.String (fun s ->
Packit bd2e5d
    camltk_argv := "-visual" :: s :: !camltk_argv),
Packit bd2e5d
    "<visual> : visual to use (CamlTk)" ]
Packit bd2e5d
Packit bd2e5d
let opentk_with_args argv (* = [argv1;..;argvn] *) =
Packit bd2e5d
  (* argv must be command line for wish *)
Packit bd2e5d
  let argv0 = Sys.argv.(0) in
Packit bd2e5d
  let rec find_display = function
Packit bd2e5d
    | "-display" :: s :: xs -> s
Packit bd2e5d
    | "-colormap" :: s :: xs -> find_display xs
Packit bd2e5d
    | "-geometry" :: s :: xs -> find_display xs
Packit bd2e5d
    | "-name" :: s :: xs -> find_display xs
Packit bd2e5d
    | "-sync" :: xs -> find_display xs
Packit bd2e5d
    | "-use" :: s :: xs -> find_display xs
Packit bd2e5d
    | "-window" :: s :: xs -> find_display xs
Packit bd2e5d
    | "-visual" :: s :: xs -> find_display xs
Packit bd2e5d
    | "--" :: _ -> ""
Packit bd2e5d
    | _ :: xs -> find_display xs
Packit bd2e5d
    | [] -> ""
Packit bd2e5d
  in
Packit bd2e5d
  default_display_name := find_display argv;
Packit bd2e5d
  opentk_low (argv0 :: argv);
Packit bd2e5d
  install_cleanup();
Packit bd2e5d
  Widget.default_toplevel
Packit bd2e5d
Packit bd2e5d
let opentk () = opentk_with_args !camltk_argv;;
Packit bd2e5d
Packit bd2e5d
let openTkClass s = opentk_with_args ["-name"; s]
Packit bd2e5d
let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl]
Packit bd2e5d
Packit bd2e5d
(*JPF CAMLTK/LABLTK? *)
Packit bd2e5d
let openTk ?(display = "") ?(clas = "LablTk") () =
Packit bd2e5d
  let dispopt =
Packit bd2e5d
    match display with
Packit bd2e5d
    | "" -> []
Packit bd2e5d
    | _ -> ["-display"; display]
Packit bd2e5d
  in
Packit bd2e5d
  opentk_with_args (dispopt @ ["-name"; clas])
Packit bd2e5d
Packit bd2e5d
(* Destroy all widgets, thus cleaning up table and exiting the loop *)
Packit bd2e5d
let closeTk () =
Packit bd2e5d
  tcl_command "destroy ."
Packit bd2e5d
Packit bd2e5d
let mainLoop =
Packit bd2e5d
  tk_mainloop
Packit bd2e5d
Packit bd2e5d
Packit bd2e5d
(* [register tclname f] makes [f] available from Tcl with
Packit bd2e5d
   name [tclname] *)
Packit bd2e5d
let register tclname ~callback =
Packit bd2e5d
  let s = register_callback Widget.default_toplevel ~callback in
Packit bd2e5d
    tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
Packit bd2e5d
                             tclname s)