l4/pkg/ocaml/contrib/otherlibs/labltk/support/fileevent.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
  17 (* $Id: fileevent.ml 4745 2002-04-26 12:16:26Z furuse $ *)
  18
  19 open Unix
  20 open Support
  21 open Protocol
  22
  23 external add_file_input : file_descr -> cbid -> unit
  24         =  "camltk_add_file_input"
  25 external rem_file_input : file_descr -> cbid -> unit
  26         =  "camltk_rem_file_input"
  27 external add_file_output : file_descr -> cbid -> unit
  28         =  "camltk_add_file_output"
  29 external rem_file_output : file_descr -> cbid -> unit
  30         =  "camltk_rem_file_output"
  31
  32 (* File input handlers *)
  33
  34 let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
  35
  36 let add_fileinput ~fd ~callback:f =
  37   let id = new_function_id () in
  38   Hashtbl.add callback_naming_table id (fun _ -> f());
  39   Hashtbl.add fd_table (fd, 'r') id;
  40   if !Protocol.debug then begin
  41     Protocol.prerr_cbid id; prerr_endline " for fileinput"
  42   end;
  43   add_file_input fd id
  44
  45 let remove_fileinput ~fd =
  46   try
  47     let id = Hashtbl.find fd_table (fd, 'r') in
  48     clear_callback id;
  49     Hashtbl.remove fd_table (fd, 'r');
  50     if !Protocol.debug then begin
  51       prerr_string "clear ";
  52       Protocol.prerr_cbid id;
  53       prerr_endline " for fileinput"
  54     end;
  55     rem_file_input fd id
  56   with
  57     Not_found -> ()
  58
  59 let add_fileoutput ~fd ~callback:f =
  60   let id = new_function_id () in
  61   Hashtbl.add callback_naming_table id (fun _ -> f());
  62   Hashtbl.add fd_table (fd, 'w') id;
  63   if !Protocol.debug then begin
  64     Protocol.prerr_cbid id; prerr_endline " for fileoutput"
  65   end;
  66   add_file_output fd id
  67
  68 let remove_fileoutput ~fd =
  69   try
  70     let id = Hashtbl.find fd_table (fd, 'w') in
  71     clear_callback id;
  72     Hashtbl.remove fd_table (fd, 'w');
  73     if !Protocol.debug then begin
  74       prerr_string "clear ";
  75       Protocol.prerr_cbid id;
  76       prerr_endline " for fileoutput"
  77     end;
  78     rem_file_output fd id
  79   with
  80     Not_found -> ()
  81