From d88e4273e3efad54c873d5697a7430d1c8cfdda0 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sat, 27 Aug 2016 18:53:39 -0400 Subject: [PATCH] Defensively physicalize pathnames This make test-logical-pathname.script work on CLISP, despite CLISP bug 677. --- test/test-logical-pathname.script | 18 ++++++++++-------- uiop/filesystem.lisp | 17 ++++++++++------- uiop/lisp-build.lisp | 23 +++++++++++++++-------- uiop/stream.lisp | 10 +++++++--- 4 files changed, 42 insertions(+), 26 deletions(-) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index 5b3e6f3b6..d29197733 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -1,11 +1,11 @@ ;;; -*- Lisp -*- +(defun wild (&rest keys) + (apply 'make-pathname :defaults (wilden *asdf-directory*) keys)) + (setf (logical-pathname-translations "ASDF") - #+(or allegro clisp) - `(("**;*.*.*" ,(asdf::wilden *asdf-directory*))) - #-(or allegro clisp) - `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (asdf::wilden *asdf-directory*))) - ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (asdf::wilden *asdf-directory*))) + `(("**;*.asd.*" ,(wild :type "asd")) + ("**;*.lisp.*" ,(wild :type "lisp")) ("**;*.*.*" ,(resolve-location `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) @@ -19,12 +19,14 @@ (translate-logical-pathname "ASDF:test;test-logical-pathname.lisp") (translate-logical-pathname "ASDF:test;test-logical-pathname.fasl")) -#+(or clisp gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0) +#+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0) (DBG "Test logical pathnames in central registry") +(clear-system :test-logical-pathname) (setf *central-registry* '(#p"ASDF:test;")) +(assert (logical-pathname-p (first *central-registry*))) (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) -(DBG "loading" (oos 'load-op :test-logical-pathname :force t)) +(DBG "loading" (load-system :test-logical-pathname :force t)) (DBG "Test logical pathnames in source-registry, non-recursive") (clear-system :test-logical-pathname) @@ -45,7 +47,7 @@ :ignore-inherited-configuration)) (load-system :test-logical-pathname :force t) -#+(or clisp abcl) (leave-test "CLISP and ABCL translate logical pathnames in *LOAD-PATHNAME*" 0) +#+abcl (leave-test "ABCL translates logical pathnames in *LOAD-PATHNAME*" 0) (defparameter sys (find-system :test-logical-pathname)) (assert (logical-pathname-p (component-pathname sys))) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index 86c7d1fb1..2a7b5b555 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -601,13 +601,16 @@ NILs." (defun rename-file-overwriting-target (source target) "Rename a file, overwriting any previous file with the TARGET name, in an atomic way if the implementation allows." - #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic - (progn (funcall 'require "syscalls") - (symbol-call :posix :copy-file source target :method :rename)) - #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic - #-clisp - (rename-file source target - #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t)) + (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) + (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) + #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic + (progn (funcall 'require "syscalls") + (symbol-call :posix :copy-file source target :method :rename)) + #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic + #-clisp + (rename-file source target + #+(or clasp clozure ecl) :if-exists + #+clozure :rename-and-delete #+(or clasp ecl) t))) (defun delete-empty-directory (directory-pathname) "Delete an empty directory" diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index 18c6b6926..e7582ca85 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -667,6 +667,7 @@ it will filter them appropriately." (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) + (physical-output-file (physicalize-pathname output-file)) #+(or clasp ecl) (object-file (unless (use-ecl-byte-compiler-p) @@ -677,11 +678,11 @@ it will filter them appropriately." (object-file (or object-file (compile-file-pathname output-file :fasl-p nil))) - (tmp-file (tmpize-pathname output-file)) + (tmp-file (tmpize-pathname physical-output-file)) #+sbcl (cfasl-file (etypecase emit-cfasl (null nil) - ((eql t) (make-pathname :type "cfasl" :defaults output-file)) + ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file)) (string (parse-namestring emit-cfasl)) (pathname emit-cfasl))) #+sbcl @@ -720,17 +721,23 @@ it will filter them appropriately." #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file)))) (or (not compile-check) (apply compile-check input-file - :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file + :output-file output-truename keywords)))) - (delete-file-if-exists output-file) + (delete-file-if-exists physical-output-file) (when output-truename #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename)) - #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) + ;; see CLISP bug 677 + #+clisp + (progn + (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) + (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) + (rename-file-overwriting-target tmp-lib lib-file)) #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) - (rename-file-overwriting-target output-truename output-file) - (setf output-truename (truename output-file))) + (rename-file-overwriting-target output-truename physical-output-file) + (setf output-truename (truename physical-output-file))) #+clasp (delete-file-if-exists tmp-file) - #+clisp (delete-file-if-exists tmp-lib)) + #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 + (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup (t ;; error or failed check (delete-file-if-exists output-truename) #+clisp (delete-file-if-exists tmp-lib) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index 6791941b8..3175c96c3 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -579,7 +579,11 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e (loop :with prefix-pn = (ensure-absolute-pathname (or prefix "tmp") - (or (ensure-pathname directory :namestring :native :ensure-directory t) + (or (ensure-pathname + directory + :namestring :native + :ensure-directory t + :ensure-physical t) #'temporary-directory)) :with prefix-nns = (native-namestring prefix-pn) :with results = (progn (ensure-directories-exist prefix-pn) @@ -679,9 +683,9 @@ Further KEYS can be passed to MAKE-PATHNAME." "Return a new pathname modified from X by adding a trivial random suffix. A new empty file with said temporary pathname is created, to ensure there is no clash with any concurrent process attempting the same thing." - (let* ((px (ensure-pathname x)) + (let* ((px (ensure-pathname x :ensure-physical t)) (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) - (directory (translate-logical-pathname (pathname-directory-pathname px)))) + (directory (pathname-directory-pathname px))) (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)))) (defun call-with-staging-pathname (pathname fun) -- GitLab