;;; pathname-tests.lisp ;;; ;;; Copyright (C) 2005 Peter Graves ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation; either version 2 ;;; of the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (in-package #:abcl.test.lisp) (defun check-physical-pathname (pathname expected-directory expected-name expected-type) (let* ((directory (pathname-directory pathname)) (name (pathname-name pathname)) (type (pathname-type pathname)) (ok t)) (unless (and (pathnamep pathname) (not (typep pathname 'logical-pathname))) (setf ok nil)) (unless (and (equal directory expected-directory) (equal name expected-name) (equal type expected-type)) (setf ok nil)) ok)) (defun check-windows-pathname (pathname expected-host expected-device expected-directory expected-name expected-type) (let* ((host (pathname-host pathname)) (device (pathname-device pathname)) (directory (pathname-directory pathname)) (name (pathname-name pathname)) (type (pathname-type pathname)) (ok t)) (unless (and (pathnamep pathname) (not (typep pathname 'logical-pathname))) (setf ok nil)) (unless (and (equal host expected-host) (equal device expected-device) (equal directory expected-directory) (equal name expected-name) (equal type expected-type)) (setf ok nil)) ok)) (defun check-logical-pathname (pathname expected-host expected-directory expected-name expected-type expected-version) (let* ((host (pathname-host pathname)) (directory (pathname-directory pathname)) (name (pathname-name pathname)) (type (pathname-type pathname)) (version (pathname-version pathname)) ;; Allegro's logical pathnames don't canonicalize their string ;; components to upper case. (test #-allegro 'equal #+allegro 'equalp) (ok t)) (unless (typep pathname 'logical-pathname) (setf ok nil)) ;; "The device component of a logical pathname is always :UNSPECIFIC..." 19.3.2.1 #-allegro ;; Except on Allegro, where it's NIL. (unless (eq (pathname-device pathname) :unspecific) (setf ok nil)) (unless (and (funcall test (if (stringp host) host (host-namestring pathname)) expected-host) (funcall test directory expected-directory) (funcall test name expected-name) (funcall test type expected-type) (eql version expected-version)) (setf ok nil)) ok)) (defun check-merge-pathnames (pathname default-pathname expected-result) (let* ((result (merge-pathnames pathname default-pathname)) (test #-allegro 'equal #+allegro (if (typep result 'logical-pathname) 'equalp 'equal))) (and (funcall test (pathname-host result) (pathname-host expected-result)) (funcall test (pathname-directory result) (pathname-directory expected-result)) (funcall test (pathname-name result) (pathname-name expected-result)) (funcall test (pathname-type result) (pathname-type expected-result))))) (defun check-translate-pathname (args expected) (declare (optimize safety)) (declare (type list args)) (declare (type string expected)) (let ((result (namestring (apply 'translate-pathname args)))) (equal result ;;#-windows expected ;;#+windows (substitute #\\ #\/ expected) ))) (defmacro check-readable (pathname) `(equal ,pathname (read-from-string (write-to-string ,pathname :readably t)))) (defun check-readable-or-signals-error (pathname) (handler-case (equal pathname (read-from-string (write-to-string pathname :readably t))) (print-not-readable () t))) (defmacro check-namestring (pathname namestring) `(string= (namestring ,pathname) ;;#+windows (substitute #\\ #\/ ,namestring) ;;#-windows ,namestring)) ;; Define a logical host. (eval-when (:compile-toplevel :load-toplevel :execute) (setf (logical-pathname-translations "effluvia") '(("**;*.*.*" "/usr/local/**/*.*")))) (deftest equal.1 (equal (make-pathname :name "foo" :type "bar") (make-pathname :name "foo" :type "bar")) t) (deftest equal.2 (equal (make-pathname :name "foo" :type "bar" :version nil) (make-pathname :name "foo" :type "bar" :version :newest)) #+(or clisp lispworks) nil #-(or clisp lispworks) t) (deftest sxhash.1 (let* ((p (make-pathname :name "foo" :type "bar" :version nil)) (s (sxhash p))) (values (typep s 'fixnum) (>= s 0))) t t) ;; "(equal x y) implies (= (sxhash x) (sxhash y))" (deftest sxhash.2 (let ((p1 (make-pathname :name "foo" :type "bar" :version nil)) (p2 (make-pathname :name "foo" :type "bar" :version :newest))) (if (equal p1 p2) (= (sxhash p1) (sxhash p2)) t)) t) ;; It's suboptimal if all pathnames return the same SXHASH, but that happens ;; with SBCL. (deftest sxhash.3 (= (sxhash #p"/usr/local/bin/sbcl") (sxhash #p"") (sxhash #p"foo.bar")) #+sbcl t #-sbcl nil) ;; "Parsing a null string always succeeds, producing a pathname with all ;; components (except the host) equal to nil." (deftest physical.1 (check-physical-pathname #p"" nil nil nil) t) (deftest physical.2 (check-physical-pathname #p"/" '(:absolute) nil nil) t) (deftest physical.3 (check-physical-pathname #p"/foo" '(:absolute) "foo" nil) t) (deftest physical.4 #-lispworks (check-physical-pathname #p"/foo." '(:absolute) "foo" "") #+lispworks (check-physical-pathname #p"/foo." '(:absolute) "foo." nil) t) (deftest physical.5 (check-physical-pathname #p"/foo.bar" '(:absolute) "foo" "bar") t) (deftest physical.6 #-lispworks (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar" "") #+lispworks (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar." nil) t) (deftest physical.7 (check-physical-pathname #p"/foo.bar.baz" '(:absolute) "foo.bar" "baz") t) (deftest physical.8 (check-physical-pathname #p"/foo/bar" '(:absolute "foo") "bar" nil) t) (deftest physical.9 (check-physical-pathname #p"/foo..bar" '(:absolute) "foo." "bar") t) (deftest physical.10 (check-physical-pathname #p"foo.bar" nil "foo" "bar") t) (deftest physical.11 (check-physical-pathname #p"foo.bar.baz" nil "foo.bar" "baz") t) (deftest physical.12 (check-physical-pathname #p"foo/" '(:relative "foo") nil nil) t) (deftest physical.13 (check-physical-pathname #p"foo/bar" '(:relative "foo") "bar" nil) t) (deftest physical.14 (check-physical-pathname #p"foo/bar/baz" '(:relative "foo" "bar") "baz" nil) t) (deftest physical.15 (check-physical-pathname #p"foo/bar/" '(:relative "foo" "bar") nil nil) t) #+allegro (deftest physical.16 ;; This reduction is wrong. (check-physical-pathname #p"foo/bar/.." '(:relative "foo") nil nil) t) #+allegro (deftest physical.17 (check-physical-pathname #p"/foo/../" '(:absolute) nil nil) t) (deftest physical.18 #-lispworks (check-physical-pathname #p".lisprc" nil ".lisprc" nil) #+lispworks (check-physical-pathname #p".lisprc" nil "" "lisprc") t) (deftest physical.19 (check-physical-pathname #p"x.lisprc" nil "x" "lisprc") t) (deftest physical.20 #-allegro (check-physical-pathname (make-pathname :name ".") nil "." nil) #+allegro (check-physical-pathname (make-pathname :name ".") '(:relative) nil nil) t) (deftest physical.21 #-cmu (check-readable (make-pathname :name ".")) #+cmu (check-readable-or-signals-error (make-pathname :name ".")) t) #+(or cmu lispworks (and allegro windows)) (pushnew 'physical.21 *expected-failures*) ;; #p"." (deftest physical.22 #+(or allegro abcl cmu) (check-physical-pathname #p"." '(:relative) nil nil) #-(or allegro abcl cmu) ;; No trailing separator character means it's a file. (check-physical-pathname #p"." nil "." nil) t) #+lispworks (pushnew 'physical.22 *expected-failures*) (deftest namestring.1 (check-namestring #p"." #+(or abcl allegro cmu) "./" #-(or abcl allegro cmu) ".") t) #+lispworks (pushnew 'namestring.1 *expected-failures*) (deftest physical.23 (equal #p"." #p"") nil) #+lispworks (pushnew 'physical.23 *expected-failures*) ;; #p"./" ;; Trailing separator character means it's a directory. (deftest physical.24 (let ((pathname #-windows #p"./" #+windows #p".\\")) #-(or sbcl) (check-physical-pathname pathname '(:relative) nil nil) #+(or sbcl) ;; Is this more exact? (check-physical-pathname pathname '(:relative ".") nil nil)) t) #+(or lispworks (and allegro windows)) (pushnew 'physical.24 *expected-failures*) (deftest namestring.2 (check-namestring #-windows #p"./" #+windows #p".\\" "./") t) #+lispworks (pushnew 'namestring.2 *expected-failures*) (deftest directory-namestring.1 (equal (directory-namestring #p"./") "./") t) #+lispworks (pushnew 'directory-namestring.1 *expected-failures*) (deftest physical.25 (equal #-windows #p"./" #+windows #p".\\" #p"") nil) #+(or lispworks (and allegro windows)) (pushnew 'physical.25 *expected-failures*) (deftest physical.26 #-allegro (check-physical-pathname (make-pathname :name "..") nil ".." nil) #+allegro (check-physical-pathname (make-pathname :name "..") '(:relative :back) nil nil) t) #-(or sbcl) (deftest physical.27 #-cmu (check-readable (make-pathname :name "..")) #+cmu (check-readable-or-signals-error (make-pathname :name "..")) t) #+(or clisp cmu lispworks) (pushnew 'physical.27 *expected-failures*) ;; #p".." (deftest physical.28 #+(or allegro (and lispworks windows)) (check-physical-pathname #p".." '(:relative :back) nil nil) #+(or abcl cmu (and lispworks unix)) (check-physical-pathname #p".." '(:relative :up) nil nil) ;; Other implementations think it's a file. #+(or) ;; If it's a file, to a human its name would be "..". No implementation gets ;; this right. (check-physical-pathname #p".." nil ".." nil) #+(or sbcl clisp) ;; These implementations parse ".." as the name "." followed by another dot and ;; the type string "", which no human would do. (check-physical-pathname #p".." nil "." "") t) #+cmu (pushnew 'physical.28 *expected-failures*) (deftest namestring.3 (check-namestring #p".." #+(or abcl allegro cmu lispworks) "../" #-(or abcl allegro cmu lispworks) "..") t) ;; #p"../" (deftest physical.29 (let ((pathname #-windows #p"../" #+windows #p"..\\")) #+(or allegro (and lispworks windows)) (check-physical-pathname pathname '(:relative :back) nil nil) #+(or abcl sbcl cmu clisp (and lispworks unix)) (check-physical-pathname pathname '(:relative :up) nil nil)) t) (deftest namestring.4 (check-namestring #-windows #p"../" #+windows #p"..\\" "../") t) (deftest directory-namestring.2 (equal (directory-namestring #-windows #p"../" #+windows #p"..\\") "../") t) #-sbcl (deftest physical.30 #-(or allegro cmu) (string= (namestring (make-pathname :name "..")) "..") #+allegro (string= (namestring (make-pathname :name "..")) #-windows "../" #+windows "..\\") #+cmu (signals-error (make-pathname :name "..") 'warning) t) (deftest physical.31 (string= (namestring (make-pathname :directory '(:relative :up))) "../") t) #+windows (deftest windows.1 (equal #p"/foo/bar/baz" #p"\\foo\\bar\\baz") t) #+windows (deftest windows.2 (let ((pathname #p"foo.bar")) (check-windows-pathname pathname nil nil nil "foo" "bar")) t) #+windows (deftest windows.3 (let ((pathname #p"\\foo.bar")) (check-windows-pathname pathname nil nil '(:absolute) "foo" "bar")) t) #+windows (deftest windows.4 (let ((pathname #p"c:\\foo.bar")) #+(or abcl allegro) (check-windows-pathname pathname nil "c" '(:absolute) "foo" "bar") #+clisp (check-windows-pathname pathname nil "C" '(:absolute) "foo" "bar") #+lispworks (check-windows-pathname pathname "c" nil '(:absolute) "foo" "bar")) t) #+windows (deftest windows.5 (equal #p"c:\\foo.bar" #p"C:\\FOO.BAR") t) #+windows (deftest pathname.windows.6 (equal (pathname-device #p"z:/foo/bar") "z") t) #+windows (deftest pathname.windows.7 (equal (pathname-device #p"file:z:/foo/bar") "z") t) #+windows (deftest pathname.windows.8 (equal (pathname-device #p"zoo:/foo/bar") nil) t) (deftest wild.1 (check-physical-pathname #p"foo.*" nil "foo" :wild) t) (deftest wild.2 (check-physical-pathname #p"*.*" nil :wild :wild) t) (deftest wild.3 #-(or cmu sbcl) (check-physical-pathname #p"abc*" nil "abc*" nil) #+(or cmu sbcl) (wild-pathname-p #p"abc*") t) (deftest wild.4 #-(or cmu sbcl) (check-physical-pathname #p"abc?" nil "abc?" nil) #+(or cmu sbcl) (wild-pathname-p #p"abc?") t) (deftest wild.5 #-(or cmu sbcl) (check-physical-pathname #p"abc[d-h]" nil "abc[d-h]" nil) #+(or cmu sbcl) (wild-pathname-p #p"abc[d-h]") t) ;; Lots of dots. #+(or allegro abcl cmu) (deftest lots-of-dots.1 (check-physical-pathname #p"..." nil "..." nil) t) #+cmu (pushnew 'lots-of-dots.1 *expected-failures*) #+(or allegro abcl cmu) (deftest lots-of-dots.2 (check-physical-pathname #p"......" nil "......" nil) t) #+cmu (pushnew 'lots-of-dots.2 *expected-failures*) ;; Silly names. #-(or allegro sbcl) (deftest silly.1 #+(or abcl clisp) (signals-error (make-pathname :name "abc/def") 'error) #-(or abcl clisp) (check-readable (make-pathname :name "abc/def")) t) #+(or cmu lispworks) (pushnew 'silly.1 *expected-failures*) (deftest silly.2 (signals-error (make-pathname :name "abc/def") #-cmu 'error #+cmu 'warning) t) (deftest silly.3 (check-readable-or-signals-error (make-pathname :name ".foo")) t) (deftest silly.4 (check-readable-or-signals-error (make-pathname :type ".foo")) t) (deftest silly.5 (check-readable-or-signals-error (make-pathname :name "abc.def")) t) (deftest silly.6 (check-readable-or-signals-error (make-pathname :type "abc.def")) t) ;; LOGICAL-PATHNAME-TRANSLATIONS #-allegro (deftest logical-pathname-translations.1 #+(or sbcl cmu lispworks) (equal (logical-pathname-translations "effluvia") '(("**;*.*.*" "/usr/local/**/*.*"))) #+clisp (equal (logical-pathname-translations "effluvia") '((#p"EFFLUVIA:**;*.*.*" "/usr/local/**/*.*"))) #+abcl (equal (logical-pathname-translations "effluvia") '((#p"EFFLUVIA:**;*.*.*" #p"/usr/local/**/*.*"))) t) ;; "The null string, "", is not a valid value for any component of a logical ;; pathname." 19.3.2.2 (deftest logical-pathname.1 #-clisp (signals-error (logical-pathname ":") 'error) #+clisp (check-logical-pathname (logical-pathname ":") "" '(:absolute) nil nil nil) t) ;; Parse error. (deftest logical-pathname.2 (signals-error (logical-pathname "effluvia::foo.bar") #-(or allegro clisp) 'parse-error #+(or allegro clisp) 'type-error) t) ;; If the prefix isn't a defined logical host, it's not a logical pathname. #-(or cmu (and clisp windows)) ;; CMUCL parses this as (:ABSOLUTE #) "bar.baz" "42". ;; CLISP signals a parse error reading #p"foo:bar.baz.42". (deftest logical.1 (let ((pathname #p"foo:bar.baz.42")) #+allegro ;; Except in Allegro. (check-logical-pathname pathname "foo" nil "bar" "baz" nil) #-allegro (check-physical-pathname pathname nil "foo:bar.baz" "42")) t) #+lispworks (pushnew 'logical.1 *expected-failures*) #+sbcl (deftest logical.2 ;; Even though "effluvia" is defined as a logical host, "bop" is not a valid ;; logical pathname version, so this can't be a logical pathname. (check-physical-pathname #p"effluvia:bar.baz.bop" nil "effluvia:bar.baz" "bop") t) (deftest logical.3 #-allegro (check-logical-pathname (make-pathname :defaults "effluvia:foo.lisp") "EFFLUVIA" '(:absolute) "FOO" "LISP" nil) #+allegro (check-logical-pathname (make-pathname :defaults "effluvia:foo.lisp") "effluvia" nil "foo" "lisp" nil) t) #-allegro (deftest logical.4 (check-logical-pathname #p"effluvia:bar.baz.42" "EFFLUVIA" '(:absolute) "BAR" "BAZ" 42) t) #-allegro (deftest logical.5 (string= (write-to-string #p"effluvia:bar.baz.42" :escape t) "#P\"EFFLUVIA:BAR.BAZ.42\"") t) #+allegro ;; Allegro returns NIL for the device and directory and drops the version ;; entirely (even from the namestring). (deftest logical.6 (check-logical-pathname #p"effluvia:bar.baz.42" "effluvia" nil "bar" "baz" nil) t) #+allegro (deftest logical.7 (string= (write-to-string #p"effluvia:bar.baz" :escape t) #+allegro-v6.2 "#p\"effluvia:bar.baz\"" #+allegro-v7.0 "#P\"effluvia:bar.baz\"") t) (deftest logical.8 (typep (parse-namestring "**;*.*.*" "effluvia") 'logical-pathname) t) (deftest logical.9 (check-namestring (parse-namestring "**;*.*.*" "effluvia") #-(or allegro lispworks) "EFFLUVIA:**;*.*.*" #+allegro ;; Allegro preserves case and drops the version component. "effluvia:**;*.*" #+lispworks "effluvia:**;*.*.*") t) #-allegro ;; The version can be a bignum. (deftest logical.10 (check-logical-pathname #p"effluvia:bar.baz.2147483648" "EFFLUVIA" '(:absolute) "BAR" "BAZ" 2147483648) t) #-allegro (deftest logical.11 (check-namestring #p"effluvia:bar.baz.2147483648" "EFFLUVIA:BAR.BAZ.2147483648") t) #+sbcl ;; SBCL has a bug when the version is a bignum. (pushnew 'logical.11 *expected-failures*) (deftest logical.12 (check-namestring #p"effluvia:foo.bar.newest" #-allegro "EFFLUVIA:FOO.BAR.NEWEST" #+allegro "effluvia:foo.bar") t) (deftest logical.13 #-allegro (check-logical-pathname #p"effluvia:foo.*" "EFFLUVIA" '(:absolute) "FOO" :wild nil) #+allegro (check-logical-pathname #p"effluvia:foo.*" "effluvia" nil "foo" :wild nil) t) (deftest logical.14 #-allegro (check-logical-pathname #p"effluvia:*.lisp" "EFFLUVIA" '(:absolute) :wild "LISP" nil) #+allegro (check-logical-pathname #p"effluvia:*.lisp" "effluvia" nil :wild "lisp" nil) t) (deftest logical.15 #-allegro (check-logical-pathname #p"effluvia:bar.baz.newest" "EFFLUVIA" '(:absolute) "BAR" "BAZ" :newest) #+allegro (check-logical-pathname #p"effluvia:bar.baz.newest" "effluvia" nil "bar" "baz" nil) t) (deftest logical.16 #-allegro (check-logical-pathname #p"EFFLUVIA:BAR.BAZ.NEWEST" "EFFLUVIA" '(:absolute) "BAR" "BAZ" :newest) #+allegro (check-logical-pathname #p"EFFLUVIA:BAR.BAZ.NEWEST" "EFFLUVIA" nil "BAR" "BAZ" nil) t) ;; The directory component. (deftest logical.17 (check-logical-pathname #p"effluvia:foo;bar.baz" "EFFLUVIA" '(:absolute "FOO") "BAR" "BAZ" nil) t) (deftest logical.18 (check-namestring #p"effluvia:foo;bar.baz" #-allegro "EFFLUVIA:FOO;BAR.BAZ" #+allegro "effluvia:foo;bar.baz") t) (deftest logical.19 #-allegro (check-logical-pathname #p"effluvia:;bar.baz" "EFFLUVIA" '(:relative) "BAR" "BAZ" nil) #+allegro ;; Allegro drops the directory component and removes the semicolon from the ;; namestring. (check-logical-pathname #p"effluvia:;bar.baz" "EFFLUVIA" nil "BAR" "BAZ" nil) t) (deftest logical.20 (check-namestring #p"effluvia:;bar.baz" #+allegro "effluvia:bar.baz" #-allegro "EFFLUVIA:;BAR.BAZ") t) ;; "If a relative-directory-marker precedes the directories, the directory ;; component parsed is as relative; otherwise, the directory component is ;; parsed as absolute." (deftest logical.21 (equal (pathname-directory #p"effluvia:foo.baz") #-allegro '(:absolute) #+allegro nil) t) (deftest logical.22 (typep #p"effluvia:" 'logical-pathname) t) (deftest logical.23 (equal (pathname-directory #p"effluvia:") #-allegro '(:absolute) #+allegro nil) t) ;; PARSE-NAMESTRING (deftest parse-namestring.1 #-allegro (check-logical-pathname (parse-namestring "effluvia:foo.bar") "EFFLUVIA" '(:absolute) "FOO" "BAR" nil) #+allegro (check-logical-pathname (parse-namestring "effluvia:foo.bar") "effluvia" nil "foo" "bar" nil) t) (deftest parse-namestring.2 (let ((pathname (parse-namestring "foo.bar" "effluvia"))) #-(or allegro lispworks) (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" "BAR" nil) #+allegro (check-logical-pathname pathname "effluvia" nil "foo" "bar" nil) #+lispworks (check-logical-pathname pathname "effluvia" '(:absolute) "FOO" "BAR" nil)) t) (deftest parse-namestring.3 (let ((pathname (parse-namestring "foo;bar;baz.fas.3" "effluvia"))) #-(or allegro lispworks) (check-logical-pathname pathname "EFFLUVIA" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3) #+allegro (check-logical-pathname pathname "effluvia" '(:absolute "foo" "bar") "baz" "fas" nil) #+lispworks (check-logical-pathname pathname "effluvia" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3) ) t) (deftest parse-namestring.4 #-(or abcl clisp cmu lispworks (and allegro windows)) (check-physical-pathname (parse-namestring "effluvia:foo.bar" "") nil "effluvia:foo" "bar") #+abcl ;; Invalid logical host name: "" (signals-error (parse-namestring "effluvia:foo.bar" "") 'error) #+(or clisp lispworks) ;; Host mismatch. (signals-error (parse-namestring "effluvia:foo.bar" "") 'error) #+cmu (signals-error (parse-namestring "effluvia:foo.bar" "") 'error) #+(and allegro windows) ;; "effluvia" is the device (check-physical-pathname (parse-namestring "effluvia:foo.bar" "") nil "foo" "bar") t) ;; "If host is nil and thing is a syntactically valid logical pathname ;; namestring containing an explicit host, then it is parsed as a logical ;; pathname namestring." (deftest parse-namestring.5 #-allegro (check-logical-pathname (parse-namestring "effluvia:foo.bar" nil) "EFFLUVIA" '(:absolute) "FOO" "BAR" nil) #+allegro (check-logical-pathname (parse-namestring "effluvia:foo.bar" nil) "effluvia" nil "foo" "bar" nil) t) ;; "If host is nil, default-pathname is a logical pathname, and thing is a ;; syntactically valid logical pathname namestring without an explicit host, ;; then it is parsed as a logical pathname namestring on the host that is the ;; host component of default-pathname." (deftest parse-namestring.6 #-allegro (check-logical-pathname (parse-namestring "foo" nil #p"effluvia:bar") "EFFLUVIA" '(:absolute) "FOO" nil nil) #+allegro (check-logical-pathname (parse-namestring "foo" nil #p"effluvia:bar") "effluvia" nil "foo" nil nil) t) (deftest parse-namestring.7 (let* ((*default-pathname-defaults* (logical-pathname "EFFLUVIA:")) (pathname (parse-namestring "foo.bar"))) #-allegro (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" "BAR" nil) #+allegro (check-logical-pathname pathname "effluvia" nil "foo" "bar" nil)) t) (deftest parse-namestring.8 (let* ((*default-pathname-defaults* #p"effluvia:bar") (pathname (parse-namestring "foo" nil))) #-allegro (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" nil nil) #+allegro (check-logical-pathname pathname "effluvia" nil "foo" nil nil)) t) ;; WILD-PATHNAME-P (deftest wild-pathname-p.1 (wild-pathname-p #p"effluvia:;*.baz") #+(or cmu sbcl) (:wild :wild-inferiors) #-(or cmu sbcl) t) ;; PATHNAME-MATCH-P (deftest pathname-match-p.1 (pathname-match-p "/foo/bar/baz" "/*/*/baz") t) (deftest pathname-match-p.2 (pathname-match-p "/foo/bar/baz" "/**/baz") t) (deftest pathname-match-p.3 (pathname-match-p "/foo/bar/quux/baz" "/**/baz") t) (deftest pathname-match-p.4 (pathname-match-p "foo.bar" "/**/*.*") t) (deftest pathname-match-p.5 (pathname-match-p "/usr/local/bin/foo.bar" "/**/foo.bar") t) (deftest pathname-match-p.6 (pathname-match-p "/usr/local/bin/foo.bar" "**/foo.bar") nil) (deftest pathname-match-p.7 (pathname-match-p "/foo/bar.txt" "/**/*.*") t) (deftest pathname-match-p.8 (pathname-match-p "/foo/bar.txt" "**/*.*") nil) (deftest pathname-match-p.9 (pathname-match-p #p"effluvia:foo.bar" #p"effluvia:**;*.*.*") t) (deftest pathname-match-p.10 (pathname-match-p "foo" "foo.*") t) ;; TRANSLATE-PATHNAME (deftest translate-pathname.1 #-clisp (equal (translate-pathname "foo" "*" "bar") #p"bar") #+clisp (signals-error (translate-pathname "foo" "*" "bar") 'error) t) (deftest translate-pathname.2 (equal (translate-pathname "foo" "*" "*") #p"foo") t) (deftest translate-pathname.3 #-abcl (string= (pathname-name (translate-pathname "foobar" "*" "foo*")) #-allegro-v7.0 "foofoobar" #+allegro-v7.0 "foo*") #+abcl ;; ABCL doesn't implement this translation. Verify that it signals an error. (signals-error (translate-pathname "foobar" "*" "foo*") 'error) t) (deftest translate-pathname.4 #-abcl (equal (translate-pathname "foobar" "foo*" "*baz") #-allegro-v7.0 #p"barbaz" #+allegro-v7.0 #p"*baz") #+abcl ;; ABCL doesn't implement this translation. Verify that it signals an error. (signals-error (translate-pathname "foobar" "foo*" "*baz") 'error) t) (deftest translate-pathname.5 (equal (translate-pathname "foobar" "foo*" "") #+(or allegro clisp) #p"bar" #+(or cmu sbcl lispworks abcl) #p"foobar") t) (deftest translate-pathname.6 (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz") t) (deftest translate-pathname.7 (equal (translate-pathname "bar/foo" "bar/*" "baz/*") #p"baz/foo") t) (deftest translate-pathname.8 (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz") t) (deftest translate-pathname.9 (string= (namestring (translate-pathname "test.txt" "*.txt" "*.text")) "test.text") t) (deftest translate-pathname.10 (equal (translate-pathname "foo" "foo.*" "bar") #p"bar") t) (deftest translate-pathname.11 (equal (translate-pathname "foo" "foo.*" "bar.*") #p"bar") t) (deftest translate-pathname.12 (string= (namestring (translate-pathname "foo.bar" "*.*" "/usr/local/*.*")) "/usr/local/foo.bar") t) (deftest translate-pathname.13 (equal (translate-pathname "foo.bar" "*.*" "/usr/local/*.*") #p"/usr/local/foo.bar") t) (deftest translate-pathname.14 (check-translate-pathname '("/foo/" "/*/" "/usr/local/*/") "/usr/local/foo/") t) (deftest translate-pathname.15 (check-translate-pathname '("/foo/baz/bar.txt" "/**/*.*" "/usr/local/**/*.*") "/usr/local/foo/baz/bar.txt") t) (deftest translate-pathname.16 (equal (translate-pathname "/foo/" "/*/" "/usr/local/*/bar/") #p"/usr/local/foo/bar/") t) (deftest translate-pathname.17 (equal (translate-pathname "/foo/bar.txt" "/*/*.*" "/usr/local/*/*.*") #P"/usr/local/foo/bar.txt") t) ;; "TRANSLATE-PATHNAME translates SOURCE (that matches FROM-WILDCARD)..." (deftest pathname-match-p.11 (pathname-match-p "/foo/bar.txt" "**/*.*") nil) ;; Since (pathname-match-p "/foo/bar.txt" "**/*.*" ) => NIL... (deftest translate-pathname.18 #+(or clisp allegro abcl cmu lispworks) ;; This seems to be the correct behavior. (signals-error (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*") 'error) #+sbcl ;; This appears to be a bug, since SOURCE doesn't match FROM-WILDCARD. (equal (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*") #p"/usr/local/foo/bar.txt") t) (deftest pathname-match-p.12 (pathname-match-p "/foo/bar.txt" "/**/*.*") t) (deftest translate-pathname.19 (equal (translate-pathname "/foo/bar.txt" "/**/*.*" "/usr/local/**/*.*") #p"/usr/local/foo/bar.txt") t) #-clisp (deftest translate-pathname.20 (equal (translate-pathname "foo.bar" "/**/*.*" "/usr/local/") #p"/usr/local/foo.bar") t) ;; TRANSLATE-LOGICAL-PATHNAME ;; "PATHNAME is first coerced to a pathname. If the coerced pathname is a ;; physical pathname, it is returned." (deftest translate-logical-pathname.1 (equal (translate-logical-pathname #p"/") #p"/") t) #+(or abcl clisp) (deftest translate-logical-pathname.2 (equal (translate-logical-pathname "effluvia:foo.bar") #p"/usr/local/foo.bar") t) #+(or sbcl cmu) (deftest translate-logical-pathname.3 ;; Device mismatch. (and (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar")) :unspecific) (eq (pathname-device #p"/usr/local/foo/bar") nil)) t) (deftest translate-logical-pathname.4 (check-namestring (translate-logical-pathname "effluvia:foo.bar") "/usr/local/foo.bar") t) (deftest translate-logical-pathname.5 (check-namestring (translate-logical-pathname "effluvia:foo;bar.txt") "/usr/local/foo/bar.txt") t) (deftest translate-logical-pathname.6 #-allegro (check-logical-pathname #p"effluvia:Foo.Bar" "EFFLUVIA" '(:absolute) "FOO" "BAR" nil) #+allegro ;; Allegro preserves case. (check-logical-pathname #p"effluvia:Foo.Bar" "effluvia" nil "Foo" "Bar" nil) t) ;; "TRANSLATE-PATHNAME [and thus also TRANSLATE-LOGICAL-PATHNAME] maps ;; customary case in SOURCE into customary case in the output pathname." (deftest translate-logical-pathname.7 #-allegro (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar") '(:absolute "usr" "local") "foo" "bar") #+allegro ;; Allegro preserves case. (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar") '(:absolute "usr" "local") "Foo" "Bar") t) (deftest merge-pathnames.1 #-allegro (check-logical-pathname (merge-pathnames "effluvia:foo.bar") "EFFLUVIA" '(:absolute) "FOO" "BAR" :newest) #+allegro ;; Allegro's MERGE-PATHNAMES apparently calls TRANSLATE-LOGICAL-PATHNAME. (check-physical-pathname (merge-pathnames "effluvia:foo.bar") '(:absolute "usr" "local") "foo" "bar") t) (deftest merge-pathnames.2 (equal (merge-pathnames (logical-pathname "effluvia:;foo;bar;") (logical-pathname "effluvia:baz;quux.lisp.3")) #-allegro (make-pathname :host "EFFLUVIA" :device :unspecific :directory '(:absolute "BAZ" "FOO" "BAR") :name "QUUX" :type "LISP" :version 3) #+allegro (make-pathname :host "effluvia" :device nil :directory '(:absolute "baz" "foo" "bar") :name "quux" :type "lisp" :version nil) ) t) (deftest compile-file-pathname.1 (equal (compile-file-pathname "effluvia:foo.lisp") #+abcl ;; Is this a bug? (Should version be :NEWEST?) #p"EFFLUVIA:FOO.ABCL" #+allegro #p"effluvia:foo.fasl" #+(or cmu sbcl) #p"EFFLUVIA:FOO.FASL.NEWEST" #+clisp ;; Is this a bug? ;; #p"EFFLUVIA:FOO.fas.NEWEST" (make-pathname :host "EFFLUVIA" :directory '(:absolute) :name "FOO" :type "fas" :version :newest) #+(and lispworks unix) #p"EFFLUVIA:FOO.UFSL.NEWEST" #+(and lispworks windows) #p"EFFLUVIA:FOO.FSL.NEWEST") t) (deftest file-namestring.1 (equal (file-namestring #p"") #+(or abcl allegro cmu) nil #+(or clisp lispworks sbcl) "") t) (deftest file-namestring.2 (equal (file-namestring #p"foo") "foo") t) (deftest file-namestring.3 (let ((pathname (make-pathname :type "foo"))) #+abcl (equal (file-namestring pathname) nil) #+allegro (equal (file-namestring pathname) "NIL.foo") ;; bug #+(or clisp lispworks) (equal (file-namestring pathname) ".foo") #+(or cmu sbcl) (signals-error (file-namestring pathname) 'error)) t) ;; A variant of FILE-NAMESTRING.3 that detects Allegro's bug as a bug. (deftest file-namestring.4 (let ((pathname (make-pathname :type "foo"))) #-(or cmu sbcl) (not (equal (file-namestring pathname) "NIL.foo")) #+(or cmu sbcl) (signals-error (file-namestring pathname) 'error)) t) #+allegro (pushnew 'file-namestring.4 *expected-failures*) (deftest enough-namestring.1 (equal (enough-namestring #p"/foo" #p"/") "foo") t) #+sbcl (pushnew 'enough-namestring.1 *expected-failures*) (deftest enough-namestring.2 #-windows (equal (enough-namestring #p"foo/bar" #p"foo") "foo/bar") #+windows (equal (enough-namestring #p"foo\\bar" #p"foo") "foo/bar") t) (deftest enough-namestring.3 (equal (enough-namestring #p"foo/bar" #p"foo/") "bar") t) #+sbcl (pushnew 'enough-namestring.3 *expected-failures*) ;; The following tests are adapted from SBCL's pathnames.impure.lisp. (setf (logical-pathname-translations "demo0") '(("**;*.*.*" "/tmp/"))) (deftest sbcl.1 (pathname-match-p "demo0:file.lisp" (logical-pathname "demo0:tmp;**;*.*.*")) nil) #-clisp (deftest sbcl.2 (check-namestring (translate-logical-pathname "demo0:file.lisp") "/tmp/file.lisp") t) (setf (logical-pathname-translations "demo1") '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*"))) ;; Remove "**" from the resulting pathname when the source directory is NIL. (deftest sbcl.3 (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) #-windows "/tmp/**/foo.lisp" #+windows "\\tmp\\**\\foo.lisp") nil) (deftest sbcl.4 (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp") t) ;;; Check for absolute/relative path confusion. #-allegro (deftest sbcl.5 (pathname-match-p "demo1:;foo.lisp" "demo1:**;*.*.*") nil) #+(or sbcl cmu) ;; BUG Pathnames should match if the following translation is to work. (deftest sbcl.6 (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*") t) #+clisp (deftest sbcl.7 (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*") t) (deftest sbcl.8 (check-namestring (translate-logical-pathname "demo1:;foo.lisp") #+abcl "/tmp/rel/foo.lisp" #+allegro "/tmp/foo.lisp" #-(or allegro abcl) "/tmp/rel/foo.lisp") t) (setf (logical-pathname-translations "demo2") '(("test;**;*.*" "/tmp/demo2/test"))) (deftest sbcl.9 (equal (enough-namestring "demo2:test;foo.lisp") #+sbcl "DEMO2:;TEST;FOO.LISP" #+(or abcl cmu lispworks) "DEMO2:TEST;FOO.LISP" #+allegro-v7.0 "demo2:test;foo.lisp" #+allegro-v6.2 "/test/foo.lisp" ;; BUG #+(and clisp unix) "TEST;FOO.LISP" #+(and clisp windows) "DEMO2:TEST;FOO.LISP") t) #-(or allegro clisp cmu) (deftest sbcl.10 (signals-error (make-pathname :host "EFFLUVIA" :directory "!bla" :name "bar") 'error) t) #-(or allegro cmu) (deftest sbcl.11 (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "!bar") 'error) t) #-(or allegro cmu) (deftest sbcl.12 (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "bar" :type "&baz") 'error) t) (deftest sbcl.13 (equal (namestring (parse-namestring "" "EFFLUVIA")) "EFFLUVIA:") t) (deftest sbcl.14 #-cmu (equal (namestring (parse-namestring "" :unspecific)) "") #+cmu ;; It seems reasonable to signal an error here, since the HOST argument to ;; PARSE-NAMESTRING is specified to be "a valid pathname host, a logical host, ;; or NIL". (signals-error (parse-namestring "" :unspecific) 'type-error) t) (deftest sbcl.15 (equal (namestring (parse-namestring "" (pathname-host (translate-logical-pathname "EFFLUVIA:")))) "") t) ;; PARSE-NAMESTRING host mismatch: "If HOST is supplied and not NIL, and THING ;; contains a manifest host name, an error of type ERROR is signaled if the ;; hosts do not match." (deftest sbcl.16 (signals-error (parse-namestring "effluvia:foo.bar" "demo2") 'error) t) (setf (logical-pathname-translations "bazooka") '(("todemo;*.*.*" "demo0:*.*.*"))) (deftest sbcl.17 #+allegro ;; BUG (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/todemo/x.y") #+clisp ;; BUG (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error) #-(or allegro clisp) (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/x.y") t) (deftest sbcl.18 #+clisp ;; BUG (signals-error (translate-logical-pathname "demo0:x.y") 'error) #-clisp (equal (namestring (translate-logical-pathname "demo0:x.y")) ;;#-windows "/tmp/x.y" ;;#+windows "\\tmp\\x.y" ) t) #-(or allegro clisp) (deftest sbcl.19 (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y")) (namestring (translate-logical-pathname "demo0:x.y"))) t) ;; "If HOST is incorrectly supplied, an error of type TYPE-ERROR is signaled." (deftest sbcl.20 (signals-error (logical-pathname-translations "unregistered-host") #+(or clisp lispworks) 'error ;; BUG #+cmu 'file-error ;; BUG #-(or clisp lispworks cmu) 'type-error) t) (deftest sbcl.21 (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST") nil) #+(or lispworks (and clisp windows)) (pushnew 'sbcl.21 *expected-failures*) (deftest sbcl.22 (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN") t) #+(and clisp windows) (pushnew 'sbcl.22 *expected-failures*) (setf (logical-pathname-translations "test0") '(("**;*.*.*" "/library/foo/**/"))) (deftest sbcl.23 (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux") "/library/foo/foo/bar/baz/mum.quux") t) (setf (logical-pathname-translations "prog") '(("CODE;*.*.*" "/lib/prog/"))) #-allegro (deftest sbcl.24 (check-namestring (translate-logical-pathname "prog:code;documentation.lisp") "/lib/prog/documentation.lisp") t) (setf (logical-pathname-translations "prog1") '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") ("CODE;*.*.*" "/lib/prog/"))) #-allegro (deftest sbcl.25 (check-namestring (translate-logical-pathname "prog1:code;documentation.lisp") "/lib/prog/docum.lisp") t) ;; "ANSI section 19.3.1.1.5 specifies that translation to a filesystem which ;; doesn't have versions should ignore the version slot. CMU CL didn't ignore ;; this as it should, but we [i.e. SBCL] do." ;; "Some file systems do not have versions. Logical pathname translation to ;; such a file system ignores the version." 19.3.1.1.5 #-cmu ;; CMUCL supports emacs-style versions. (deftest sbcl.26 (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3") "/library/foo/foo/bar/baz/mum.quux") t) #+lispworks (pushnew 'sbcl.26 *expected-failures*) (setf (logical-pathname-translations "scratch") '(("**;*.*.*" "/usr/local/doc/**/*"))) ;; Trivial merge. (deftest sbcl.27 (check-merge-pathnames #p"foo" #p"/usr/local/doc/" #p"/usr/local/doc/foo") t) ;; If pathname does not specify a host, device, directory, name, or type, each ;; such component is copied from default-pathname. ;; 1) no name, no type (deftest sbcl.28 (check-merge-pathnames #p"/supplied-dir/" #p"/dir/name.type" #p"/supplied-dir/name.type") t) ;; 2) no directory, no type (deftest sbcl.29 (check-merge-pathnames #p"supplied-name" #p"/dir/name.type" #p"/dir/supplied-name.type") t) ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed ;; as a name) (deftest sbcl.30 (check-merge-pathnames (make-pathname :type "supplied-type") #p"/dir/name.type" #p"/dir/name.supplied-type") t) ;; If (pathname-directory pathname) is a list whose car is ;; :relative, and (pathname-directory default-pathname) is a ;; list, then the merged directory is [...] (deftest sbcl.31 (check-merge-pathnames #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee" #p"/aaa/bbb/ccc/ddd/qqq/www") t) ;; except that if the resulting list contains a string or ;; :wild immediately followed by :back, both of them are ;; removed. (deftest sbcl.32 (check-merge-pathnames ;; "../" in a namestring is parsed as :up not :back, so MAKE-PATHNAME. (make-pathname :directory '(:relative :back "blah")) #p"/aaa/bbb/ccc/ddd/eee" #P"/aaa/bbb/ccc/blah/eee") t) ;; If (pathname-directory default-pathname) is not a list or ;; (pathname-directory pathname) is not a list whose car is ;; :relative, the merged directory is (or (pathname-directory ;; pathname) (pathname-directory default-pathname)) (deftest sbcl.33 (check-merge-pathnames #p"/absolute/path/name" #p"/dir/default-name.type" #P"/absolute/path/name.type") t) (deftest sbcl.34 (check-merge-pathnames #p"scratch:;name2" #p"scratch:foo;" #p"SCRATCH:FOO;NAME2") t) (deftest sbcl.35 (check-merge-pathnames #p"scratch:;foo" #p"/usr/local/doc/" #-(or allegro clisp lispworks) #P"SCRATCH:USR;LOCAL;DOC;FOO" #+(and allegro unix) #p"/usr/local/doc/foo" #+(and allegro windows) #p"scratch:usr;local;doc;foo" #+clisp #p"SCRATCH:;FOO" #+lispworks #p"SCRATCH:FOO") t) (deftest sbcl.36 (check-merge-pathnames #p"scratch:supplied-dir;" #p"/dir/name.type" #-clisp #p"SCRATCH:SUPPLIED-DIR;NAME.TYPE" #+clisp ;; #p"SCRATCH:SUPPLIED-DIR;name.type.NEWEST" (make-pathname :host "SCRATCH" :directory '(:absolute "SUPPLIED-DIR") :name "name" :type "type")) t) (deftest sbcl.37 (check-merge-pathnames #p"scratch:;supplied-name" #p"/dir/name.type" #-(or allegro clisp lispworks) #p"SCRATCH:DIR;SUPPLIED-NAME.TYPE" #+(and allegro unix) #p"/usr/local/doc/supplied-name.type" #+(and allegro windows) #P"scratch:dir;supplied-name.type" #+clisp ;; #P"SCRATCH:;SUPPLIED-NAME.type.NEWEST" (make-pathname :host "SCRATCH" :directory '(:relative) :name "SUPPLIED-NAME" :type "type") #+lispworks ;; #P"SCRATCH:SUPPLIED-NAME.TYPE.NEWEST" (make-pathname :host "SCRATCH" :directory '(:absolute) :name "SUPPLIED-NAME" :type "TYPE")) t) (deftest sbcl.38 (check-merge-pathnames (make-pathname :host "scratch" :type "supplied-type") #p"/dir/name.type" #-(or allegro clisp lispworks) #p"SCRATCH:DIR;NAME.SUPPLIED-TYPE" #+(and allegro unix) #p"/usr/local/doc/name.supplied-type" #+(and allegro windows) #P"scratch:dir;name.supplied-type" #+clisp ;; #P"SCRATCH:dir;name.supplied-type.NEWEST" (make-pathname :host "SCRATCH" :directory '(:absolute "dir") :name "name" :type "supplied-type") #+lispworks ;; #P"SCRATCH:NAME.SUPPLIED-TYPE.NEWEST" (make-pathname :host "SCRATCH" :directory '(:absolute) :name "NAME" :type "SUPPLIED-TYPE")) t) (deftest sbcl.39 (let ((pathname (make-pathname :host "scratch" :directory '(:relative "foo") :name "bar")) (default-pathname #p"/aaa/bbb/ccc/ddd/eee")) #-allegro (check-merge-pathnames pathname default-pathname #-(or clisp lispworks) #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" #+clisp ;; #P"SCRATCH:;foo;bar" (make-pathname :host "SCRATCH" :directory '(:relative "foo") :name "bar") #+lispworks #p"SCRATCH:FOO;BAR") #+(and allegro unix) (signals-error (merge-pathnames pathname default-pathname) 'error) #+(and allegro windows) (check-merge-pathnames pathname default-pathname #P"scratch:aaa;bbb;ccc;ddd;foo;bar")) t) #-lispworks (deftest sbcl.40 (let ((pathname (make-pathname :host "scratch" :directory '(:relative :back "foo") :name "bar")) (default-pathname #p"/aaa/bbb/ccc/ddd/eee")) #-allegro (check-merge-pathnames pathname default-pathname #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR" #+clisp ;; #P"SCRATCH:;..;foo;bar.NEWEST" (make-pathname :host "SCRATCH" :directory '(:relative :back "foo") :name "bar")) #+(and allegro unix) (signals-error (merge-pathnames pathname default-pathname) 'error) #+(and allegro windows) (check-merge-pathnames pathname default-pathname #P"scratch:aaa;bbb;ccc;foo;bar")) t) #+lispworks ;; "Illegal logical pathname directory component: :BACK." (deftest sbcl.40 (signals-error (make-pathname :host "scratch" :directory '(:relative :back "foo") :name "bar") 'error) t) (deftest sbcl.41 (check-merge-pathnames #p"scratch:absolute;path;name" #p"/dir/default-name.type" #-clisp #p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" #+clisp ;; #P"SCRATCH:ABSOLUTE;PATH;NAME.type.NEWEST" (make-pathname :host "SCRATCH" :directory '(:absolute "ABSOLUTE" "PATH") :name "NAME" :type "type")) t) (deftest sbcl.42 (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo") t) #+lispworks (pushnew 'sbcl.42 *expected-failures*) (deftest sbcl.43 (string= (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) "SCRATCH:FOO") t) #-(or allegro clisp cmu lispworks) (deftest sbcl.44 ;; "The null string, "", is not a valid value for any component of a logical ;; pathname." 19.3.2.2 (signals-error (setf (logical-pathname-translations "") (list '("**;*.*.*" "/**/*.*"))) 'error) t) #-clisp (deftest sbcl.45 (check-namestring (translate-logical-pathname "/") "/") t) (deftest sbcl.46 (signals-error (pathname (make-string-input-stream "FOO")) #-(or allegro-v6.2 cmu) 'type-error #+allegro-v6.2 'stream-error #+cmu 'error) t) (deftest sbcl.47 (signals-error (merge-pathnames (make-string-output-stream)) #-allegro-v6.2 'type-error #+allegro-v6.2 'stream-error) t) (deftest sbcl.48 (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version :newest)) t) #+lispworks (pushnew 'sbcl.48 *expected-failures*) #-allegro (deftest sbcl.49 (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version 1)) t) #+lispworks (pushnew 'sbcl.49 *expected-failures*) (deftest sbcl.50 #-clisp (check-readable-or-signals-error (make-pathname :name "foo" :type ".txt")) #+clisp (signals-error (make-pathname :name "foo" :type ".txt") 'error) t) #+(or allegro cmu lispworks) (pushnew 'sbcl.50 *expected-failures*) (deftest sbcl.51 (check-readable-or-signals-error (make-pathname :name "foo." :type "txt")) t) (deftest sbcl.52 (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.1")) t) (deftest sbcl.53 (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.NEWEST")) t) (deftest sbcl.54 (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT")) t) (deftest sbcl.55 (equal (parse-namestring "foo" nil "/") (parse-namestring "foo" nil #p"/")) t) #-allegro (deftest sbcl.56 (let ((test "parse-namestring-test.tmp")) (unwind-protect (with-open-file (f test :direction :output) ;; FIXME: This test is a bit flaky, since we only check that ;; no error is signalled. The dilemma here is "what is the ;; correct result when defaults is a _file_, not a ;; directory". Currently (0.8.10.73) we get #P"foo" here (as ;; opposed to eg. #P"/path/to/current/foo"), which is ;; possibly mildly surprising but probably conformant. (equal (parse-namestring "foo" nil f) #p"foo")) (when (probe-file test) (delete-file test)))) t) ;;; ENOUGH-NAMESTRING should probably not fail when the namestring in ;;; question has a :RELATIVE pathname. (deftest sbcl.57 (equal (enough-namestring #p"foo" #p"./") "foo") t) ;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing ;;; directory lists. (deftest sbcl.58 (check-namestring #p"/tmp/*/" "/tmp/*/") t) #-allegro (deftest sbcl.59 (string= (with-standard-io-syntax (write-to-string #p"/foo")) ;;#-windows "#P\"/foo\"" ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" ;;#+(and windows lispworks) "#P\"/foo\"") t) #-allegro (deftest sbcl.60 (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil)) ;;#-windows "#P\"/foo\"" ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" ;;#+(and windows lispworks) "#P\"/foo\"" ) t) #-allegro (deftest sbcl.61 (string= (with-standard-io-syntax (write-to-string #p"/foo" :escape nil)) ;;#-windows "#P\"/foo\"" ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" ;;#+(and windows lispworks) "#P\"/foo\"" ) t) (deftest sbcl.62 (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil :escape nil)) ;;#-windows "/foo" ;;#+windows "\\foo" ) t) (deftest make-pathname.1 (handler-case (make-pathname :directory #p"/tmp/") (type-error () t)) t) (deftest pathname.uri-encoding.1 (signals-error (let ((s "file:/path with /spaces")) (equal s (namestring (pathname s)))) 'error) t) (deftest pathname.uri-encoding.2 (string-equal "/path with/uri-escaped/?characters/" (namestring (pathname "file:/path%20with/uri-escaped/%3fcharacters/"))) t) (deftest pathname.load.1 (let ((dir (merge-pathnames "dir+with+plus/" *abcl-test-directory*))) (with-temp-directory (dir) (let ((file (merge-pathnames "foo.lisp" dir))) (with-open-file (s file :direction :output) (write *foo.lisp* :stream s)) (load file)))) t) (deftest pathname.load.2 (let ((dir (merge-pathnames "dir with space/" *abcl-test-directory*))) (with-temp-directory (dir) (let ((file (merge-pathnames "foo.lisp" dir))) (with-open-file (s file :direction :output) (write *foo.lisp* :stream s)) (load file)))) t) (deftest pathname.make-pathname.1 (make-pathname :directory nil :defaults "/home/fare/") #p"") (deftest pathname.make-pathname.2 (let ((p (make-pathname :defaults (make-pathname :name :wild :type :wild :version :wild :directory :wild)))) (values (pathname-name p) (pathname-type p) (pathname-version p) (pathname-directory p))) :wild :wild :wild (:absolute :wild))