1 (***********************************************************************)
3 (* MLTk, Tcl/Tk interface of Objective Caml *)
5 (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
6 (* projet Cristal, INRIA Rocquencourt *)
7 (* Jacques Garrigue, Kyoto University RIMS *)
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. *)
15 (***********************************************************************)
17 (* $Id: fileevent.ml 4745 2002-04-26 12:16:26Z furuse $ *)
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"
32 (* File input handlers *)
34 let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
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"
45 let remove_fileinput ~fd =
47 let id = Hashtbl.find fd_table (fd, 'r') in
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"
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"
68 let remove_fileoutput ~fd =
70 let id = Hashtbl.find fd_table (fd, 'w') in
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"