diff --git a/TODO b/TODO index 71cd0b37fe475c6168dcfc849fe8fbc1cf46553f..97ff02e9a2166ce1c1600e54ba43b7eb3fb7aa15 100644 --- a/TODO +++ b/TODO @@ -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 diff --git a/test/script-support.lisp b/test/script-support.lisp index 4496c9a6618672c2dab5179eb3a559b9700fd6f6..fae5cf49fda900956d4c7f5c5e3d9220b70d8290 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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) diff --git a/test/test-utilities.script b/test/test-utilities.script index e0008b2af8152d9b43f1fec02c89852cec5d3155..a523b15ab7f3aa88445b64d14c4226ddf6099778 100755 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -1,6 +1,7 @@ ;;; -*- 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 diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index 94b63a99a871f60940d8b607e1306d15f7f27964..f8cbebf595bfa86ede96003be4f5fb800d725ff3 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -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?"