Add test from OCaml test suite

Author: vouillon

compiler/tests-ocaml/win-unicode/dune

@@ -0,0 +1,5 @@
+(tests
+ (names
+  mltest)
+ (libraries ocaml_testing unix)
+ (modes js wasm))

compiler/tests-ocaml/win-unicode/mltest.ml

@@ -0,0 +1,291 @@
+(* TEST
+ include unix;
+ hasunix;
+ flags += "-strict-sequence -w +A -warn-error +A";
+ windows-unicode;
+ toplevel;
+*)
+
+let foreign_names =
+  List.sort compare
+    [
+      "simple";
+      "\xE4\xBD\xA0\xE5\xA5\xBD"; (* "你好" *)
+      "\x73\xC5\x93\x75\x72"; (* "sœur" *)
+      "e\204\129te\204\129"; (* "été" *)
+    ]
+;;
+
+let test_files =
+  List.map (fun s -> s ^ ".txt") foreign_names
+;;
+
+let to_create_and_delete_files =
+  [
+    (* "верблюды" *)
+    "\xD0\xB2\xD0\xB5\xD1\x80\xD0\xB1\xD0\xBB\xD1\x8E\xD0\xB4\xD1\x8B";
+    "\xE9\xAA\x86\xE9\xA9\xBC"; (* "骆驼" *)
+    "\215\167\215\162\215\158\215\156"; (* "קעמל" *)
+    "\216\167\217\136\217\134\217\185"; (* "اونٹ" *)
+    "L\225\186\161c \196\145\195\160"; (* "Lạc đà" *)
+    "\224\176\146\224\176\130\224\176\159\224\177\134"; (* "ఒంటె" *)
+    "\224\174\146\224\174\159\224\175\141\224\174\159\224\174\149\224\
+     \174\174\224\175\141"; (* "ஒட்டகம்" *)
+    "\217\136\216\180\216\170\216\177"; (* "وشتر" *)
+    "\224\164\137\224\164\183\224\165\141\224\164\159\224\165\141\224\
+     \164\176\224\164\131"; (* "उष्ट्रः" *)
+    "\216\167\217\186"; (* "اٺ" *)
+  ]
+;;
+
+let foreign_names2 =
+  let rec take n l =
+    if n = 0 then []
+    else List.hd l :: take (n-1) (List.tl l)
+  in
+  take (List.length foreign_names) to_create_and_delete_files
+;;
+
+(* let env0 =
+     List.sort compare
+     (List.mapi (fun i v -> Printf.sprintf "OCAML_UTF8_VAR%d=%s" i v)
+                foreign_names2) *)
+
+(* let read_all ic = *)
+(*   set_binary_mode_in ic false; *)
+(*   let rec loop acc = *)
+(*     match input_line ic with *)
+(*     | exception End_of_file -> *)
+(*         List.rev acc *)
+(*     | s -> *)
+(*         loop (s :: acc) *)
+(*   in *)
+(*   loop [] *)
+
+(** WRAPPERS *)
+
+let getenvironmentenv s =
+  let env = Unix.environment () in
+  let rec loop i =
+    if i >= Array.length env then
+      ""
+    else begin
+      let e = env.(i) in
+      let pos = String.index e '=' in
+      if String.sub e 0 pos = s then
+        String.sub e (pos+1) (String.length e - pos - 1)
+      else
+        loop (i+1)
+    end
+  in
+  loop 0
+;;
+
+let unix_getcwd () =
+  Filename.basename (Unix.getcwd ())
+;;
+
+let sys_getcwd () =
+  Filename.basename (Sys.getcwd ())
+;;
+
+let unix_readdir s =
+  let h = Unix.opendir s in
+  let rec loop acc =
+    match Unix.readdir h with
+    | s ->
+        loop (s :: acc)
+    | exception End_of_file ->
+        Unix.closedir h;
+        acc
+  in
+  List.sort compare (loop [])
+;;
+
+let sys_readdir s =
+  List.sort compare (Array.to_list (Sys.readdir s))
+;;
+
+(* let open_process_in cmdline = *)
+(*   let f cmdline = *)
+(*     let ic as proc = Unix.open_process_in cmdline in *)
+(*     let l = List.tl (read_all ic) in *)
+(*     ignore (Unix.close_process_in proc); *)
+(*     l *)
+(*   in *)
+(*   wrap "Unix.open_process_in" f ell cmdline (list quote) *)
+
+(* let open_process_full filter cmdline env =
+     let f cmdline env =
+       let (ic, _, _) as proc =
+         Unix.open_process_full cmdline (Array.of_list env)
+       in
+       let l = read_all ic in
+       ignore (Unix.close_process_full proc);
+       List.sort compare (List.filter filter l)
+     in
+     wrap2 "Unix.open_process_full" f ell (list quote) cmdline env (list quote)
+*)
+
+let test_readdir readdir =
+  let filter s = List.mem s test_files && Filename.check_suffix s ".txt" in
+  List.filter filter (readdir Filename.current_dir_name)
+;;
+
+let test_open_in () =
+  let check s =
+    let ic = open_in s in
+    let l = input_line ic in
+    close_in ic;
+    l
+  in
+  let filter s = List.mem s test_files in
+  let files = List.filter filter (sys_readdir Filename.current_dir_name) in
+  List.map check files
+;;
+
+(*
+let test_getenv () =
+  let equiv l r =
+    assert (l = r);
+    l, r
+  in
+  let doit key s =
+    Unix.putenv key s;
+    let l = equiv (Sys.getenv key) (getenvironmentenv key) in
+    let r =
+      Unix.putenv key (s ^ s);
+      equiv (Sys.getenv key) (getenvironmentenv key)
+    in
+      l, r
+  in
+  List.map2 doit foreign_names foreign_names2
+;;
+*)
+
+let test_mkdir () =
+  let doit s =
+    Unix.mkdir s 0o755;
+    Sys.file_exists s, Sys.is_directory s
+  in
+  List.map doit foreign_names
+;;
+
+let test_chdir chdir getcwd =
+  let doit s =
+    chdir s;
+    let d = getcwd () in
+    chdir Filename.parent_dir_name;
+    d
+  in
+  List.map doit foreign_names
+;;
+
+let test_rmdir () =
+  let doit s =
+    Unix.rmdir s;
+    Sys.file_exists s
+  in
+  List.map doit foreign_names
+;;
+
+let test_stat () =
+  let doit s =
+    (Unix.stat s).Unix.st_kind,
+    (Unix.lstat s).Unix.st_kind,
+    (Unix.LargeFile.stat s).Unix.LargeFile.st_kind,
+    (Unix.LargeFile.lstat s).Unix.LargeFile.st_kind
+  in
+  List.map doit to_create_and_delete_files
+;;
+
+let test_access () =
+  List.iter (fun s -> Unix.access s [Unix.F_OK]) to_create_and_delete_files
+
+let test_rename rename =
+  let doit s =
+    let s' = s ^ "-1" in
+    rename s s';
+    let x = Sys.file_exists s, Sys.file_exists s' in
+    rename s' s;
+    let y = Sys.file_exists s, Sys.file_exists s' in
+    x, y
+  in
+  List.map doit to_create_and_delete_files
+;;
+
+let test_open_out () =
+  let doit s =
+    let oc = open_out s in
+    Printf.fprintf oc "Hello, %s\n" s;
+    close_out oc;
+    let ic = open_in s in
+    let l = input_line ic in
+    close_in ic;
+    l
+  in
+  List.map doit to_create_and_delete_files
+;;
+
+let test_file_exists () =
+  List.map Sys.file_exists to_create_and_delete_files
+;;
+
+let test_remove () =
+  let doit s =
+    Sys.remove s;
+    Sys.file_exists s
+  in
+  List.map doit to_create_and_delete_files
+;;
+
+let create_file s =
+  let oc = open_out_bin s in
+  output_string oc s;
+  close_out oc
+;;
+
+let test_symlink () =
+  let foodir = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD" (* "UNIQU你好" *) in
+  let foofile = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD/\xE4\xBD\xA0\xE5\xA5\xBD.txt"
+                                                          (* "UNIQU你好/你好.txt" *)
+  in
+  let fileln = "\xE4\xBD\xA0\xE5\xA5\xBD-file-ln-s" (* "你好-file-ln-s" *) in
+  let dirln = "\xE4\xBD\xA0\xE5\xA5\xBD-dir-ln-s" (* "你好-dir-ln-s" *) in
+  Unix.mkdir foodir 0o777;
+  create_file foofile;
+  Unix.symlink ~to_dir:true foodir dirln;
+  Unix.symlink ~to_dir:false foofile fileln;
+  let res =
+    (Unix.stat fileln).Unix.st_kind = Unix.S_REG &&
+    (Unix.stat dirln).Unix.st_kind = Unix.S_DIR &&
+    (Unix.lstat fileln).Unix.st_kind = Unix.S_LNK &&
+    (Unix.lstat dirln).Unix.st_kind = Unix.S_LNK
+  in
+  Sys.remove foofile;
+  Sys.remove fileln;
+  Sys.remove dirln;
+  Unix.rmdir foodir;
+  res
+;;
+
+List.iter create_file test_files;;
+
+let check_length ?(n = 4) v = assert (List.length v = n);;
+
+let t_unix_readdir = check_length @@ test_readdir unix_readdir;;
+let t_sys_readdir = check_length @@ test_readdir sys_readdir;;
+let t_open_in = check_length @@ test_open_in ();;
+let t_open_out = check_length ~n:10 @@ test_open_out ();;
+let t_file_exists = assert (List.for_all Fun.id (test_file_exists ()));;
+let t_stat = assert (List.for_all (fun x -> match x with Unix.S_REG,Unix.S_REG,Unix.S_REG,Unix.S_REG -> true | _ -> false) (test_stat ()));;
+test_access ();;
+let t_unix_rename = test_rename Unix.rename;;
+let t_sys_rename = test_rename Sys.rename;;
+assert (not (List.exists Fun.id (test_remove ())));;
+assert (List.for_all (fun (p, q) -> p && q) (test_mkdir ()));;
+let t_sys_chdir = assert (foreign_names = test_chdir Sys.chdir sys_getcwd);;
+let t_unix_chdir = assert (foreign_names = test_chdir Unix.chdir unix_getcwd);;
+assert (not (List.exists Fun.id (test_rmdir ())));;
+(*let t_getenv = test_getenv ();;*)
+assert (if Unix.has_symlink () then test_symlink () else true);;