Commit 4fc1e719 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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

parent f73f7d8b

TODO

+1 −0
Original line number Diff line number Diff line
@@ -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

test/script-support.lisp

+2 −2
Original line number Diff line number Diff line
@@ -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)

test/test-utilities.script

+88 −13
Original line number Diff line number Diff line 
;;; -*- 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))

(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 asdf-directory (getcwd-from-run-program))

  (assert (probe-file* "asdf.asd")))

             (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))))



(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")))

    ;; For the rest of this test, use these:

    (setf *default-pathname-defaults* (nil-pathname))

    (chdir test-directory)))



(assert

 (every #'directory-pathname-p

uiop/filesystem.lisp

+54 −57
Original line number Diff line number Diff line
@@ -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,16 +90,15 @@ 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

    (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
@@ -118,29 +120,24 @@ or the original (parsed) pathname if it is false (the default)." 
                 (pp (find-symbol* '#:probe-pathname :ext nil)))

            `(if truename

                 ,(if pp

			     `(ignore-errors (,pp p))

                      `(values (,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))))))))

                    (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)

		   (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))))))

             #+(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?"