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 @@
*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL???
** 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
has massive lossage in logical-pathname support.
*** If using block () and return in search-for-system-definition
......
......@@ -168,14 +168,14 @@ Some constraints:
qx x (pathname-components x)
qy y (pathname-components y)))
;; 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~%~
the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%"
qx x (pathname-components x)
qy y (pathname-components y)))
(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 other expression ~S yields that:~% ~S~% ~S~%"
qx x (pathname-components x)
......
;;; -*- Lisp -*-
#+(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 ()
(uiop:parse-native-namestring
......@@ -14,19 +15,93 @@
:output '(:string :stripped t)))
:ensure-directory t))
(let ((asdf-directory (truename *asdf-directory*)))
(chdir asdf-directory)
(assert-pathname-equal asdf-directory (getcwd))
#-(and sbcl os-windows)
(assert-pathname-equal asdf-directory (getcwd-from-run-program))
(assert (probe-file* "asdf.asd")))
(let ((test-directory (truename *test-directory*)))
(chdir test-directory)
(assert-pathname-equal test-directory (getcwd))
#-(and sbcl os-windows)
(assert-pathname-equal test-directory (getcwd-from-run-program))
(assert (probe-file* "test-utilities.script")))
(let ((asdf-directory (truename *asdf-directory*))
(test-directory (truename *test-directory*)))
(labels ((check-cwd (dir)
(assert-pathname-equal dir (getcwd))
#-(and sbcl os-windows)
(assert-pathname-equal dir (getcwd-from-run-program)))
(check-true-dpd (dir)
(assert-pathname-equal dir (get-pathname-defaults))
(assert-pathname-equal dir (truename #p"./"))
(assert-pathname-equal dir (truename* #p"./")))
(check-file-exists (file &optional true)
(setf file (parse-unix-namestring file))
(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
(every #'directory-pathname-p
......
......@@ -64,9 +64,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
;;; Probing the filesystem
(with-upgradability ()
(defun truename* (p)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
;; avoids both logical-pathname merging and physical resolution issues
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
"Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
(when p
(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)
"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"
probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)."
(etypecase p
(null nil)
(string
;; avoid logical-pathname issues on some implementations
(let ((pn (with-pathname-defaults () (parse-namestring p))))
(probe-file* pn :truename truename)))
(pathname
(and (not (wild-pathname-p p))
(handler-case
(or
#+allegro
(probe-file p :follow-symlinks truename)
#+gcl
(if truename
(truename* p)
(let ((kind (car (si::stat p))))
(when (eq kind :link)
(setf kind (ignore-errors (car (si::stat (truename* p))))))
(ecase kind
((nil) nil)
((:file :link)
(cond
((file-pathname-p p) p)
((directory-pathname-p p)
(subpathname p (car (last (pathname-directory p)))))))
(:directory (ensure-directory-pathname p)))))
#+clisp
#.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
(pp (find-symbol* '#:probe-pathname :ext nil)))
`(if truename
,(if pp
`(ignore-errors (,pp p))
'(or (truename* p)
(truename* (ignore-errors (ensure-directory-pathname p)))))
,(cond
(fs `(and (ignore-errors (,fs p)) p))
(pp `(ignore-errors (nth-value 1 (,pp p))))
(t '(if-let (q (ensure-absolute-pathname p
:defaults 'get-pathname-defaults :on-error nil))
(or (and (truename* q) q)
(if-let (d (ignore-errors (ensure-directory-pathname q)))
(and (truename* d) d))))))))
#-(or allegro clisp gcl)
(if truename
(probe-file p)
(ignore-errors
(let ((pp (physicalize-pathname p)))
(and
#+(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))))))
(values
(ignore-errors
(setf p (funcall 'ensure-pathname p
:namestring :lisp
:ensure-physical t
:ensure-absolute t :defaults 'get-pathname-defaults
:want-non-wild t
:on-error nil))
(when p
#+allegro
(probe-file p :follow-symlinks truename)
#+gcl
(if truename
(truename* p)
(let ((kind (car (si::stat p))))
(when (eq kind :link)
(setf kind (ignore-errors (car (si::stat (truename* p))))))
(ecase kind
((nil) nil)
((:file :link)
(cond
((file-pathname-p p) p)
((directory-pathname-p p)
(subpathname p (car (last (pathname-directory p)))))))
(:directory (ensure-directory-pathname p)))))
#+clisp
#.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
(pp (find-symbol* '#:probe-pathname :ext nil)))
`(if truename
,(if pp
`(values (,pp p))
'(or (truename* p)
(truename* (ignore-errors (ensure-directory-pathname p)))))
,(cond
(fs `(and (,fs p) p))
(pp `(nth-value 1 (,pp p)))
(t '(or (and (truename* p) p)
(if-let (d (ensure-directory-pathname p))
(and (truename* d) d)))))))
#-(or allegro clisp gcl)
(if truename
(probe-file p)
(and
#+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
#+(and lispworks unix) (system:get-file-stat p)
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
p))))))
(defun directory-exists-p (x)
"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