[Git][cmucl/cmucl][issue-132-ansi-test-rename-files] Fix so renaming directories does the expected thing.

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-132-ansi-test-rename-files at cmucl / cmucl


Commits:
127d8235 by Raymond Toy at 2022-09-16T12:58:47-07:00
Fix so renaming directories does the expected thing.

To do this, we need to merge the new name with
*default-pathname-defaults* to fill in the directory components if
needed.  Then we merge that with the original name to fill any
unfilled components.

Add a test for this where we rename "dir/orig-dir" to "dir/new-dir".

- - - - -


2 changed files:

- src/code/filesys.lisp
- tests/issues.lisp


Changes:

=====================================
src/code/filesys.lisp
=====================================
@@ -940,7 +940,7 @@
 
 ;;; Rename-File  --  Public
 ;;;
-(defun rename-file (file new-name)
+(defun rename-file (file new-file-name)
   "Rename File to have the specified New-Name.  If file is a stream
   open to a file, then the associated file is renamed.
 
@@ -950,7 +950,11 @@
   File after it was renamed."
   (let* ((original (truename file))
 	 (original-namestring (unix-namestring original t))
-	 (new-name (merge-pathnames new-name original))
+	 ;; First, merge NEW-FILE-NAME with *DEFAULT-PATHNAME-DEFAULTS* to
+	 ;; fill in the missing components and then merge again with
+	 ;; the FILE to get any missing components from FILE.
+	 (new-name (merge-pathnames (merge-pathnames new-file-name)
+				    file))
 	 (new-namestring (unix-namestring new-name nil)))
     (unless new-namestring
       (error 'simple-file-error
@@ -968,7 +972,9 @@
 				       (unix:get-unix-error-msg error))))
       (when (streamp file)
 	(file-name file new-namestring))
-      (values new-name original (truename new-name)))))
+      (values new-name
+	      original
+	      (truename new-name)))))
 
 ;;; Delete-File  --  Public
 ;;;


=====================================
tests/issues.lisp
=====================================
@@ -579,3 +579,27 @@
 	with user-info = (unix:unix-getpwuid uid)
 	while user-info
 	finally (assert-false user-info)))
+
+(define-test issue.132
+    (:tag :issues)
+  ;; From a message on cmucl-imp 2008/06/01.  If "d1" is a directory,
+  ;; (rename "d1" "d2") should rename the directory "d1" to "d2".
+  ;; Previously that produced an error trying to rename "d1" to
+  ;; "d1/d2".
+  ;;
+  ;; Create the test directory (that is a subdirectory of "dir").
+  (assert (ensure-directories-exist "dir/orig-dir/"))
+  (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
+    (multiple-value-bind (defaulted-new-name old-truename new-truename)
+	;; Rename "dir/orig-dir" to "orig/new-dir".
+	(rename-file "orig-dir/" "new-dir")
+      (let ((orig (merge-pathnames
+		   (make-pathname :directory '(:relative "orig-dir"))))
+	    (new (merge-pathnames
+		  (make-pathname :directory '(:relative "new-dir")))))
+	;; Ensure that the rename worked and that the returned values
+	;; have the expected values.
+	(assert defaulted-new-name)
+	(assert (equalp old-truename orig))
+	(assert (equalp new-truename new))))))
+  



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/127d8235e5c2553e359af9e084b3bcc80ac24c61

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/127d8235e5c2553e359af9e084b3bcc80ac24c61
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20220916/ca2677b3/attachment-0001.html>