Skip to content
Snippets Groups Projects
Commit 4fc1e719 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

uiop: make probe-file* and truename* more robust

parent f73f7d8b
No related branches found
No related tags found
No related merge requests found
...@@ -113,6 +113,7 @@ ...@@ -113,6 +113,7 @@
*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL??? *** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL???
** XCL has bad bugs: ** XCL has bad bugs:
*** it can't compile ASDF3 anymore. Figure out why, if you have time.
*** make-pathname doesn't handle :type nil properly and *** make-pathname doesn't handle :type nil properly and
has massive lossage in logical-pathname support. has massive lossage in logical-pathname support.
*** If using block () and return in search-for-system-definition *** If using block () and return in search-for-system-definition
......
...@@ -168,14 +168,14 @@ Some constraints: ...@@ -168,14 +168,14 @@ Some constraints:
qx x (pathname-components x) qx x (pathname-components x)
qy y (pathname-components y))) qy y (pathname-components y)))
;; accept equalp namestrings, to account for case-independent filesystems ;; accept equalp namestrings, to account for case-independent filesystems
((equalp (namestring x) (namestring y)) ((equalp (and x (namestring x)) (and y (namestring y)))
(warn "These two expressions yield pathnames that have equalp namestrings yet are not pathname-equal~%~ (warn "These two expressions yield pathnames that have equalp namestrings yet are not pathname-equal~%~
the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%"
qx x (pathname-components x) qx x (pathname-components x)
qy y (pathname-components y))) qy y (pathname-components y)))
(t (t
(error "These two expressions yield paths that are equal in any way:~%~ (error "These two expressions yield paths that are not equal in any way:~%~
the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%"
qx x (pathname-components x) qx x (pathname-components x)
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
#+(and sbcl os-windows) (trace sb-ext:run-program) #+(and sbcl os-windows) (trace sb-ext:run-program)
(proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0)))
(defun getcwd-from-run-program () (defun getcwd-from-run-program ()
(uiop:parse-native-namestring (uiop:parse-native-namestring
...@@ -14,19 +15,93 @@ ...@@ -14,19 +15,93 @@
:output '(:string :stripped t))) :output '(:string :stripped t)))
:ensure-directory t)) :ensure-directory t))
(let ((asdf-directory (truename *asdf-directory*))) (let ((asdf-directory (truename *asdf-directory*))
(chdir asdf-directory) (test-directory (truename *test-directory*)))
(assert-pathname-equal asdf-directory (getcwd)) (labels ((check-cwd (dir)
#-(and sbcl os-windows) (assert-pathname-equal dir (getcwd))
(assert-pathname-equal asdf-directory (getcwd-from-run-program)) #-(and sbcl os-windows)
(assert (probe-file* "asdf.asd"))) (assert-pathname-equal dir (getcwd-from-run-program)))
(check-true-dpd (dir)
(let ((test-directory (truename *test-directory*))) (assert-pathname-equal dir (get-pathname-defaults))
(chdir test-directory) (assert-pathname-equal dir (truename #p"./"))
(assert-pathname-equal test-directory (getcwd)) (assert-pathname-equal dir (truename* #p"./")))
#-(and sbcl os-windows) (check-file-exists (file &optional true)
(assert-pathname-equal test-directory (getcwd-from-run-program)) (setf file (parse-unix-namestring file))
(assert (probe-file* "test-utilities.script"))) (if true
(assert-pathname-equal true (probe-file file))
(setf true (probe-file file)))
(assert-pathname-equal true (truename file))
(assert-pathname-equal true (truename* file))
(assert-pathname-equal true (probe-file* file :truename t))
(assert-pathname-equal true (ensure-absolute-pathname (probe-file* file) 'get-pathname-defaults)))
(check-file-doesnt-exist (file)
(setf file (parse-unix-namestring file))
(assert-equal nil (probe-file* file))
(assert-equal nil (probe-file file)))
(check-directory-exists (file &optional true)
(setf file (parse-unix-namestring file))
(let ((dir (truename (ensure-directory-pathname file))))
(if true
(assert-pathname-equal true dir)
(setf true dir)))
(assert-pathname-equal true (truename (ensure-directory-pathname file)))
(assert-pathname-equal true (truename* file))
(assert-pathname-equal true (nest #+allegro (ensure-directory-pathname) (probe-file* file :truename t)))
(assert-pathname-equal true (if-let (x (probe-file* file))
(ensure-absolute-pathname (ensure-directory-pathname x) 'get-pathname-defaults))))
(check-directory-doesnt-exist (file)
(setf file (parse-unix-namestring file))
(assert-equal nil (probe-file* file)))
(check-true-dpd-asdf ()
(check-true-dpd asdf-directory)
(check-file-exists "asdf.asd")
(check-file-exists "test/test-utilities.script")
(check-directory-exists "tools/")
(check-directory-exists "tools")
(check-file-doesnt-exist "test-utilities.script")
(check-directory-doesnt-exist "stamp-propagation/"))
(check-true-dpd-test ()
(check-true-dpd test-directory)
(check-file-exists "test-utilities.script")
(check-directory-exists "stamp-propagation/")
(check-directory-exists "stamp-propagation")
(check-file-doesnt-exist "test/test-utilities.script")
(check-directory-doesnt-exist "tools/")))
(DBG "1" (chdir asdf-directory) (setf *default-pathname-defaults* asdf-directory))
(check-true-dpd-asdf)
(DBG "2" (chdir test-directory) (setf *default-pathname-defaults* test-directory))
(check-true-dpd-test)
(with-expected-failure (#+gcl t)
(DBG "3" (chdir asdf-directory) (setf *default-pathname-defaults* test-directory))
(check-true-dpd-test))
#-(or abcl genera xcl) ;; on these platforms, chdir changes D-P-D so these tests are not meaningful
(progn
;; SBCL hates to get (truename #p"") when D-P-D is itself #p"". See https://bugs.launchpad.net/sbcl/+bug/1472414
(DBG "4"
(setf *default-pathname-defaults* (nil-pathname)) ;; make things relative to GETCWD
(chdir asdf-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname.
(check-true-dpd-asdf)
(DBG "5"
*default-pathname-defaults*
(chdir test-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname.
(check-true-dpd-test)
;; On implementations where chdir doesn't side-effect D-P-D, we can have D-P-D be relative to GETCWD...
;; except on allegro, that hates this trick.
(with-expected-failure (#+(or allegro gcl) t)
(unless (absolute-pathname-p *default-pathname-defaults*)
(DBG "6"
(chdir asdf-directory)
(setf *default-pathname-defaults* (parse-unix-namestring "test/")))
(check-true-dpd-test))))
;; For the rest of this test, use these:
(setf *default-pathname-defaults* (nil-pathname))
(chdir test-directory)))
(assert (assert
(every #'directory-pathname-p (every #'directory-pathname-p
......
...@@ -64,9 +64,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -64,9 +64,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
;;; Probing the filesystem ;;; Probing the filesystem
(with-upgradability () (with-upgradability ()
(defun truename* (p) (defun truename* (p)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts" "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
;; avoids both logical-pathname merging and physical resolution issues (when p
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil)))) (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
(values
(or (ignore-errors (truename p))
#+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
(defun safe-file-write-date (pathname) (defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
...@@ -87,60 +90,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -87,60 +90,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
probes the filesystem for a file or directory with given pathname. probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true, If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)." or the original (parsed) pathname if it is false (the default)."
(etypecase p (values
(null nil) (ignore-errors
(string (setf p (funcall 'ensure-pathname p
;; avoid logical-pathname issues on some implementations :namestring :lisp
(let ((pn (with-pathname-defaults () (parse-namestring p)))) :ensure-physical t
(probe-file* pn :truename truename))) :ensure-absolute t :defaults 'get-pathname-defaults
(pathname :want-non-wild t
(and (not (wild-pathname-p p)) :on-error nil))
(handler-case (when p
(or #+allegro
#+allegro (probe-file p :follow-symlinks truename)
(probe-file p :follow-symlinks truename) #+gcl
#+gcl (if truename
(if truename (truename* p)
(truename* p) (let ((kind (car (si::stat p))))
(let ((kind (car (si::stat p)))) (when (eq kind :link)
(when (eq kind :link) (setf kind (ignore-errors (car (si::stat (truename* p))))))
(setf kind (ignore-errors (car (si::stat (truename* p)))))) (ecase kind
(ecase kind ((nil) nil)
((nil) nil) ((:file :link)
((:file :link) (cond
(cond ((file-pathname-p p) p)
((file-pathname-p p) p) ((directory-pathname-p p)
((directory-pathname-p p) (subpathname p (car (last (pathname-directory p)))))))
(subpathname p (car (last (pathname-directory p))))))) (:directory (ensure-directory-pathname p)))))
(:directory (ensure-directory-pathname p))))) #+clisp
#+clisp #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
#.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) (pp (find-symbol* '#:probe-pathname :ext nil)))
(pp (find-symbol* '#:probe-pathname :ext nil))) `(if truename
`(if truename ,(if pp
,(if pp `(values (,pp p))
`(ignore-errors (,pp p)) '(or (truename* p)
'(or (truename* p) (truename* (ignore-errors (ensure-directory-pathname p)))))
(truename* (ignore-errors (ensure-directory-pathname p))))) ,(cond
,(cond (fs `(and (,fs p) p))
(fs `(and (ignore-errors (,fs p)) p)) (pp `(nth-value 1 (,pp p)))
(pp `(ignore-errors (nth-value 1 (,pp p)))) (t '(or (and (truename* p) p)
(t '(if-let (q (ensure-absolute-pathname p (if-let (d (ensure-directory-pathname p))
:defaults 'get-pathname-defaults :on-error nil)) (and (truename* d) d)))))))
(or (and (truename* q) q) #-(or allegro clisp gcl)
(if-let (d (ignore-errors (ensure-directory-pathname q))) (if truename
(and (truename* d) d)))))))) (probe-file p)
#-(or allegro clisp gcl) (and
(if truename #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
(probe-file p) #+(and lispworks unix) (system:get-file-stat p)
(ignore-errors #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
(let ((pp (physicalize-pathname p))) #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
(and p))))))
#+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
#+(and lispworks unix) (system:get-file-stat pp)
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p)))))
(file-error () nil))))))
(defun directory-exists-p (x) (defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?" "Is X the name of a directory that exists on the filesystem?"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment