l4/pkg/ocaml/contrib/otherlibs/labltk/frx/frx_rpc.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 (* Some notion of RPC *)
  17 open Camltk
  18 open Protocol
  19
  20 (* A RPC is just a callback with a particular name, plus a Tcl procedure *)
  21 let register name f =
  22   let id = new_function_id() in
  23   Hashtbl.add callback_naming_table id f;
  24   (* For rpc_info *)
  25   Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")"))
  26                    (string_of_cbid id);
  27   tkCommand [| TkToken "proc"; TkToken name; TkToken "args";
  28             TkToken ("camlcb "^(string_of_cbid id)^" $args") |]
  29
  30 (* RPC *)
  31 let invoke interp f args =
  32   tkEval [|
  33     TkToken "send";
  34     TkToken interp;
  35     TkToken f;
  36     TkTokenList (List.map (fun s -> TkToken s) args)
  37     |]
  38
  39 let async_invoke interp f args =
  40   tkCommand [|
  41     TkToken "send";
  42     TkToken "-async";
  43     TkToken interp;
  44     TkToken f;
  45     TkTokenList (List.map (fun s -> TkToken s) args)
  46     |]
  47
  48 let rpc_info interp =
  49   tkEval [|
  50     TkToken "send";
  51     TkToken interp;
  52     TkToken "array";
  53     TkToken "names";
  54     TkToken "camltkrpc"
  55     |]