Change out implementation of ocs ports

ocs-1.0.3/src/ocs_port.ml

@@ -2,222 +2,124 @@
 
 open Ocs_error
 
-(* Ports can either be file descriptors or string buffers.  File
+type port_impl =
-   descriptors may be valid for both input and output, but when
+  | Input_channel of in_channel
-   switching between the two modes, the file offset may not work
+  | Output_channel of out_channel
-   as expected.
+  | Input_string of string * int ref
-
+  | Output_string of Buffer.t
-   For unbuffered or asynchronous I/O, from Scheme or otherwise,
-   the port can simply be used as a reference to the file
-   descriptor.  *)
 
 type port = {
-  mutable p_buf : string;
+  ungot : char option ref;
-  mutable p_pos : int;
+  impl : port_impl;
-  mutable p_wend : int;
-  mutable p_rend : int;
-  mutable p_ugc : char option;
-  mutable p_fd : Unix.file_descr option;
-  mutable p_input : bool;
-  mutable p_output : bool;
-  p_close : bool
 }
 
-type port_flag =
-    Pf_input
-  | Pf_output
-  | Pf_close
-
-let mkbuf () =
-  String.create 1024
-;;
-
-let mkport buf fd inf outf cl =
-  { p_buf = buf;
-    p_pos = 0;
-    p_wend = 0;
-    p_rend = 0;
-    p_ugc = None;
-    p_fd = fd;
-    p_input = inf;
-    p_output = outf;
-    p_close = cl }
-;;
-
 let is_input p =
-  p.p_input
+  match p.impl with
-;;
+    | Input_string _
+    | Input_channel _ -> true
+    | _ -> false
 
 let is_output p =
-  p.p_output
+  match p.impl with
-;;
+    | Output_string _
-
+    | Output_channel _ -> true
-let wrflush p =
+    | _ -> false
-  if not p.p_output then
-    raise (Error "not a valid output port");
-  match p.p_fd with
-    Some fd ->
-      if p.p_wend > 0 && p.p_pos > 0 then
-	begin
-	  try
-	    let n = Unix.write fd p.p_buf 0 p.p_pos in
-	      if n <> p.p_pos then
-		raise (Error "write error: incomplete write")
-	  with
-	    Unix.Unix_error (e, _, _) ->
-	      raise (Error ("write error: " ^ Unix.error_message e))
-	end;
-      p.p_pos <- 0;
-      p.p_wend <- String.length p.p_buf
-  | None ->
-      if p.p_pos = p.p_wend then
-	let n = String.length p.p_buf in
-	let nbuf = String.create (n * 2) in
-	  String.blit p.p_buf 0 nbuf 0 n;
-	  p.p_buf <- nbuf;
-	  p.p_wend <- String.length p.p_buf
-;;
-
-let rdfill p =
-  if not p.p_input then
-    raise (Error "not a valid input port");
-  if p.p_wend > 0 then
-    wrflush p;
-  p.p_pos <- 0;
-  p.p_rend <- 0;
-  p.p_wend <- 0;
-  match p.p_fd with
-    Some fd ->
-      begin
-	try
-	  p.p_rend <- Unix.read fd p.p_buf 0 (String.length p.p_buf)
-	with
-	  Unix.Unix_error (e, _, _) ->
-	    raise (Error ("read error: " ^ Unix.error_message e))
-      end
-  | None -> ()
-;;
 
 let getc p =
-  match p.p_ugc with
+  match (!(p.ungot), p.impl) with
-    Some _ as c -> p.p_ugc <- None; c
+    | (Some c, _) ->
-  | None ->
+        p.ungot := None;
-      if p.p_rend = 0 || p.p_pos >= p.p_rend then rdfill p;
-      if p.p_rend = 0 then None
-      else
-	begin
-	  assert (p.p_pos < p.p_rend);
-	  let c = p.p_buf.[p.p_pos] in
-	    p.p_pos <- p.p_pos + 1;
         Some c
+    | (None, Input_string (str, pos)) ->
+        if !pos >= (String.length str) then
+          None
+        else
+          let c = str.[!pos] in
+            pos := !pos + 1;
+            Some c
+    | (None, Input_channel chan) ->
+        begin
+          try
+            Some (input_char chan)
+          with End_of_file ->
+            None
         end
-;;
+    | _ ->
-
+        None
-let get_fd p =
-  p.p_fd
-;;
 
 let flush p =
-  if p.p_wend > 0 then
+  match p.impl with
-    wrflush p
+    | Output_channel chan ->
-;;
+        Pervasives.flush chan
+    | _ ->
+        ()
 
 let close p =
-  if p.p_input || p.p_output then
+  p.ungot := None;
-    begin
+  match p.impl with
-      flush p;
+    | Input_channel chan ->
-      p.p_input <- false;
+        close_in chan
-      p.p_output <- false;
+    | Output_channel chan ->
-      match p.p_fd with
+        close_out chan
-	Some fd ->
+    | _ ->
-	  if p.p_close then Unix.close fd;
+        ()
-	  p.p_fd <- None
-      | None -> ()
-    end
-;;
 
 let ungetc p c =
-  p.p_ugc <- Some c
+  p.ungot := Some c
-;;
 
 let char_ready p =
-  if p.p_ugc <> None || p.p_pos < p.p_rend then true
+  match (!(p.ungot), p.impl) with
-  else if not p.p_input then false
+    | (Some _, Input_string _)
-  else
+    | (Some _, Input_channel _) ->
-    match p.p_fd with
+        true
-      Some fd ->
+    | (None, Input_string (str, pos)) ->
+        !pos < (String.length str)
+    | (None, Input_channel chan) ->
+        let fd = Unix.descr_of_in_channel chan in
         let (r, _, _) = Unix.select [fd] [] [] 0.0 in
           List.length r > 0
-    | None -> false
+    | _ ->
-;;
+        false
 
 let putc p c =
-  if p.p_wend = 0 || p.p_pos >= p.p_wend then
+  match p.impl with
-    wrflush p;
+    | Output_string buf ->
-  assert (p.p_pos < p.p_wend);
+        Buffer.add_char buf c
-  p.p_buf.[p.p_pos] <- c;
+    | Output_channel chan ->
-  p.p_pos <- p.p_pos + 1
+        output_char chan c
-;;
+    | _ ->
+        ()
 
 let puts p s =
-  let n = String.length s in
+  match p.impl with
-    if n > 0 && p.p_rend - p.p_pos >= n then
+    | Output_string buf ->
-      begin
+        Buffer.add_string buf s
-	String.blit s 0 p.p_buf p.p_pos n;
+    | Output_channel chan ->
-	p.p_pos <- p.p_pos + n
+        output_string chan s
-      end
+    | _ ->
-    else
+        ()
-      String.iter (fun c -> putc p c) s
-;;
-
-let fd_port fd flags =
-  let inf = ref false
-  and outf = ref false
-  and clf = ref false in
-    List.iter (function
-		Pf_input -> inf := true
-	      | Pf_output -> outf := true
-	      | Pf_close -> clf := true) flags;
-    let p = mkport (mkbuf ()) (Some fd) !inf !outf !clf in
-      if !clf then Gc.finalise close p;
-      p
-;;
 
 let input_port ch =
-  fd_port (Unix.descr_of_in_channel ch) [ Pf_input ]
+  { ungot = ref None; impl = Input_channel ch }
-;;
 
 let output_port ch =
-  fd_port (Unix.descr_of_out_channel ch) [ Pf_output ]
+  { ungot = ref None; impl = Output_channel ch }
-;;
 
 let open_input_port name =
   try
-    let fd = Unix.openfile name [ Unix.O_RDONLY ] 0 in
+    input_port (open_in_bin name)
-      fd_port fd [ Pf_input; Pf_close ]
+  with Sys_error err ->
-  with
-    Unix.Unix_error (e, _, _) ->
-      let err = Unix.error_message e in
     raise (Error ("unable to open '" ^ name ^ "' for input: " ^ err))
-;;
 
 let open_output_port name =
   try
-    let fd = Unix.openfile name [ Unix.O_WRONLY; Unix.O_APPEND;
+    output_port (open_out_bin name)
-				  Unix.O_CREAT; Unix.O_TRUNC ] 0o666 in
+  with Sys_error err ->
-      fd_port fd [ Pf_output; Pf_close ]
-  with
-    Unix.Unix_error (e, _, _) ->
-      let err = Unix.error_message e in
     raise (Error ("unable to open '" ^ name ^ "' for output: " ^ err))
-;;
 
 let string_input_port s =
-  let p = mkport s None true false false in
+  { ungot = ref None; impl = Input_string (s, ref 0) }
-    p.p_rend <- String.length s;
-    p
-;;
 
 let string_output_port () =
-  mkport (mkbuf ()) None false true false
+  { ungot = ref None; impl = Output_string (Buffer.create 256) }
-;;
+

ocs-1.0.3/src/ocs_port.mli

@@ -2,12 +2,6 @@
 
 type port
 
-type port_flag =
-    Pf_input
-  | Pf_output
-  | Pf_close
-
-val fd_port : Unix.file_descr -> port_flag list -> port
 val input_port : in_channel -> port
 val output_port : out_channel -> port
 val open_input_port : string -> port
@@ -25,8 +19,6 @@ val char_ready : port -> bool
 val putc : port -> char -> unit
 val puts : port -> string -> unit
 
-val get_fd : port -> Unix.file_descr option
-
 val flush : port -> unit
 
 val close : port -> unit