Sys.rename win fixes (#12184)

4 files changed, 42 insertions, 0 deletions

diff --git a/Changes b/Changes
index 40be5e7574..75c07f1984 100644
--- a/Changes
+++ b/Changes
@@ -349,6 +349,9 @@ OCaml 5.1.0
   (Xavier Leroy, review by Edwin Török and Gabriel Scherer, fix by Damien
    Doligez)
 
+- #12184: Sys.rename Windows fixes on directory corner cases.
+  (Jan Midtgaard, review by Anil Madhavapeddy)
+
 ### Other libraries:
 
 - #11374: Remove pointer cast to a type with stricter alignment requirements
diff --git a/runtime/win32.c b/runtime/win32.c
index 599805145f..90527f01c8 100644
--- a/runtime/win32.c
+++ b/runtime/win32.c
@@ -783,6 +783,28 @@ CAMLexport wchar_t *caml_win32_getenv(wchar_t const *lpName)
 
 int caml_win32_rename(const wchar_t * oldpath, const wchar_t * newpath)
 {
+  /* First handle corner-cases not handled by MoveFileEx:
+     - dir to empty dir - positive - should succeed
+     - dir to existing file - should fail */
+  DWORD old_attribs = GetFileAttributes(oldpath);
+  if ((old_attribs != INVALID_FILE_ATTRIBUTES) &&
+      (old_attribs & FILE_ATTRIBUTE_DIRECTORY) != 0 &&
+      (old_attribs & FILE_ATTRIBUTE_HIDDEN) == 0 &&
+      (old_attribs & FILE_ATTRIBUTE_SYSTEM) == 0) {
+    DWORD new_attribs = GetFileAttributes(newpath);
+    if ((new_attribs != INVALID_FILE_ATTRIBUTES) &&
+        (new_attribs & FILE_ATTRIBUTE_HIDDEN) == 0 &&
+        (new_attribs & FILE_ATTRIBUTE_SYSTEM) == 0) {
+      if ((new_attribs & FILE_ATTRIBUTE_DIRECTORY) != 0) {
+        /* Try to delete and fall though.
+           RemoveDirectoryW fails on non-empty dirs as intended. */
+        RemoveDirectoryW(newpath);
+      } else {
+        errno = ENOTDIR;
+        return -1;
+      }
+    }
+  }
   /* MOVEFILE_REPLACE_EXISTING: to be closer to POSIX
      MOVEFILE_COPY_ALLOWED: MoveFile performs a copy if old and new
        paths are on different devices, so we do the same here for
diff --git a/testsuite/tests/lib-sys/rename.ml b/testsuite/tests/lib-sys/rename.ml
index 948481c3de..7c62f218e9 100644
--- a/testsuite/tests/lib-sys/rename.ml
+++ b/testsuite/tests/lib-sys/rename.ml
@@ -82,3 +82,18 @@ let _ =
   testfailure "foo" "bar";
   print_newline();
   safe_remove f1; safe_remove_dir "foo"; safe_remove_dir "bar";
+  print_string "Rename directory to existing empty directory: ";
+  Sys.mkdir "foo" 0o755;
+  Sys.mkdir "bar" 0o755;
+  testrenamedir "foo" "bar";
+  print_newline();
+  safe_remove_dir "foo";
+  safe_remove_dir "bar";
+  print_string "Rename directory to existing file: ";
+  Sys.mkdir "foo" 0o755;
+  writefile f2 "xyz";
+  testfailure "foo" f2;
+  print_newline();
+  safe_remove_dir "foo";
+  safe_remove f2;
+  safe_remove_dir f2;
diff --git a/testsuite/tests/lib-sys/rename.reference b/testsuite/tests/lib-sys/rename.reference
index db06aad9d3..6fe40fcf87 100644
--- a/testsuite/tests/lib-sys/rename.reference
+++ b/testsuite/tests/lib-sys/rename.reference
@@ -5,3 +5,5 @@ Renaming to a nonexisting directory: fails as expected
 Rename directory to a nonexisting directory: passed
 Rename a nonexisting directory: fails as expected
 Rename directory to a non-empty directory: fails as expected
+Rename directory to existing empty directory: passed
+Rename directory to existing file: fails as expected