ocaml/ocamltest/ocamltest_stdlib.ml

198 lines
6.1 KiB
OCaml

(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
(* *)
(* Copyright 2016 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* A few extensions to OCaml's standard library *)
module Unix = Ocamltest_unix
let input_line_opt ic =
try Some (input_line ic) with End_of_file -> None
module Char = struct
include Char
let is_blank c =
c = ' ' || c = '\012' || c = '\n' || c = '\r' || c = '\t'
end
module Filename = struct
include Filename
let path_sep = if Sys.win32 then ";" else ":"
(* This function comes from otherlibs/win32unix/unix.ml *)
let maybe_quote f =
if String.contains f ' ' ||
String.contains f '\"' ||
String.contains f '\t' ||
f = ""
then Filename.quote f
else f
let make_filename name ext = String.concat "." [name; ext]
let make_path components = List.fold_left Filename.concat "" components
let mkexe filename = filename ^ Ocamltest_config.exe
end
module List = struct
include List
let rec concatmap f = function
| [] -> []
| x::xs -> (f x) @ (concatmap f xs)
end
module String = struct
include Misc.Stdlib.String
let string_of_char = String.make 1
let words s =
let l = String.length s in
let rec f quote w ws i =
if i>=l then begin
if w<>"" then List.rev (w::ws)
else List.rev ws
end else begin
let j = i+1 in
match s.[i] with
| '\'' -> f (not quote) w ws j
| ' ' ->
begin
if quote
then f true (w ^ (string_of_char ' ')) ws j
else begin
if w=""
then f false w ws j
else f false "" (w::ws) j
end
end
| _ as c -> f quote (w ^ (string_of_char c)) ws j
end in
if l=0 then [] else f false "" [] 0
end
module Sys = struct
include Sys
let erase_file path =
try Sys.remove path
with Sys_error _ when Sys.win32 && Ocamltest_config.libunix <> None ->
(* Deal with read-only attribute on Windows. Ignore any error from chmod
so that the message always come from Sys.remove *)
let () = try Unix.chmod path 0o666 with Sys_error _ -> () in
Sys.remove path
let rm_rf path =
let rec erase path =
if Sys.is_directory path then begin
Array.iter (fun entry -> erase (Filename.concat path entry))
(Sys.readdir path);
Sys.rmdir path
end else erase_file path
in
try if Sys.file_exists path then erase path
with Sys_error err ->
raise (Sys_error (Printf.sprintf "Failed to remove %S (%s)" path err))
let rec make_directory dir =
if Sys.file_exists dir then ()
else let () = make_directory (Filename.dirname dir) in
if not (Sys.file_exists dir) then
Sys.mkdir dir 0o777
else ()
let make_directory dir =
try make_directory dir
with Sys_error err ->
raise (Sys_error (Printf.sprintf "Failed to create %S (%s)" dir err))
let with_input_file ?(bin=false) x f =
let ic = (if bin then open_in_bin else open_in) x in
Fun.protect ~finally:(fun () -> close_in_noerr ic)
(fun () -> f ic)
let file_is_empty filename =
not (Sys.file_exists filename) ||
with_input_file filename in_channel_length = 0
let string_of_file filename =
with_input_file ~bin:true filename @@ fun chan ->
let filesize = in_channel_length chan in
if filesize > Sys.max_string_length then
failwith
("The file " ^ filename ^ " is too large to be loaded into a string")
else begin
try really_input_string chan filesize
with End_of_file ->
failwith ("Got unexpected end of file while reading " ^ filename)
end
let iter_lines_of_file f filename =
let rec go ic =
match input_line ic with
| exception End_of_file -> ()
| l -> f l; go ic
in
with_input_file filename go
let dump_file oc ?(prefix = "") filename =
let f s =
output_string oc prefix; output_string oc s; output_char oc '\n' in
iter_lines_of_file f filename
let with_output_file ?(bin=false) x f =
let oc = (if bin then open_out_bin else open_out) x in
Fun.protect ~finally:(fun () -> close_out_noerr oc)
(fun () -> f oc)
let copy_chan ic oc =
let m = in_channel_length ic in
let m = (m lsr 12) lsl 12 in
let m = max 16384 (min Sys.max_string_length m) in
let buf = Bytes.create m in
let rec loop () =
let len = input ic buf 0 m in
if len > 0 then begin
output oc buf 0 len;
loop ()
end
in loop ()
let copy_file src dest =
with_input_file ~bin:true src @@ fun ic ->
with_output_file ~bin:true dest @@ fun oc ->
copy_chan ic oc
let force_remove file =
if file_exists file then remove file
let with_chdir path f =
let oldcwd = Sys.getcwd () in
Sys.chdir path;
Fun.protect ~finally:(fun () -> Sys.chdir oldcwd) f
let getenv_with_default_value variable default_value =
try Sys.getenv variable with Not_found -> default_value
let safe_getenv variable = getenv_with_default_value variable ""
end
module Seq = struct
include Seq
let rec equal s1 s2 =
match s1 (), s2 () with
| Nil, Nil -> true
| Cons(e1, s1), Cons(e2, s2) -> e1 = e2 && equal s1 s2
| _, _ -> false
end