From 7184771c315004a4e0d6a733c5a3b495a7d4056b Mon Sep 17 00:00:00 2001
From: Benjamin Pollack <benjamin@bitquabit.com>
Date: Thu, 5 Jan 2017 18:26:55 -0500
Subject: [PATCH] io.directories: improve file moving words

move-file previously had inconsistent behavior on Windows and unixes.
This unifies the behavior to the common case (just get 'er done), while
also introducing an obviously named word, move-file-atomically, to
handle the case where you need an atomic file primitive.

Fixes #1772
---
 basis/io/directories/directories-docs.factor | 8 +++++++-
 basis/io/directories/directories.factor      | 1 +
 basis/io/directories/unix/unix.factor        | 9 ++++++++-
 basis/io/directories/windows/windows.factor  | 3 +++
 basis/windows/kernel32/kernel32.factor       | 3 ++-
 5 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor
index 90d51249bf..07d6afcc69 100644
--- a/basis/io/directories/directories-docs.factor
+++ b/basis/io/directories/directories-docs.factor
@@ -104,7 +104,13 @@ HELP: touch-file
 
 HELP: move-file
 { $values { "from" "a pathname string" } { "to" "a pathname string" } }
-{ $description "Moves or renames a file." }
+{ $description "Moves or renames a file. This operation is not guaranteed to be atomic. In particular, if you attempt to move a file across volumes, this will copy the file and then delete the original in a nontransactional manner." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." }
+{ $see-also move-file-atomically } ;
+
+HELP: move-file-atomically
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Moves or renames a file as an atomic operation." }
 { $errors "Throws an error if the file does not exist or if the move operation fails." } ;
 
 HELP: move-file-into
diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor
index d9353d8113..0b5c335f9a 100644
--- a/basis/io/directories/directories.factor
+++ b/basis/io/directories/directories.factor
@@ -84,6 +84,7 @@ HOOK: delete-directory io-backend ( path -- )
 
 ! Moving and renaming files
 HOOK: move-file io-backend ( from to -- )
+HOOK: move-file-atomically io-backend ( from to -- )
 
 : move-file-into ( from to -- )
     to-directory move-file ;
diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor
index 3cc0b549e8..14a37f5bed 100644
--- a/basis/io/directories/unix/unix.factor
+++ b/basis/io/directories/unix/unix.factor
@@ -17,9 +17,16 @@ M: unix touch-file ( path -- )
         touch-mode file-mode open-file close-file
     ] if ;
 
-M: unix move-file ( from to -- )
+M: unix move-file-atomically ( from to -- )
     [ normalize-path ] bi@ [ rename ] unix-system-call drop ;
 
+M: unix move-file ( from to -- )
+    [ move-file-atomically ] [
+        dup errno>> EXDEV = [
+            drop [ copy-file ] [ drop delete-file ] 2bi
+        ] [ rethrow ] if
+    ] recover ;
+
 M: unix delete-file ( path -- ) normalize-path unlink-file ;
 
 M: unix make-directory ( path -- )
diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor
index bfc7f8a1b4..16f4724b30 100644
--- a/basis/io/directories/windows/windows.factor
+++ b/basis/io/directories/windows/windows.factor
@@ -17,6 +17,9 @@ M: windows touch-file ( path -- )
 M: windows move-file ( from to -- )
     [ normalize-path ] bi@ MoveFile win32-error=0/f ;
 
+M: windows move-file-atomically ( from to -- )
+    [ normalize-path ] bi@ 0 MoveFileEx win32-error=0/f ;
+
 ERROR: file-delete-failed path error ;
 
 : delete-file-throws ( path -- )
diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
index 0ebb18c4d0..5e2b170d65 100644
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@@ -1676,7 +1676,8 @@ FUNCTION: LPVOID MapViewOfFileEx ( HANDLE hFileMappingObject,
 ! FUNCTION: Module32NextW
 ! FUNCTION: MoveFileA
 ! FUNCTION: MoveFileExA
-! FUNCTION: MoveFileExW
+FUNCTION: BOOL MoveFileExW ( LPCSTR lpExistingFile, LPCSTR lpNewFileName, DWORD dwFlags )
+ALIAS: MoveFileEx MoveFileExW
 FUNCTION: BOOL MoveFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName )
 ALIAS: MoveFile MoveFileW
 ! FUNCTION: MoveFileWithProgressA
-- 
2.34.1