add resource-handling IO functions in pervasives

Changes

@@ -662,6 +662,10 @@ OCaml 4.08.0 (13 June 2019)
   shouldn't create randomized hash tables.
   (David Allsopp, review by Alain Frisch)
 
+- GPR#640: Add safe IO functions, prefixed by `with_`, in `Pervasives`,
+  with automatic disposal of resources
+  (Simon Cruanes, review by Daniel Bünzli, Alain Frisch, Nicolás Ojeda Bär)
+
 ### Other libraries:
 
 - #2533, #1839, #1949: added Unix.fsync

stdlib/stdlib.ml

@@ -43,6 +43,31 @@ exception Division_by_zero = Division_by_zero
 exception Sys_blocked_io = Sys_blocked_io
 exception Undefined_recursive_module = Undefined_recursive_module
 
+type raw_backtrace
+external get_raw_backtrace:
+  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+  = "%raise_with_backtrace"
+
+exception Finally_raised of exn
+
+(* cannot depend on Fun *)
+let protect ~(finally : unit -> unit) work =
+  let finally_no_exn () =
+    try finally () with e ->
+      let bt = get_raw_backtrace () in
+      raise_with_backtrace (Finally_raised e) bt
+  in
+  match work () with
+  | result -> finally_no_exn () ; result
+  | exception work_exn ->
+      let work_bt = get_raw_backtrace () in
+      finally_no_exn () ;
+      raise_with_backtrace work_exn work_bt
+
+let protect_apply_ f g x =
+  protect ~finally:(fun () -> g x) (fun () -> f x)
+
 (* Composition operators *)
 
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
@@ -295,6 +320,13 @@ let rec ( @ ) l1 l2 =
     [] -> l2
   | hd :: tl -> hd :: (tl @ l2)
 
+let list_rev l =
+  let rec rev_append l1 l2 = match l1 with
+    | [] -> l2
+    | x :: tail1 -> rev_append tail1 (x :: l2)
+  in
+  rev_append l []
+
 (* I/O operations *)
 
 type in_channel
@@ -389,6 +421,27 @@ let close_out_noerr oc =
 external set_binary_mode_out : out_channel -> bool -> unit
                              = "caml_ml_set_binary_mode"
 
+let wrap_out ~ok ~err f x =
+  try
+    let res = f x in
+    ok x;
+    res
+  with e ->
+    err x;
+    raise e
+
+let with_open_out_gen mode perm name f =
+  let c = open_out_gen mode perm name in
+  wrap_out ~ok:close_out ~err:close_out_noerr f c
+
+let with_open_out name f =
+  let c = open_out name in
+  wrap_out ~ok:close_out ~err:close_out_noerr f c
+
+let with_open_out_bin name f =
+  let c = open_out_bin name in
+  wrap_out ~ok:close_out ~err:close_out_noerr f c
+
 (* General input functions *)
 
 external set_in_channel_name: in_channel -> string -> unit =
@@ -433,6 +486,28 @@ let really_input_string ic len =
   really_input ic s 0 len;
   bytes_unsafe_to_string s
 
+let string_of_in_channel ic =
+  let buf = ref (bytes_create 1024) in
+  let len = ref 0 in
+  try
+    while true do
+      (* resize, by doubling the size of [buf] *)
+      if !len = bytes_length !buf then (
+        let new_buf = bytes_create (2 * !len) in
+        bytes_blit !buf 0 new_buf 0 !len;
+        buf := new_buf;
+      );
+      assert (bytes_length !buf > !len);
+      let n = input ic !buf !len (bytes_length !buf - !len) in
+      len := !len + n;
+      if n = 0 then raise Exit;  (* exhausted *)
+    done;
+    assert false (* never reached*)
+  with Exit ->
+    let res = bytes_create !len in
+    bytes_blit !buf 0 res 0 !len;
+    bytes_unsafe_to_string res
+
 external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
 
 let input_line chan =
@@ -463,6 +538,16 @@ let input_line chan =
     end
   in bytes_unsafe_to_string (scan [] 0)
 
+let input_lines ic =
+  let l = ref [] in
+  try
+    while true do
+      l := input_line ic :: !l
+    done;
+    assert false
+  with End_of_file ->
+    list_rev !l
+
 external input_byte : in_channel -> int = "caml_ml_input_char"
 external input_binary_int : in_channel -> int = "caml_ml_input_int"
 external input_value : in_channel -> 'a = "caml_input_value"
@@ -474,6 +559,18 @@ let close_in_noerr ic = (try close_in ic with _ -> ())
 external set_binary_mode_in : in_channel -> bool -> unit
                             = "caml_ml_set_binary_mode"
 
+let with_open_in_gen mode perm name f =
+  let c = open_in_gen mode perm name in
+  protect_apply_ f close_in_noerr c
+
+let with_open_in name f =
+  let c = open_in name in
+  protect_apply_ f close_in_noerr c
+
+let with_open_in_bin name f =
+  let c = open_in_bin name in
+  protect_apply_ f close_in_noerr c
+
 (* Output functions on standard output *)
 
 let print_char c = output_char stdout c

stdlib/stdlib.mli

@@ -927,6 +927,30 @@ val open_out_gen : open_flag list -> int -> string -> out_channel
    {!Stdlib.open_out} and {!Stdlib.open_out_bin} are special
    cases of this function. *)
 
+val with_open_out : string -> (out_channel -> 'a) -> 'a
+(** [with_open_out file f] open the named file for writing,
+    obtaining a channel [c], then calls [f c]. It then behaves like
+    [f c], returning or raising the same way, except that it will close
+    the file in any case before returning.
+    see {!open_out} for more details
+    @since NEXT_RELEASE *)
+
+val with_open_out_bin : string -> (out_channel -> 'a) -> 'a
+(** Same as {!Pervasives.with_open_out}, but the file is opened in binary mode,
+   so that no translation takes place during writes. On operating
+   systems that do not distinguish between text mode and binary
+    mode, this function behaves like {!Pervasives.with_open_out}.
+    @since NEXT_RELEASE *)
+
+val with_open_out_gen :
+  open_flag list -> int -> string ->
+  (out_channel -> 'a) -> 'a
+(** [with_open_out_gen mode perm filename f] opens the named file for writing,
+    as described above, then gives the channel to [f] and ensures
+    that the channel is closed after [f] raises or returns.
+    see {!open_out_gen} for more details on the other arguments
+    @since NEXT_RELEASE *)
+
 val flush : out_channel -> unit
 (** Flush the buffer associated with the given output channel,
    performing all pending writes on that channel.
@@ -1035,6 +1059,26 @@ val open_in_gen : open_flag list -> int -> string -> in_channel
    {!Stdlib.open_in} and {!Stdlib.open_in_bin} are special
    cases of this function. *)
 
+val with_open_in : string -> (in_channel -> 'a) -> 'a
+(** [with_open_in file f] opens the named file for reading,
+    gives the channel to [f], and takes care of closing the channel
+    once [f] returns or raises.
+    @since NEXT_RELEASE *)
+
+val with_open_in_bin : string -> (in_channel -> 'a) -> 'a
+(** Same as {!Pervasives.with_open_in}, but the file is opened in binary mode.
+    see {!open_in_bin}
+    @since NEXT_RELEASE *)
+
+val with_open_in_gen :
+  open_flag list -> int -> string ->
+  (in_channel -> 'a) -> 'a
+(** [with_open_in_gen mode perm filename f] opens the named file for reading,
+    as described above, and gives the channel to [f]. It closes the channel
+    once [f] is done.
+    see {!open_in_gen} for more details on the other arguments
+    @since NEXT_RELEASE *)
+
 val input_char : in_channel -> char
 (** Read one character from the given input channel.
    Raise [End_of_file] if there are no more characters to read. *)
@@ -1078,6 +1122,16 @@ val really_input_string : in_channel -> int -> string
    characters have been read.
    @since 4.02.0 *)
 
+val string_of_in_channel : in_channel -> string
+(** [string_of_in_channel c] reads the whole content of [c] into a string.
+    If [c] is an infinite stream (e.g. a socket) this will never return.
+    @since NEXT_RELEASE *)
+
+val input_lines : in_channel -> string list
+(** [input_lines c] reads every line in [c] into a list.
+    If [c] is an infinite stream (e.g. a socket) this will never return.
+    @since NEXT_RELEASE *)
+
 val input_byte : in_channel -> int
 (** Same as {!Stdlib.input_char}, but return the 8-bit integer representing
    the character.