Unix.symlink: support forward slashes in symlink targets under Windows (#1211)

* Normalize target before calling CreateSymbolicLink

* Add Changes entry

* Run test only on Windows with symlink permissions

6 files changed, 58 insertions, 4 deletions

diff --git a/Changes b/Changes
index c43549d6da..1429507ce0 100644
--- a/Changes
+++ b/Changes
@@ -275,10 +275,13 @@ Working version
   (Ethan Aubin, suggestion by Gabriel Scherer, review by David Allsopp,
   Florian Angeletti, and Gabriel Scherer)
 
+- MPR#7564, GPR#1211: Allow forward slashes in the target of symbolic links
+  created by Unix.symlink under Windows.
+  (Nicolas Ojeda Bar, review by David Allsopp)
+
 - Fix pprintast for #... infix operators
   (Alain Frisch, report by Omar Chebib)
 
-
 ### Runtime system:
 
 - GPR#71: The runtime can now be shut down gracefully by means of the new
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 227e4267e5..73b34144e9 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -396,6 +396,17 @@ let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
 external readlink : string -> string = "unix_readlink"
 external symlink_stub : bool -> string -> string -> unit = "unix_symlink"
 
+(* See https://caml.inria.fr/mantis/view.php?id=7564.
+   The Windows API used to create symbolic links does not normalize the target
+   of a symbolic link, so we do it here.  Note that we cannot use the native
+   Windows call GetFullPathName to do this because we need relative paths to
+   stay relative. *)
+let normalize_slashes path =
+  if String.length path >= 4 && path.[0] = '\\' && path.[1] = '\\' && path.[2] = '?' && path.[3] = '\\' then
+    path
+  else
+    String.init (String.length path) (fun i -> match path.[i] with '/' -> '\\' | c -> c)
+
 let symlink ?to_dir source dest =
   let to_dir =
     match to_dir with
@@ -407,7 +418,8 @@ let symlink ?to_dir source dest =
         with _ ->
           false
   in
-    symlink_stub to_dir source dest
+  let source = normalize_slashes source in
+  symlink_stub to_dir source dest
 
 external has_symlink : unit -> bool = "unix_has_symlink"
 
@@ -565,7 +577,7 @@ type msg_flag =
   | MSG_DONTROUTE
   | MSG_PEEK
 
-external socket : 
+external socket :
   ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
   = "unix_socket"
 let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
@@ -954,7 +966,7 @@ let open_process_full cmd env =
     with e ->
       close out_read; close out_write;
       close in_read; close in_write;
-      close err_read; close err_write; 
+      close err_read; close err_write;
       raise e
   end;
   close out_read;
diff --git a/testsuite/tests/lib-unix/win-symlink/Makefile b/testsuite/tests/lib-unix/win-symlink/Makefile
new file mode 100755
index 0000000000..c0c031ac09
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/Makefile
@@ -0,0 +1,16 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+MAIN_MODULE=test
+TEST_TEMP_FILES=link1 link2 test.txt
+
+test:
+	@if $(OCAML) $(ADD_COMPFLAGS) unix.cma precheck.ml; then \
+	  $(MAKE) default; \
+	else \
+	  echo " ... testing => skipped (not on Windows and/or symlinks not allowed)"; \
+	fi
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-unix/win-symlink/precheck.ml b/testsuite/tests/lib-unix/win-symlink/precheck.ml
new file mode 100755
index 0000000000..85c9550f23
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/precheck.ml
@@ -0,0 +1,2 @@
+let () =
+  exit (if Sys.win32 && Unix.has_symlink () then 0 else 1)
diff --git a/testsuite/tests/lib-unix/win-symlink/test.ml b/testsuite/tests/lib-unix/win-symlink/test.ml
new file mode 100755
index 0000000000..0c8556d238
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/test.ml
@@ -0,0 +1,19 @@
+let link1 = "link1"
+let link2 = "link2"
+
+let link_exists s =
+  try (Unix.lstat s).Unix.st_kind = Unix.S_LNK with _ -> false
+
+let main () =
+  close_out (open_out "test.txt");
+  if link_exists link1 then Sys.remove link1;
+  if link_exists link2 then Sys.remove link2;
+  Unix.symlink ~to_dir:false ".\\test.txt" link1;
+  assert ((Unix.stat link1).Unix.st_kind = Unix.S_REG);
+  print_endline "Unix.symlink works with backwards slashes";
+  Unix.symlink ~to_dir:false "./test.txt" link2;
+  assert ((Unix.stat link2).Unix.st_kind = Unix.S_REG);
+  print_endline "Unix.symlink works with forward slashes"
+
+let () =
+  Unix.handle_unix_error main ()
diff --git a/testsuite/tests/lib-unix/win-symlink/test.reference b/testsuite/tests/lib-unix/win-symlink/test.reference
new file mode 100644
index 0000000000..871a3e019e
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/test.reference
@@ -0,0 +1,2 @@
+Unix.symlink works with backwards slashes
+Unix.symlink works with forward slashes