Commit d88e4273 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Defensively physicalize pathnames

This make test-logical-pathname.script work on CLISP,
despite CLISP bug 677.
parent a763da75
;;; -*- 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)))
......
......@@ -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"
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment