Changeset 10008


Ignore:
Timestamp:
09/23/05 12:53:02 (16 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/tests/pathname-tests.lisp

    r10003 r10008  
    33;;; This software is in the public domain and is provided with absolutely no
    44;;; warranty.
     5
     6(defvar *ansi-tests-translations*
     7  ;; Your path may vary!
     8  '(("*.*.*" #-windows "/home/peter/gcl/ansi-tests/*.*"
     9             #+windows "c:/cygwin/home/peter/gcl/ansi-tests/*.*")))
     10
     11(unless (member "RT" *modules* :test #'string=)
     12  (setf (logical-pathname-translations "ansi-tests") *ansi-tests-translations*)
     13  (load "ansi-tests:rt-package.lsp")
     14  (load #+abcl (compile-file-if-needed "ansi-tests:rt.lsp")
     15        ;; Force compilation to avoid fasl name conflict between SBCL and
     16        ;; Allegro.
     17        #-abcl (compile-file "ansi-tests:rt.lsp"))
     18  (let ((*package* (find-package '#:rt)))
     19    (export (find-symbol (string '#:*expected-failures*))))
     20  (provide "RT"))
     21
     22(rt:rem-all-tests)
     23(setf rt:*expected-failures* nil)
     24
     25(defpackage #:pathname-tests (:use #:cl #:regression-test))
     26
     27(in-package #:pathname-tests)
    528
    629(defmacro expect (test-form)
     
    1740  (let* ((directory (pathname-directory pathname))
    1841         (name (pathname-name pathname))
    19          (type (pathname-type pathname)))
     42         (type (pathname-type pathname))
     43         (ok t))
    2044    (unless (and (pathnamep pathname)
    2145                 (not (typep pathname 'logical-pathname)))
    22       (format t "~S => ~S; expected ~S~%" pathname (type-of pathname) 'pathname))
     46      (format t "~&~S => ~S; expected ~S~%" pathname (type-of pathname) 'pathname)
     47      (setf ok nil))
    2348    (unless (and (equal directory expected-directory)
    2449                 (equal name      expected-name)
    2550                 (equal type      expected-type))
    26       (format t "~S => ~S ~S ~S; expected ~S ~S ~S~%"
    27               pathname directory name type expected-directory expected-name expected-type))))
     51      (format t "~&~S => ~S ~S ~S; expected ~S ~S ~S~%"
     52              pathname directory name type expected-directory expected-name expected-type)
     53      (setf ok nil))
     54    ok))
    2855
    2956(defun check-logical-pathname (pathname expected-host expected-directory
     
    3865         ;; components to upper case.
    3966         (test #-allegro 'equal
    40                #+allegro 'equalp))
     67               #+allegro 'equalp)
     68         (ok t))
    4169    (unless (typep pathname 'logical-pathname)
    42       (format t "~S => ~S; expected ~S~%" pathname (type-of pathname) 'logical-pathname))
     70      (format t "~&~S => ~S; expected ~S~%" pathname (type-of pathname) 'logical-pathname)
     71      (setf ok nil))
    4372    ;; "The device component of a logical pathname is always :UNSPECIFIC..." 19.3.2.1
    4473    #-allegro ;; Except on Allegro, where it's NIL.
    4574    (unless (eq (pathname-device pathname) :unspecific)
    4675      (format t "~S => device is ~S, not ~S~%"
    47               pathname (pathname-device pathname) :unspecific))
     76              pathname (pathname-device pathname) :unspecific)
     77      (setf ok nil))
    4878    (unless (and (or (not (stringp host))
    4979                     (funcall test host expected-host))
     
    5282                 (funcall test type expected-type)
    5383                 (eql version expected-version))
    54       (format t "~S => ~S ~S ~S ~S ~S; expected ~S ~S ~S ~S ~S~%"
     84      (format t "~&~S => ~S ~S ~S ~S ~S; expected ~S ~S ~S ~S ~S~%"
    5585              pathname
    5686              host directory name type version
    5787              expected-host expected-directory expected-name expected-type
    58               expected-version))))
     88              expected-version)
     89      (setf ok nil))
     90    ok))
    5991
    6092(defun check-translate-pathname (args expected)
     
    70102
    71103(defmacro check-readable (pathname)
    72   `(expect (equal ,pathname (read-from-string (write-to-string ,pathname :readably t)))))
     104  `(equal ,pathname (read-from-string (write-to-string ,pathname :readably t))))
    73105
    74106(defmacro check-namestring (pathname namestring)
    75   `(expect (string= (namestring ,pathname)
    76                     #+windows (substitute #\\ #\/ ,namestring)
    77                     #-windows ,namestring)))
    78 
    79 (check-physical-pathname #p"/" '(:absolute) nil nil)
    80 (check-physical-pathname #p"/foo" '(:absolute) "foo" nil)
    81 (check-physical-pathname #p"/foo." '(:absolute) "foo" "")
    82 (check-physical-pathname #p"/foo.b" '(:absolute) "foo" "b")
    83 (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar" "")
    84 (check-physical-pathname #p"/foo.bar.baz" '(:absolute) "foo.bar" "baz")
    85 (check-physical-pathname #p"/foo/bar" '(:absolute "foo") "bar" nil)
    86 (check-physical-pathname #p"/foo..bar" '(:absolute) "foo." "bar")
    87 (check-physical-pathname #p"foo.bar" nil "foo" "bar")
    88 (check-physical-pathname #p"foo.bar.baz" nil "foo.bar" "baz")
    89 (check-physical-pathname #p"foo/" '(:relative "foo") nil nil)
    90 (check-physical-pathname #p"foo/bar" '(:relative "foo") "bar" nil)
    91 (check-physical-pathname #p"foo/bar/baz" '(:relative "foo" "bar") "baz" nil)
    92 (check-physical-pathname #p"foo/bar/" '(:relative "foo" "bar") nil nil)
    93 #+allegro
    94 ;; This reduction is wrong.
    95 (check-physical-pathname #p"foo/bar/.." '(:relative "foo") nil nil)
    96 #+allegro
    97 (check-physical-pathname #p"/foo/../" '(:absolute) nil nil)
    98 (check-physical-pathname #p".lisprc" nil ".lisprc" nil)
    99 (check-physical-pathname #p"x.lisprc" nil "x" "lisprc")
    100 
    101 #-allegro
    102 (check-physical-pathname (make-pathname :name ".") nil "." nil)
    103 #+allegro
    104 (check-physical-pathname (make-pathname :name ".") '(:relative) nil nil)
    105 
    106 (check-readable (make-pathname :name "."))
     107  `(string= (namestring ,pathname)
     108            #+windows (substitute #\\ #\/ ,namestring)
     109            #-windows ,namestring))
     110
     111(deftest physical.1
     112  (check-physical-pathname #p"/" '(:absolute) nil nil)
     113  t)
     114(deftest physical.2
     115  (check-physical-pathname #p"/foo" '(:absolute) "foo" nil)
     116  t)
     117(deftest physical.3
     118  (check-physical-pathname #p"/foo." '(:absolute) "foo" "")
     119  t)
     120(deftest physical.4
     121  (check-physical-pathname #p"/foo.b" '(:absolute) "foo" "b")
     122  t)
     123(deftest physical.5
     124  (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar" "")
     125  t)
     126(deftest physical.6
     127  (check-physical-pathname #p"/foo.bar.baz" '(:absolute) "foo.bar" "baz")
     128  t)
     129(deftest physical.7
     130  (check-physical-pathname #p"/foo/bar" '(:absolute "foo") "bar" nil)
     131  t)
     132(deftest physical.8
     133  (check-physical-pathname #p"/foo..bar" '(:absolute) "foo." "bar")
     134  t)
     135(deftest physical.9
     136  (check-physical-pathname #p"foo.bar" nil "foo" "bar")
     137  t)
     138(deftest physical.10
     139  (check-physical-pathname #p"foo.bar.baz" nil "foo.bar" "baz")
     140  t)
     141(deftest physical.11
     142  (check-physical-pathname #p"foo/" '(:relative "foo") nil nil)
     143  t)
     144(deftest physical.12
     145  (check-physical-pathname #p"foo/bar" '(:relative "foo") "bar" nil)
     146  t)
     147(deftest physical.13
     148  (check-physical-pathname #p"foo/bar/baz" '(:relative "foo" "bar") "baz" nil)
     149  t)
     150(deftest physical.14
     151  (check-physical-pathname #p"foo/bar/" '(:relative "foo" "bar") nil nil)
     152  t)
     153#+allegro
     154(deftest physical.15
     155  ;; This reduction is wrong.
     156  (check-physical-pathname #p"foo/bar/.." '(:relative "foo") nil nil)
     157  t)
     158#+allegro
     159(deftest physical.16
     160  (check-physical-pathname #p"/foo/../" '(:absolute) nil nil)
     161  t)
     162(deftest physical.17
     163  (check-physical-pathname #p".lisprc" nil ".lisprc" nil)
     164  t)
     165(deftest physical.18
     166  (check-physical-pathname #p"x.lisprc" nil "x" "lisprc")
     167  t)
     168
     169(deftest physical.19
     170  #-allegro
     171  (check-physical-pathname (make-pathname :name ".") nil "." nil)
     172  #+allegro
     173  (check-physical-pathname (make-pathname :name ".") '(:relative) nil nil)
     174  t)
     175
     176(deftest physical.20
     177  (check-readable (make-pathname :name "."))
     178  t)
    107179
    108180;; #p"."
    109 #+(or allegro abcl cmu)
    110 (check-physical-pathname #p"." '(:relative) nil nil)
    111 #+(or sbcl clisp)
    112 ;; No trailing separator character means it's a file.
    113 (check-physical-pathname #p"." nil "." nil)
     181(deftest physical.21
     182  #+(or allegro abcl cmu)
     183  (check-physical-pathname #p"." '(:relative) nil nil)
     184  #+(or sbcl clisp)
     185  ;; No trailing separator character means it's a file.
     186  (check-physical-pathname #p"." nil "." nil)
     187  t)
     188#+cmu
     189(pushnew 'physical.21 rt:*expected-failures*)
    114190
    115191;; #p"./"
    116192;; Trailing separator character means it's a directory.
    117 #+(or allegro abcl clisp cmu)
    118 (check-physical-pathname #p"./" '(:relative) nil nil)
    119 #+(or sbcl)
    120 ;; Is this more exact?
    121 (check-physical-pathname #p"./" '(:relative ".") nil nil)
    122 
    123 #-allegro
    124 (check-physical-pathname (make-pathname :name "..") nil ".." nil)
    125 #+allegro
    126 (check-physical-pathname (make-pathname :name "..") '(:relative :back) nil nil)
    127 
     193(deftest physical.22
     194  #+(or allegro abcl clisp cmu)
     195  (check-physical-pathname #p"./" '(:relative) nil nil)
     196  #+(or sbcl)
     197  ;; Is this more exact?
     198  (check-physical-pathname #p"./" '(:relative ".") nil nil)
     199  t)
     200#+cmu
     201(pushnew 'physical.22 rt:*expected-failures*)
     202
     203(deftest physical.23
     204  #-allegro
     205  (check-physical-pathname (make-pathname :name "..") nil ".." nil)
     206  #+allegro
     207  (check-physical-pathname (make-pathname :name "..") '(:relative :back) nil nil)
     208  t)
    128209
    129210;; #p".."
    130 #+(or allegro)
    131 (check-physical-pathname #p".." '(:relative :back) nil nil)
    132 #+(or abcl cmu)
    133 (check-physical-pathname #p".." '(:relative :up) nil nil)
    134 ;; Other implementations think it's a file.
    135 #+(or)
    136 ;; If it's a file, to a human its name would be "..". No implementation gets
    137 ;; this right.
    138 (check-physical-pathname #p".." nil ".." nil)
    139 #+(or sbcl clisp)
    140 ;; These implementations parse ".." as the name "." followed by another dot and
    141 ;; the type string "", which no human would do.
    142 (check-physical-pathname #p".." nil "." "")
     211(deftest physical.24
     212  #+(or allegro)
     213  (check-physical-pathname #p".." '(:relative :back) nil nil)
     214  #+(or abcl cmu)
     215  (check-physical-pathname #p".." '(:relative :up) nil nil)
     216  ;; Other implementations think it's a file.
     217  #+(or)
     218  ;; If it's a file, to a human its name would be "..". No implementation gets
     219  ;; this right.
     220  (check-physical-pathname #p".." nil ".." nil)
     221  #+(or sbcl clisp)
     222  ;; These implementations parse ".." as the name "." followed by another dot and
     223  ;; the type string "", which no human would do.
     224  (check-physical-pathname #p".." nil "." "")
     225  t)
     226#+cmu
     227(pushnew 'physical.24 rt:*expected-failures*)
    143228
    144229;; #p"../"
    145 #+allegro
    146 (check-physical-pathname #p"../" '(:relative :back) nil nil)
    147 #+(or abcl sbcl cmu clisp)
    148 (check-physical-pathname #p"../" '(:relative :up) nil nil)
    149 
     230(deftest physical.25
     231  #+allegro
     232  (check-physical-pathname #p"../" '(:relative :back) nil nil)
     233  #+(or abcl sbcl cmu clisp)
     234  (check-physical-pathname #p"../" '(:relative :up) nil nil)
     235  t)
     236
     237;; Lots of dots.
    150238#+(or allegro abcl cmu)
    151 (check-physical-pathname #p"..." nil "..." nil)
     239(deftest lots-of-dots.1
     240  (check-physical-pathname #p"..." nil "..." nil)
     241  t)
     242#+cmu
     243(pushnew 'lots-of-dots.1 rt:*expected-failures*)
    152244#+(or allegro abcl cmu)
    153 (check-physical-pathname #p"......" nil "......" nil)
    154 (check-physical-pathname #p"foo.*" nil "foo" :wild)
    155 
    156 #-(or sbcl allegro)
    157 (expect (string= (namestring (make-pathname :name "..")) ".."))
    158 #+allegro
    159 (expect (string= (namestring (make-pathname :name "..")) "../"))
    160 
    161 (expect (string= (namestring (make-pathname :directory '(:relative :up)))
    162                  #+windows "..\\"
    163                  #-windows "../"))
     245(deftest lots-of-dots.2
     246  (check-physical-pathname #p"......" nil "......" nil)
     247  t)
     248#+cmu
     249(pushnew 'lots-of-dots.2 rt:*expected-failures*)
     250
     251(deftest physical.26
     252  (check-physical-pathname #p"foo.*" nil "foo" :wild)
     253  t)
     254
     255#-sbcl
     256(deftest physical.27
     257  #-allegro
     258  (string= (namestring (make-pathname :name "..")) "..")
     259  #+allegro
     260  (string= (namestring (make-pathname :name "..")) "../")
     261  t)
     262
     263(deftest physical.28
     264  (string= (namestring (make-pathname :directory '(:relative :up)))
     265           #+windows "..\\"
     266           #-windows "../")
     267  t)
    164268
    165269;; Silly names.
    166 #+(or abcl clisp)
    167 (expect (signals-error (make-pathname :name "abc/def") 'error))
    168 #-(or abcl allegro clisp sbcl)
    169 (check-readable (make-pathname :name "abc/def"))
     270#-(or allegro sbcl)
     271(deftest silly.1
     272  #+(or abcl clisp)
     273  (signals-error (make-pathname :name "abc/def") 'error)
     274  #-(or abcl clisp)
     275  (check-readable (make-pathname :name "abc/def"))
     276  t)
     277#+cmu
     278(pushnew 'silly.1 rt:*expected-failures*)
    170279
    171280;; If the prefix isn't a defined logical host, it's not a logical pathname.
    172 #+allegro
    173 ;; Except in Allegro.
    174 (check-logical-pathname #p"foo:bar.baz.42" "foo" nil "bar" "baz" nil)
    175 #-(or allegro cmu)
     281#-cmu
    176282;; CMUCL parses this as (:ABSOLUTE #<SEARCH-LIST foo>) "bar.baz" "42".
    177 (check-physical-pathname #p"foo:bar.baz.42" nil "foo:bar.baz" "42")
     283(deftest logical.1
     284  #+allegro
     285  ;; Except in Allegro.
     286  (check-logical-pathname #p"foo:bar.baz.42" "foo" nil "bar" "baz" nil)
     287  #-allegro
     288  (check-physical-pathname #p"foo:bar.baz.42" nil "foo:bar.baz" "42")
     289  t)
    178290
    179291;; Define a logical host.
     
    182294
    183295;; LOGICAL-PATHNAME-TRANSLATIONS
    184 #+(or sbcl cmu)
    185 (expect (equal (logical-pathname-translations "effluvia")
    186                '(("**;*.*.*" "/usr/local/**/*.*"))))
    187 #+clisp
    188 (expect (equal (logical-pathname-translations "effluvia")
    189                '((#p"EFFLUVIA:**;*.*.*" "/usr/local/**/*.*"))))
    190 #+abcl
    191 (expect (equal (logical-pathname-translations "effluvia")
    192                '((#p"EFFLUVIA:**;*.*.*" #p"/usr/local/**/*.*"))))
     296#-allegro
     297(deftest logical-pathname-translations.1
     298  #+(or sbcl cmu)
     299  (equal (logical-pathname-translations "effluvia")
     300                 '(("**;*.*.*" "/usr/local/**/*.*")))
     301  #+clisp
     302  (equal (logical-pathname-translations "effluvia")
     303         '((#p"EFFLUVIA:**;*.*.*" "/usr/local/**/*.*")))
     304  #+abcl
     305  (equal (logical-pathname-translations "effluvia")
     306         '((#p"EFFLUVIA:**;*.*.*" #p"/usr/local/**/*.*")))
     307  t)
    193308
    194309#+sbcl
    195 ;; Even though "effluvia" is defined as a logical host, "bop" is not a valid
    196 ;; logical pathname version, so this can't be a logical pathname.
    197 (check-physical-pathname #p"effluvia:bar.baz.bop" nil "effluvia:bar.baz" "bop")
     310(deftest physical.29
     311  ;; Even though "effluvia" is defined as a logical host, "bop" is not a valid
     312  ;; logical pathname version, so this can't be a logical pathname.
     313  (check-physical-pathname #p"effluvia:bar.baz.bop" nil "effluvia:bar.baz" "bop")
     314  t)
    198315
    199316;; Parse error.
    200 (expect (signals-error (logical-pathname "effluvia::foo.bar")
    201                        #-(or allegro clisp) 'parse-error
    202                        #+(or allegro clisp) 'type-error))
     317(deftest logical-pathname.1
     318  (signals-error (logical-pathname "effluvia::foo.bar")
     319                 #-(or allegro clisp) 'parse-error
     320                 #+(or allegro clisp) 'type-error)
     321  t)
    203322
    204323#-allegro
     
    308427;; TRANSLATE-PATHNAME
    309428#-clisp
    310 (expect (equal (translate-pathname "foo" "*" "bar") #p"bar"))
    311 (expect (equal (translate-pathname "foo" "*" "*")   #p"foo"))
     429(deftest translate-pathname.1
     430  (equal (translate-pathname "foo" "*" "bar") #p"bar")
     431  t)
     432(deftest translate-pathname.2
     433  (equal (translate-pathname "foo" "*" "*")   #p"foo")
     434  t)
    312435
    313436#-abcl
    314437;; ABCL doesn't implement this translation.
    315 (expect (string= (pathname-name (translate-pathname "foobar" "*" "foo*")) "foofoobar"))
    316 
    317 (expect (string= (namestring (translate-pathname "test.txt" "*.txt" "*.text"))
    318                  "test.text"))
    319 
    320 (check-namestring (translate-pathname "foo/bar" "*/bar" "*/baz") "foo/baz")
     438(deftest translate-pathname.3
     439  (string= (pathname-name (translate-pathname "foobar" "*" "foo*")) "foofoobar")
     440  t)
     441
     442(deftest translate-pathname.4
     443  (string= (namestring (translate-pathname "test.txt" "*.txt" "*.text"))
     444           "test.text")
     445  t)
     446
     447(deftest translate-pathname.5
     448  (check-namestring (translate-pathname "foo/bar" "*/bar" "*/baz") "foo/baz")
     449  t)
    321450(expect (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz"))
    322451(expect (string= (namestring (translate-pathname "foo.bar" "*.*" "/usr/local/*.*"))
     
    361490  (expect (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar")) :unspecific))
    362491  (expect (eq (pathname-device #p"/usr/local/foo/bar") nil)))
    363 ;; (check-physical-pathname (translate-logical-pathname "effluvia:foo.bar")
    364 ;;                          '(:absolute "usr" "local") "foo" "bar")
    365492(expect (string= (namestring (translate-logical-pathname "effluvia:foo.bar"))
    366493                 #-windows "/usr/local/foo.bar"
    367494                 #+windows "\\usr\\local\\foo.bar"))
    368 ;; (check-physical-pathname (translate-logical-pathname "effluvia:foo;bar.txt")
    369 ;;                          '(:absolute "usr" "local" "foo") "bar" "txt")
    370495(expect (string= (namestring (translate-logical-pathname "effluvia:foo;bar.txt"))
    371496                 #-windows "/usr/local/foo/bar.txt"
     
    379504;; "TRANSLATE-PATHNAME [and thus also TRANSLATE-LOGICAL-PATHNAME] maps
    380505;; customary case in SOURCE into customary case in the output pathname."
    381 #-allegro
    382 (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
    383                          '(:absolute "usr" "local") "foo" "bar")
    384 #+allegro
    385 ;; Allegro preserves case.
    386 (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
    387                          '(:absolute "usr" "local") "Foo" "Bar")
    388 
    389 #-allegro
    390 (check-logical-pathname (merge-pathnames "effluvia:foo.bar")
    391                         "EFFLUVIA" '(:absolute) "FOO" "BAR" :newest)
    392 #+allegro
    393 ;; Allegro's MERGE-PATHNAMES apparently calls TRANSLATE-LOGICAL-PATHNAME.
    394 (check-physical-pathname (merge-pathnames "effluvia:foo.bar")
    395                          '(:absolute "usr" "local") "foo" "bar")
     506(deftest translate-logical-pathname.1
     507  #-allegro
     508  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
     509                           '(:absolute "usr" "local") "foo" "bar")
     510  #+allegro
     511  ;; Allegro preserves case.
     512  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
     513                           '(:absolute "usr" "local") "Foo" "Bar")
     514  t)
     515
     516(deftest merge-pathnames.1
     517  #-allegro
     518  (check-logical-pathname (merge-pathnames "effluvia:foo.bar")
     519                          "EFFLUVIA" '(:absolute) "FOO" "BAR" :newest)
     520  #+allegro
     521  ;; Allegro's MERGE-PATHNAMES apparently calls TRANSLATE-LOGICAL-PATHNAME.
     522  (check-physical-pathname (merge-pathnames "effluvia:foo.bar")
     523                           '(:absolute "usr" "local") "foo" "bar")
     524  t)
    396525
    397526;; The following tests are adapted from SBCL's pathnames.impure.lisp.
    398527(setf (logical-pathname-translations "demo0")
    399528      '(("**;*.*.*" "/tmp/")))
    400 (expect (not (pathname-match-p "demo0:file.lisp"
    401                                (logical-pathname "demo0:tmp;**;*.*.*"))))
     529(deftest sbcl.1
     530  (pathname-match-p "demo0:file.lisp" (logical-pathname "demo0:tmp;**;*.*.*"))
     531  nil)
     532
    402533#-clisp
    403 (check-namestring (translate-logical-pathname "demo0:file.lisp") "/tmp/file.lisp")
     534(deftest sbcl.2
     535  (check-namestring (translate-logical-pathname "demo0:file.lisp") "/tmp/file.lisp")
     536  t)
    404537
    405538(setf (logical-pathname-translations "demo1")
    406539      '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
    407540;; Remove "**" from the resulting pathname when the source directory is NIL.
    408 (expect (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
    409                     #-windows "/tmp/**/foo.lisp"
    410                     #+windows "\\tmp\\**\\foo.lisp")))
    411 (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp")
     541(deftest sbcl.3
     542  (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
     543         #-windows "/tmp/**/foo.lisp"
     544         #+windows "\\tmp\\**\\foo.lisp")
     545  nil)
     546(deftest sbcl.4
     547  (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp")
     548  t)
    412549;;; Check for absolute/relative path confusion.
    413 (expect (not (pathname-match-p "demo1:;foo.lisp" "**;*.*.*")))
     550(deftest sbcl.5
     551  (pathname-match-p "demo1:;foo.lisp" "**;*.*.*")
     552  nil)
    414553#-(or sbcl cmu allegro abcl)
    415554;; BUG Pathnames should match if the following translation is to work.
    416 (expect (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*"))
     555(deftest sbcl.6
     556  (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*")
     557  t)
    417558#+clisp
    418 (expect (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*"))
    419 (expect (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
    420                #+(and abcl windows) "\\tmp\\rel\\foo.lisp"
    421                #+(and abcl unix) "/tmp/rel/foo.lisp"
    422                #-(or allegro abcl) "/tmp/rel/foo.lisp"
    423                #+allegro "/tmp/foo.lisp"))
     559(deftest sbcl.7
     560  (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*")
     561  t)
     562(deftest sbcl.8
     563  (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
     564         #+(and abcl windows) "\\tmp\\rel\\foo.lisp"
     565         #+(and abcl unix) "/tmp/rel/foo.lisp"
     566         #-(or allegro abcl) "/tmp/rel/foo.lisp"
     567         #+allegro "/tmp/foo.lisp")
     568  t)
    424569
    425570(setf (logical-pathname-translations "demo2")
    426571      '(("test;**;*.*" "/tmp/demo2/test")))
    427 (expect (equal (enough-namestring "demo2:test;foo.lisp")
    428                #+sbcl "DEMO2:;TEST;FOO.LISP"
    429                #+cmu #p"DEMO2:TEST;FOO.LISP" ;; BUG (must be string or NIL)
    430                #+clisp "TEST;FOO.LISP"
    431                #+allegro "/test/foo.lisp" ;; BUG
    432                #+abcl "DEMO2:TEST;FOO.LISP"
    433                ))
     572(deftest sbcl.9
     573  (equal (enough-namestring "demo2:test;foo.lisp")
     574         #+sbcl "DEMO2:;TEST;FOO.LISP"
     575         #+cmu #p"DEMO2:TEST;FOO.LISP" ;; BUG (must be string or NIL)
     576         #+clisp "TEST;FOO.LISP"
     577         #+allegro "/test/foo.lisp" ;; BUG
     578         #+abcl "DEMO2:TEST;FOO.LISP"
     579         )
     580  t)
    434581
    435582#-(or allegro clisp cmu)
    436 (expect (signals-error (make-pathname :host "EFFLUVIA" :directory "!bla" :name "bar")
    437                        'error))
     583(deftest sbcl.10
     584  (signals-error (make-pathname :host "EFFLUVIA" :directory "!bla" :name "bar")
     585                 'error)
     586  t)
    438587#-(or allegro cmu)
    439 (expect (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "!bar")
    440                        'error))
     588(deftest sbcl.11
     589  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "!bar")
     590                 'error)
     591  t)
    441592#-(or allegro cmu)
    442 (expect (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "bar" :type "&baz")
    443                        'error))
    444 
    445 (expect (equal (namestring (parse-namestring "" "EFFLUVIA")) "EFFLUVIA:"))
    446 
    447 #-cmu
    448 (expect (equal (namestring (parse-namestring "" :unspecific)) ""))
    449 #+cmu
    450 ;; It seems reasonable to signal an error here, since the HOST argument to
    451 ;; PARSE-NAMESTRING is specified to be "a valid pathname host, a logical host,
    452 ;; or NIL".
    453 (expect (signals-error (parse-namestring "" :unspecific) 'type-error))
    454 
    455 (expect (equal (namestring (parse-namestring ""
    456                                              (pathname-host
    457                                               (translate-logical-pathname
    458                                                "EFFLUVIA:"))))
    459                ""))
     593(deftest sbcl.12
     594  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "bar" :type "&baz")
     595                 'error)
     596  t)
     597
     598(deftest sbcl.13
     599  (equal (namestring (parse-namestring "" "EFFLUVIA")) "EFFLUVIA:")
     600  t)
     601
     602(deftest sbcl.14
     603  #-cmu
     604  (equal (namestring (parse-namestring "" :unspecific)) "")
     605  #+cmu
     606  ;; It seems reasonable to signal an error here, since the HOST argument to
     607  ;; PARSE-NAMESTRING is specified to be "a valid pathname host, a logical host,
     608  ;; or NIL".
     609  (signals-error (parse-namestring "" :unspecific) 'type-error)
     610  t)
     611
     612(deftest sbcl.15
     613  (equal (namestring (parse-namestring ""
     614                                       (pathname-host
     615                                        (translate-logical-pathname
     616                                         "EFFLUVIA:"))))
     617         "")
     618  t)
    460619
    461620;; PARSE-NAMESTRING host mismatch: "If HOST is supplied and not NIL, and THING
    462621;; contains a manifest host name, an error of type ERROR is signaled if the
    463622;; hosts do not match."
    464 (expect (signals-error (parse-namestring "effluvia:foo.bar" "demo2") 'error))
     623(deftest sbcl.16
     624  (signals-error (parse-namestring "effluvia:foo.bar" "demo2") 'error)
     625  t)
    465626
    466627(setf (logical-pathname-translations "bazooka")
    467628      '(("todemo;*.*.*" "demo0:*.*.*")))
    468 #+allegro ;; BUG
    469 (expect (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y")) "/tmp/todemo/x.y"))
    470 #+clisp ;; BUG
    471 (expect (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error))
     629(deftest sbcl.17
     630  #+allegro ;; BUG
     631  (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y")) "/tmp/todemo/x.y")
     632  #+clisp ;; BUG
     633  (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error)
     634  #-(or allegro clisp)
     635  (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
     636         #-windows "/tmp/x.y"
     637         #+windows "\\tmp\\x.y")
     638  t)
     639(deftest sbcl.18
     640  #+clisp ;; BUG
     641  (signals-error (translate-logical-pathname "demo0:x.y") 'error)
     642  #-clisp
     643  (equal (namestring (translate-logical-pathname "demo0:x.y"))
     644         #-windows "/tmp/x.y"
     645         #+windows "\\tmp\\x.y")
     646  t)
    472647#-(or allegro clisp)
    473 (expect (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
    474                #-windows "/tmp/x.y"
    475                #+windows "\\tmp\\x.y"))
    476 #+clisp ;; BUG
    477 (expect (signals-error (translate-logical-pathname "demo0:x.y") 'error))
    478 #-clisp
    479 (expect (equal (namestring (translate-logical-pathname "demo0:x.y"))
    480                #-windows "/tmp/x.y"
    481                #+windows "\\tmp\\x.y"))
    482 #-(or allegro clisp)
    483 (expect (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
    484                (namestring (translate-logical-pathname "demo0:x.y"))))
     648(deftest sbcl.19
     649  (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
     650         (namestring (translate-logical-pathname "demo0:x.y")))
     651  t)
    485652
    486653;; "If HOST is incorrectly supplied, an error of type TYPE-ERROR is signaled."
    487 (expect (signals-error (logical-pathname-translations "unregistered-host")
    488                        #+clisp 'error ;; BUG
    489                        #+cmu 'file-error ;; BUG
    490                        #-(or clisp cmu) 'type-error))
    491 
    492 (expect (not (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")))
    493 (expect (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN"))
     654(deftest sbcl.20
     655  (signals-error (logical-pathname-translations "unregistered-host")
     656                 #+clisp 'error ;; BUG
     657                 #+cmu 'file-error ;; BUG
     658                 #-(or clisp cmu) 'type-error)
     659  t)
     660
     661(deftest sbcl.21
     662  (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")
     663  nil)
     664(deftest sbcl.22
     665  (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")
     666  t)
    494667
    495668(setf (logical-pathname-translations "test0")
    496669      '(("**;*.*.*"              "/library/foo/**/")))
    497 (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux")
    498                   "/library/foo/foo/bar/baz/mum.quux")
    499 (setf (logical-pathname-translations "prog")
    500       '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
    501         ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
    502         ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
    503         ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")))
     670(deftest sbcl.23
     671  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux")
     672                    "/library/foo/foo/bar/baz/mum.quux")
     673  t)
     674;; (setf (logical-pathname-translations "prog")
     675;;       '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
     676;;         ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
     677;;         ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
     678;;         ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")))
    504679(setf (logical-pathname-translations "prog")
    505680      '(("CODE;*.*.*"             "/lib/prog/")))
    506681#-allegro
    507 (check-namestring (translate-logical-pathname "prog:code;documentation.lisp")
    508                   "/lib/prog/documentation.lisp")
    509 (setf (logical-pathname-translations "prog")
     682(deftest sbcl.24
     683  (check-namestring (translate-logical-pathname "prog:code;documentation.lisp")
     684                    "/lib/prog/documentation.lisp")
     685  t)
     686(setf (logical-pathname-translations "prog1")
    510687      '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
    511688        ("CODE;*.*.*"             "/lib/prog/")))
    512689#-allegro
    513 (check-namestring (translate-logical-pathname "prog:code;documentation.lisp")
    514                   "/lib/prog/docum.lisp")
     690(deftest sbcl.25
     691  (check-namestring (translate-logical-pathname "prog1:code;documentation.lisp")
     692                    "/lib/prog/docum.lisp")
     693  t)
    515694
    516695;; "ANSI section 19.3.1.1.5 specifies that translation to a filesystem which
    517696;; doesn't have versions should ignore the version slot. CMU CL didn't ignore
    518697;; this as it should, but we [i.e. SBCL] do."
    519 #-cmucl
    520 (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")
    521                   "/library/foo/foo/bar/baz/mum.quux")
     698#-cmu
     699;; CMUCL supports emacs-style versions.
     700(deftest sbcl.26
     701  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")
     702                    "/library/foo/foo/bar/baz/mum.quux")
     703  t)
    522704
    523705(eval-when (:compile-toplevel :load-toplevel :execute)
     
    527709#-(or allegro clisp)
    528710;; FIXME Figure out why CLISP and Allegro don't like this test!
     711;; FIXME Figure out how to wrap this in DEFTEST!
    529712(loop for (expected-result . params) in
    530713  `(;; trivial merge
     
    611794         (frob pathname-type))))
    612795
    613 (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo")
    614 (expect (string=
    615          (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
    616          "SCRATCH:FOO"))
     796(deftest sbcl.27
     797  (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo")
     798  t)
     799(deftest sbcl.28
     800  (string= (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
     801           "SCRATCH:FOO")
     802  t)
    617803#-(or allegro clisp cmu)
    618 (expect (signals-error
    619          (setf (logical-pathname-translations "")
    620                (list '("**;*.*.*" "/**/*.*")))
    621          'error))
     804(deftest sbcl.29
     805  (signals-error (setf (logical-pathname-translations "")
     806                       (list '("**;*.*.*" "/**/*.*")))
     807                 'error)
     808  t)
     809
     810(rt:do-tests)
Note: See TracChangeset for help on using the changeset viewer.