(***********************************************************************)

(*                                                                     *)

(*                 MLTk, Tcl/Tk interface of OCaml                     *)

(*                                                                     *)

(*    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 OCaml source tree.          *)

(*                                                                     *)

(***********************************************************************)

(* $Id$ *)

open Unix

open Protocol

external add_file_input : file_descr -> cbid -> unit

        =  "camltk_add_file_input"

external rem_file_input : file_descr -> cbid -> unit

        =  "camltk_rem_file_input"

external add_file_output : file_descr -> cbid -> unit

        =  "camltk_add_file_output"

external rem_file_output : file_descr -> cbid -> unit

        =  "camltk_rem_file_output"

(* File input handlers *)

let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)

let add_fileinput ~fd ~callback:f =

  let id = new_function_id () in

  Hashtbl.add callback_naming_table id (fun _ -> f());

  Hashtbl.add fd_table (fd, 'r') id;

  if !Protocol.debug then begin

    Protocol.prerr_cbid id; prerr_endline " for fileinput"

  end;

  add_file_input fd id

let remove_fileinput ~fd =

  try

    let id = Hashtbl.find fd_table (fd, 'r') in

    clear_callback id;

    Hashtbl.remove fd_table (fd, 'r');

    if !Protocol.debug then begin

      prerr_string "clear ";

      Protocol.prerr_cbid id;

      prerr_endline " for fileinput"

    end;

    rem_file_input fd id

  with

    Not_found -> ()

let add_fileoutput ~fd ~callback:f =

  let id = new_function_id () in

  Hashtbl.add callback_naming_table id (fun _ -> f());

  Hashtbl.add fd_table (fd, 'w') id;

  if !Protocol.debug then begin

    Protocol.prerr_cbid id; prerr_endline " for fileoutput"

  end;

  add_file_output fd id

let remove_fileoutput ~fd =

  try

    let id = Hashtbl.find fd_table (fd, 'w') in

    clear_callback id;

    Hashtbl.remove fd_table (fd, 'w');

    if !Protocol.debug then begin

      prerr_string "clear ";

      Protocol.prerr_cbid id;

      prerr_endline " for fileoutput"

    end;

    rem_file_output fd id

  with

    Not_found -> ()