tests/pathnames.pure.lisp

   1 ;;;; miscellaneous tests of pathname-related stuff
   2
   3 ;;;; This file is naturally impure because we mess with
   4 ;;;; LOGICAL-PATHNAME-TRANSLATIONS.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; While most of SBCL is derived from the CMU CL system, the test
  10 ;;;; files (like this one) were written from scratch after the fork
  11 ;;;; from CMU CL.
  12 ;;;;
  13 ;;;; This software is in the public domain and is provided with
  14 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  15 ;;;; more information.
  16
  17 \f
  18 ;;;; Pathname accessors
  19
  20 (with-test (:name (pathname :accessors :stream-not-associated-to-file type-error))
  21   (let ((*stream* (make-string-output-stream)))
  22     (declare (special *stream*))
  23     (checked-compile-and-assert ()
  24         '(lambda (pathname) (pathname-host pathname))
  25       (((make-string-output-stream))     (condition 'type-error))
  26       (((make-synonym-stream '*stream*)) (condition 'type-error)))))
  27
  28 (with-test (:name (pathname :accessors file-stream))
  29   (let* ((name "pathnames.pure")
  30          (type "lisp"))
  31     (with-open-file (stream (make-pathname :name name :type type))
  32       (assert (equal (pathname-name stream) name))
  33       (assert (equal (pathname-type stream) type)))))
  34
  35 (with-test (:name (pathname :accessors synonym-stream))
  36   (let* ((name "pathnames.pure")
  37          (type "lisp"))
  38     (with-open-file (stream (make-pathname :name name :type type))
  39       (let* ((*stream1* stream)
  40              (stream1 (make-synonym-stream '*stream1*))
  41              (*stream2* stream1)
  42              (stream2 (make-synonym-stream '*stream2*)))
  43         (declare (special *stream1* *stream2*))
  44         (assert (equal (pathname-name stream1) name))
  45         (assert (equal (pathname-name stream2) name))
  46         (assert (equal (pathname-type stream1) type))
  47         (assert (equal (pathname-type stream2) type))))))
  48
  49 (labels ((unpattern (thing)
  50            (typecase thing
  51              (cons
  52               (list* (unpattern (first thing))
  53                      (map 'list #'unpattern (rest thing))))
  54              (sb-impl::pattern
  55               (sb-impl::pattern-pieces thing))
  56              (t
  57               thing)))
  58          (pattern (thing)
  59            (typecase thing
  60              ((cons (member :absolute :relative))
  61               (list* (pattern (first thing))
  62                      (map 'list #'pattern (cdr thing))))
  63              (cons
  64               (sb-impl::make-pattern thing))
  65              (t
  66               thing)))
  67          (accessor-cases (initarg accessor cases)
  68            (map nil (lambda (test-case)
  69                       (destructuring-bind (pathname case expected) test-case
  70                         ;; Check accessor directory.
  71                         (let ((result (funcall accessor pathname :case case)))
  72                           (assert (equal (unpattern result) expected)))
  73                         ;; Check roundtrip.
  74                         (let* ((pathname (make-pathname initarg (pattern expected) :case case))
  75                                (result (funcall accessor pathname :case case)))
  76                           (assert (equal (unpattern result) expected)))))
  77                 cases)))
  78
  79   (with-test (:name (pathname-device :case))
  80     (accessor-cases
  81      :device #'pathname-device
  82      `((,(make-pathname :device "foo") :local  "foo")
  83        (,(make-pathname :device "FOO") :local  "FOO")
  84        (,(make-pathname :device "Foo") :local  "Foo")
  85
  86        (,(make-pathname :device "foo") :common "FOO")
  87        (,(make-pathname :device "FOO") :common "foo")
  88        (,(make-pathname :device "Foo") :common "Foo"))))
  89
  90   (with-test (:name (pathname-directory :case))
  91     (accessor-cases
  92      :directory #'pathname-directory
  93      `((,#P"/ab/cd/" :local  (:absolute "ab" "cd"))
  94        (,#P"/AB/CD/" :local  (:absolute "AB" "CD"))
  95        (,#P"/Ab/Cd/" :local  (:absolute "Ab" "Cd"))
  96        (,#P"/AB/cd/" :local  (:absolute "AB" "cd"))
  97        (,#P"/a*b/"   :local  (:absolute ("a" :multi-char-wild "b")))
  98
  99        (,#P"/ab/cd/" :common (:absolute "AB" "CD"))
 100        (,#P"/AB/CD/" :common (:absolute "ab" "cd"))
 101        (,#P"/Ab/Cd/" :common (:absolute "Ab" "Cd"))
 102        (,#P"/AB/cd/" :common (:absolute "ab" "CD"))
 103        (,#P"/a*b/"   :common (:absolute ("A" :multi-char-wild "B"))))))
 104
 105   (with-test (:name (pathname-name :case))
 106     (accessor-cases
 107      :name #'pathname-name
 108      `((,#P"foo" :local  "foo")
 109        (,#P"FOO" :local  "FOO")
 110        (,#P"Foo" :local  "Foo")
 111        (,#P"a*b" :local  ("a" :multi-char-wild "b"))
 112
 113        (,#P"foo" :common "FOO")
 114        (,#P"FOO" :common "foo")
 115        (,#P"Foo" :common "Foo")
 116        (,#P"a*b" :common ("A" :multi-char-wild "B")))))
 117
 118   (with-test (:name (pathname-type :case))
 119     (accessor-cases
 120      :type #'pathname-type
 121      `((,#P"n.foo" :local  "foo")
 122        (,#P"n.FOO" :local  "FOO")
 123        (,#P"n.Foo" :local  "Foo")
 124        (,#P"n.a*b" :local  ("a" :multi-char-wild "b"))
 125
 126        (,#P"n.foo" :common "FOO")
 127        (,#P"n.FOO" :common "foo")
 128        (,#P"n.Foo" :common "Foo")
 129        (,#P"n.a*b" :common ("A" :multi-char-wild "B"))))))
 130
 131 \f
 132 ;;;; Logical pathnames
 133
 134 (setf (logical-pathname-translations "demo0")
 135       '(("**;*.*.*" "/tmp/")))
 136
 137 ;;; In case of a parse error we want to get a condition of type TYPE-ERROR,
 138 ;;; because ANSI says so. (This used to be PARSE-ERROR.)
 139 (with-test (:name (logical-pathname :signals type-error))
 140   (mapc (lambda (namestring)
 141           (assert-error (logical-pathname namestring) type-error))
 142         '("demo0::bla;file.lisp"
 143           "FOO.txt"
 144           "SYS:%")))
 145
 146 ;; Ensure LOGICAL-PATHNAME signals the required type of error for all
 147 ;; the stream cases enumerated in CLHS.
 148 (with-test (:name (logical-pathname streams))
 149   (flet ((check-it (stream)
 150            (assert-error (logical-pathname stream) type-error)))
 151     (with-open-stream (in (make-string-input-stream ""))
 152       (with-open-stream (out (make-string-output-stream))
 153         (check-it in)
 154         (check-it out)
 155         (with-open-stream (two-way (make-two-way-stream in out))
 156           (check-it two-way))
 157         (with-open-stream (echo (make-echo-stream in out))
 158           (check-it echo))
 159         (with-open-stream (broadcast (make-broadcast-stream))
 160           (check-it broadcast))
 161         (with-open-stream (concatenated (make-concatenated-stream))
 162           (check-it concatenated))))
 163     ;; CLHS: "If PATHSPEC is a stream, it should be one for which
 164     ;; PATHNAME returns a logical pathname".
 165     (with-scratch-file (tmp "tmp")
 166       (with-open-file (file tmp :direction :output)
 167         ;; PATHNAME will return a physical pathname.
 168         (check-it file)))))
 169
 170 ;; Because FD-STREAM is a subclass of FILE-STREAM (lp#310098), some
 171 ;; file-streams have no associated pathname. In this case PATHNAME
 172 ;; errors; let's ensure LOGICAL-PATHNAME signals the required
 173 ;; TYPE-ERROR. (SB-SYS:*STDIN* is one such FILE-STREAM. If something
 174 ;; changes about SB-SYS:*STDIN* but there are still FILE-STREAMs
 175 ;; without pathnames, pick or make a different one.)
 176 (with-test (:name (logical-pathname anonymous-file-stream))
 177   (assert-error (logical-pathname sb-sys:*stdin*) type-error))
 178
 179 ;;; some things SBCL-0.6.9 used not to parse correctly:
 180 ;;;
 181 ;;; SBCL used to signal an error saying there's no translation.
 182 (with-test (:name (:logical-pathname 1))
 183   (assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
 184                  "/tmp/file.lisp")))
 185
 186 ;;; We do not match a null directory to every wild path:
 187 (with-test (:name (:logical-pathname 2))
 188   (assert (not (pathname-match-p "demo0:file.lisp"
 189                                  (logical-pathname "demo0:tmp;**;*.*.*")))))
 190
 191 ;;; Remove "**" from our resulting pathname when the source-dir is NIL:
 192 (with-test (:name (:logical-pathname 3))
 193   (setf (logical-pathname-translations "demo1")
 194         '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
 195   (assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
 196                     "/tmp/**/foo.lisp"))))
 197
 198 ;;; That should be correct:
 199 (with-test (:name (:logical-pathname 4))
 200   (assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
 201                  "/tmp/foo.lisp")))
 202
 203 ;;; Check for absolute/relative path confusion:
 204 (with-test (:name (:logical-pathname 5))
 205   (assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
 206                       "tmp/rel/foo.lisp")))
 207   (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
 208                  "/tmp/rel/foo.lisp")))
 209
 210 ;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to
 211 ;;; handle the following case exactly (otherwise we get an error:
 212 ;;; "#'IDENTITY CALLED WITH 2 ARGS."
 213 (with-test (:name (:logical-pathname 6))
 214   (setf (logical-pathname-translations "demo2")
 215         '(("test;**;*.*" "/tmp/demo2/test")))
 216   (enough-namestring "demo2:test;foo.lisp"))
 217
 218 ;;; When a pathname comes from a logical host, it should be in upper
 219 ;;; case. (This doesn't seem to be specifically required in the ANSI
 220 ;;; spec, but it's left up to the implementors, and the arguments made
 221 ;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty
 222 ;;; compelling reason for the implementors to choose case
 223 ;;; insensitivity and a canonical case.)
 224 (with-test (:name (:logical-pathname 7))
 225   (setf (logical-pathname-translations "FOO")
 226         '(("**;*.*.*" "/full/path/to/foo/**/*.*")))
 227   (let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD"
 228                              :type "conf"))
 229          (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd"
 230                              :type "CONF"))
 231          (pn3 (read-from-string (prin1-to-string pn1))))
 232     (assert (equal pn1 pn2))
 233     (assert (equal pn1 pn3))))
 234
 235 ;;; In addition to the upper-case constraint above, if the logical-pathname
 236 ;;; contains a string component in e.g. the directory, name and type slot,
 237 ;;; these should be valid "WORDS", according to CLHS 19.3.1.
 238 ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
 239 ;;; a TYPE-ERROR?
 240 (with-test (:name (:logical-pathname 8))
 241   (locally
 242     ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE
 243     (declare (optimize safety))
 244
 245     (assert (not (ignore-errors
 246                   (make-pathname :host "FOO" :directory "!bla" :name "bar"))))
 247
 248     ;; error: name-component not valid
 249     (assert (not (ignore-errors
 250                   (make-pathname :host "FOO" :directory "bla" :name "!bar"))))
 251
 252     ;; error: type-component not valid.
 253     (assert (not (ignore-errors
 254                   (make-pathname :host "FOO" :directory "bla" :name "bar"
 255                                  :type "&baz"))))))
 256
 257 ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
 258 ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC
 259 ;;; without actually requiring the system to signal an error (apart
 260 ;;; from host mismatches).
 261 (with-test (:name (:logical-pathname 9))
 262   (assert (equal (namestring (parse-namestring "" "FOO")) "FOO:"))
 263   (assert (equal (namestring (parse-namestring "" :unspecific)) "")))
 264
 265 ;;; The third would work if the call were (and it should continue to
 266 ;;; work ...)
 267 (with-test (:name (:logical-pathname 10))
 268   (parse-namestring ""
 269                     (pathname-host
 270                      (translate-logical-pathname
 271                       "FOO:"))))
 272
 273 ;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch.
 274 (with-test (:name (:logical-pathname 11))
 275   (let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
 276     (assert (typep cond 'type-error))))
 277
 278 ;;; turning one logical pathname into another:
 279 (with-test (:name (:logical-pathname 12))
 280   (setf (logical-pathname-translations "foo")
 281         '(("todemo;*.*.*" "demo0:*.*.*")))
 282   (assert (equal (namestring (translate-logical-pathname "foo:todemo;x.y"))
 283                  (namestring (translate-logical-pathname "demo0:x.y")))))
 284
 285 ;;; ANSI, in its wisdom, specifies that it's an error (specifically a
 286 ;;; TYPE-ERROR) to query the system about the translations of a string
 287 ;;; which doesn't have any translations. It's not clear why we don't
 288 ;;; just return NIL in that case, but they make the rules..
 289 (with-test (:name (:logical-pathname 13))
 290   (let ((cond (grab-condition (logical-pathname-translations "unregistered-host"))))
 291     (assert (typep cond 'type-error)))
 292
 293   (assert (not (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")))
 294   (assert (string-equal (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")))
 295
 296 ;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said
 297 ;;;   examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS
 298 ;;;   (sometimes converted to the Un*x way of things)
 299 ;;; but when I looked it up I didn't see the connection. Presumably
 300 ;;; there's some code in this section which should be attributed
 301 ;;; to something in the ANSI spec, but I don't know what code it is
 302 ;;; or what section of the specification has the related code.
 303 (with-test (:name (:logical-pathname 14))
 304   (setf (logical-pathname-translations "test0")
 305         '(("**;*.*.*"              "/library/foo/**/")))
 306   (assert (equal (namestring (translate-logical-pathname
 307                               "test0:foo;bar;baz;mum.quux"))
 308                  "/library/foo/foo/bar/baz/mum.quux"))
 309   (setf (logical-pathname-translations "prog")
 310         '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
 311           ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
 312           ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
 313           ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")))
 314   (setf (logical-pathname-translations "prog")
 315         '(("CODE;*.*.*"             "/lib/prog/")))
 316   (assert (equal (namestring (translate-logical-pathname
 317                               "prog:code;documentation.lisp"))
 318                  "/lib/prog/documentation.lisp"))
 319   (setf (logical-pathname-translations "prog")
 320         '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
 321           ("CODE;*.*.*"             "/lib/prog/")))
 322   (assert (equal (namestring (translate-logical-pathname
 323                               "prog:code;documentation.lisp"))
 324                  "/lib/prog/docum.lisp")))
 325
 326 ;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
 327 ;;; which doesn't have versions should ignore the version slot. CMU CL
 328 ;;; didn't ignore this as it should, but we do.
 329 (with-test (:name (:logical-pathname 15))
 330   (assert (equal (namestring (translate-logical-pathname
 331                               "test0:foo;bar;baz;mum.quux.3"))
 332                  "/library/foo/foo/bar/baz/mum.quux")))
 333
 334 \f
 335 ;;;; MERGE-PATHNAME tests
 336 ;;;;
 337 ;;;; There are some things we don't bother testing, just because they're
 338 ;;;; not meaningful on the underlying filesystem anyway.
 339 ;;;;
 340 ;;;; Mostly that means that we don't do devices, we don't do versions
 341 ;;;; except minimally in LPNs (they get lost in the translation to
 342 ;;;; physical hosts, so it's not much of an issue), and we don't do
 343 ;;;; hosts except for LPN hosts
 344 ;;;;
 345 ;;;; Although these tests could conceivably be useful in principle for
 346 ;;;; other implementations, they depend quite heavily on the rules for
 347 ;;;; namestring parsing, which are implementation-specific. So, success
 348 ;;;; or failure in these tests doesn't tell you anything about
 349 ;;;; ANSI-compliance unless your PARSE-NAMESTRING works like ours.
 350
 351 ;;; Needs to be done at compile time, so that the #p"" read-macro
 352 ;;; correctly parses things as logical pathnames. This is not a
 353 ;;; problem as was, as this is an impure file and so gets loaded in,
 354 ;;; but just for future proofing...
 355 (eval-when (:compile-toplevel :load-toplevel :execute)
 356   (setf (logical-pathname-translations "scratch")
 357         '(("**;*.*.*" "/usr/local/doc/**/*"))))
 358
 359 (with-test (:name (merge-pathnames 1))
 360   (loop for (expected-result . params) in
 361         `( ;; trivial merge
 362           (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/")
 363           ;; If pathname does not specify a host, device, directory,
 364           ;; name, or type, each such component is copied from
 365           ;; default-pathname.
 366           ;; 1) no name, no type
 367           (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type")
 368           ;; 2) no directory, no type
 369           (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type")
 370           ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
 371           ;; as a name)
 372           (#p"/dir/name.supplied-type"
 373              ,(make-pathname :type "supplied-type")
 374              #p"/dir/name.type")
 375           ;; If (pathname-directory pathname) is a list whose car is
 376           ;; :relative, and (pathname-directory default-pathname) is a
 377           ;; list, then the merged directory is [...]
 378           (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee")
 379           ;; except that if the resulting list contains a string or
 380           ;; :wild immediately followed by :back, both of them are
 381           ;; removed.
 382           (#P"/aaa/bbb/ccc/blah/eee"
 383              ;; "../" in a namestring is parsed as :up not :back, so make-pathname
 384              ,(make-pathname :directory '(:relative :back "blah"))
 385              #p"/aaa/bbb/ccc/ddd/eee")
 386           ;; If (pathname-directory default-pathname) is not a list or
 387           ;; (pathname-directory pathname) is not a list whose car is
 388           ;; :relative, the merged directory is (or (pathname-directory
 389           ;; pathname) (pathname-directory default-pathname))
 390           (#P"/absolute/path/name.type"
 391              #p"/absolute/path/name"
 392              #p"/dir/default-name.type")
 393           ;; === logical pathnames ===
 394           ;; recognizes a logical pathname namestring when
 395           ;; default-pathname is a logical pathname
 396           ;; FIXME: 0.6.12.23 fails this one.
 397           ;;
 398           ;; And, as it happens, it's right to fail it. Because
 399           ;; #p"name1" is read in with the ambient *d-p-d* value, which
 400           ;; has a physical (Unix) host; therefore, the host of the
 401           ;; default-pathname argument to merge-pathnames is
 402           ;; irrelevant. The result is (correctly) different if
 403           ;; '#p"name1"' is replaced by "name1", below, though it's
 404           ;; still not what one might expect... -- CSR, 2002-05-09
 405           #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;")
 406           ;; or when the namestring begins with the name of a defined
 407           ;; logical host followed by a colon [I assume that refers to pathname
 408           ;; rather than default-pathname]
 409           (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;")
 410           ;; conduct the previous set of tests again, with a lpn first argument
 411           (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/")
 412           (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
 413              #p"scratch:supplied-dir;"
 414              #p"/dir/name.type")
 415           (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
 416              #p"scratch:;supplied-name"
 417              #p"/dir/name.type")
 418           (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
 419              ,(make-pathname :host "scratch" :type "supplied-type")
 420              #p"/dir/name.type")
 421           (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
 422              ,(make-pathname :host "scratch"
 423                              :directory '(:relative "foo")
 424                              :name "bar")
 425              #p"/aaa/bbb/ccc/ddd/eee")
 426           (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
 427              ,(make-pathname :host "scratch"
 428                              :directory '(:relative :back "foo")
 429                              :name "bar")
 430              #p"/aaa/bbb/ccc/ddd/eee")
 431           (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
 432              #p"scratch:absolute;path;name" #p"/dir/default-name.type")
 433
 434           ;; FIXME: test version handling in LPNs
 435           )
 436         do (let ((result (apply #'merge-pathnames params)))
 437              (macrolet ((frob (op)
 438                               `(assert (equal (,op result) (,op expected-result)))))
 439                (frob pathname-host)
 440                (frob pathname-directory)
 441                (frob pathname-name)
 442                (frob pathname-type)))))
 443 \f
 444 ;;; host-namestring testing
 445 (with-test (:name host-namestring)
 446   (assert (string=
 447            (namestring (parse-namestring "/foo" (host-namestring #p"/bar")))
 448            "/foo"))
 449   (assert (string=
 450            (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
 451            "SCRATCH:FOO"))
 452   (assert-error
 453    (setf (logical-pathname-translations "")
 454          (list '("**;*.*.*" "/**/*.*")))))
 455 \f
 456 ;;; Bug 200: translate-logical-pathname is according to the spec supposed
 457 ;;; not to give errors if asked to translate a namestring for a valid
 458 ;;; physical pathname.  Failed in 0.7.7.28 and before
 459 (with-test (:name (:logical-pathname 16))
 460   (assert (string= (namestring (translate-logical-pathname "/")) "/")))
 461
 462 \f
 463 ;;; Not strictly pathname logic testing, but until sbcl-0.7.6.19 we
 464 ;;; had difficulty with non-FILE-STREAM stream arguments to pathname
 465 ;;; functions (they would cause memory protection errors).  Make sure
 466 ;;; that those errors are gone:
 467 (with-test (:name (string-stream :not-a pathname))
 468   (flet ((test (form)
 469            (multiple-value-bind (fun failurep warnings)
 470                (checked-compile
 471                 `(lambda () ,form) :allow-warnings 'sb-int:type-warning)
 472              (declare (ignore failurep))
 473              (assert (= 1 (length warnings)))
 474              (assert-error (funcall fun) type-error))))
 475     (test '(pathname (make-string-input-stream "FOO")))
 476     (test '(merge-pathnames (make-string-output-stream)))))
 477 \f
 478 ;;; ensure print-read consistency (or print-not-readable-error) on
 479 ;;; pathnames:
 480 (with-test (:name :print/read-consistency)
 481   (dolist (p (list (make-pathname :name ".")
 482                    (make-pathname :name "foo" :type "txt" :version :newest)
 483                    (make-pathname :name "foo" :type "txt" :version 1)
 484                    (make-pathname :name "foo" :type ".txt")
 485                    (make-pathname :name "foo." :type "txt")
 486                    (make-pathname :name #-win32 "\\" #+win32 "^^" :type "txt")
 487                    (make-pathname :name "^" :type "txt")
 488                    (make-pathname :name "foo*" :type "txt")
 489                    (make-pathname :name "foo[" :type "txt")
 490                    (make-pathname :name "foo.bar" :type "txt")
 491                    (make-pathname :name "foo" :type "txt.gz")
 492                    (make-pathname :name "foo.bar" :type "txt.gz")
 493                    (make-pathname :name "foo.bar")
 494                    (parse-namestring "SCRATCH:FOO.TXT.1")
 495                    (parse-namestring "SCRATCH:FOO.TXT.NEWEST")
 496                    (parse-namestring "SCRATCH:FOO.TXT")))
 497     (let* ((*print-readably* t)
 498            (new (read-from-string (format nil "~S" p))))
 499       (unless (equal new p)
 500         (let ((*print-readably* nil))
 501           (error ":host ~S :device ~S :directory ~S :name ~S :type ~S :version ~S~@
 502                   -> :host ~S :device ~S :directory ~S :name ~S :type ~S :version ~S"
 503                  (pathname-host p) (pathname-device p)
 504                  (pathname-directory p) (pathname-name p)
 505                  (pathname-type p) (pathname-version p)
 506                  (pathname-host new) (pathname-device new)
 507                  (pathname-directory new) (pathname-name new)
 508                  (pathname-type new) (pathname-version new)))))))
 509 \f
 510 ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the
 511 ;;; default argument" ...and streams as well
 512 (with-test (:name (parse-namestring stream))
 513   (assert (equal (parse-namestring "foo" nil "/")
 514                  (parse-namestring "foo" nil #P"/")))
 515   (with-scratch-file (test "tmp")
 516         (with-open-file (f test :direction :output)
 517           ;; FIXME: This test is a bit flaky, since we only check that
 518           ;; no error is signalled. The dilemma here is "what is the
 519           ;; correct result when defaults is a _file_, not a
 520           ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
 521           ;; opposed to eg. #P"/path/to/current/foo"), which is
 522           ;; possibly mildly surprising but probably conformant.
 523           (assert (parse-namestring "foo" nil f)))))
 524 \f
 525 ;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
 526 ;;; question has a :RELATIVE pathname.
 527 (with-test (:name enough-namestring)
 528   (assert (equal (enough-namestring #p"foo" #p"./") "foo")))
 529 \f
 530 ;;;; NAMESTRING
 531
 532 ;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
 533 ;;; directory lists. lp#1738775, reported by Richard M. Kreuter, added
 534 ;;; more cases.
 535 (with-test (:name (namestring :wild :wild-inferiors :up :lp-1738775))
 536   (flet ((test (expected pathname)
 537            (assert (equal (namestring pathname) expected))))
 538     ;; The second variant using MAKE-PATHNAME makes sure we don't just
 539     ;; return the original namestring.
 540     (test "/tmp/*/" #P"/tmp/*/")
 541     (test "/tmp/*/" (make-pathname :directory '(:absolute "tmp" :wild)))
 542
 543     ;; lp#1738775 reported breakage in case FIRST in (:absolute FIRST
 544     ;; ...) is not of type STRING.
 545     (test "/*/" #P"/*/")
 546     (test "/*/" (make-pathname :directory '(:absolute :wild)))
 547
 548     (test "/**/" #P"/**/")
 549     (test "/**/" (make-pathname :directory '(:absolute :wild-inferiors)))
 550
 551     ;; FIXME "Invalid combinations" in 19.2.2.4.3 requires :ABSOLUTE
 552     ;; :UP to signal a FILE-ERROR, but we don't.
 553     (test "/../" #P"/../")
 554     (test "/../" (make-pathname :directory '(:absolute :up)))))
 555
 556 (with-test (:name (namestring :escape-pattern-pieces))
 557   (labels ((prepare (namestring)
 558              #-win32 (substitute #\\ #\E namestring)
 559              #+win32 (substitute #\^ #\E namestring))
 560            (test (expected namestring)
 561              (let ((pathname (pathname (prepare namestring))))
 562                (assert (string= (prepare expected) (namestring pathname))))))
 563     #-win32 (test "*E?"    "*E?")
 564     #-win32 (test "*E*"    "*E*")
 565             (test "*E[ab]" "*E[ab]")
 566             (test "*EE"    "*EE")))
 567
 568 (with-test (:name (namestring :escape-dot))
 569   (labels ((prepare (namestring)
 570              #-win32 (substitute #\\ #\E namestring)
 571              #+win32 (substitute #\^ #\E namestring))
 572            (test (expected &rest args)
 573              (let* ((expected (prepare expected))
 574                     (args (loop for (key value) on args by #'cddr
 575                                 collect key collect (prepare value)))
 576                     (pathname (pathname (apply #'make-pathname args))))
 577                (assert (string= expected (namestring pathname)))
 578                (assert (equal (parse-namestring expected) pathname)))))
 579     (test "."                :name ".")
 580     (test "foo"              :name "foo")
 581     (test ".foo"             :name ".foo")
 582     (test "fooE.baz"         :name "foo.baz")
 583     (test "fooEE"            :name "fooE")
 584     (test "fooEEEE"          :name "fooEE")
 585
 586     (test "..bar"            :name "."       :type "bar")
 587     (test "foo.bar"          :name "foo"     :type "bar")
 588     (test ".foo.bar"         :name ".foo"    :type "bar")
 589     (test "foo.baz.bar"      :name "foo.baz" :type "bar")
 590     (test "fooEE.bar"        :name "fooE"    :type "bar")
 591     (test "fooEEEE.bar"      :name "fooEE"   :type "bar")
 592
 593     (test "..E.bar"          :name "."       :type ".bar")
 594     (test "foo.E.bar"        :name "foo"     :type ".bar")
 595     (test ".foo.E.bar"       :name ".foo"    :type ".bar")
 596     (test "foo.baz.E.bar"    :name "foo.baz" :type ".bar")
 597     (test "fooEE.E.bar"      :name "fooE"    :type ".bar")
 598     (test "fooEEEE.E.bar"    :name "fooEE"   :type ".bar")
 599
 600     (test "..barE.fez"       :name "."       :type "bar.fez")
 601     (test "foo.barE.fez"     :name "foo"     :type "bar.fez")
 602     (test ".foo.barE.fez"    :name ".foo"    :type "bar.fez")
 603     (test "foo.baz.barE.fez" :name "foo.baz" :type "bar.fez")
 604     (test "fooEE.barE.fez"   :name "fooE"    :type "bar.fez")
 605     (test "fooEEEE.barE.fez" :name "fooEE"   :type "bar.fez")
 606
 607     (test "..barE."          :name "."       :type "bar.")
 608     (test "foo.barE."        :name "foo"     :type "bar.")
 609     (test ".foo.barE."       :name ".foo"    :type "bar.")
 610     (test "foo.baz.barE."    :name "foo.baz" :type "bar.")
 611     (test "fooEE.barE."      :name "fooE"    :type "bar.")
 612     (test "fooEEEE.barE."    :name "fooEE"   :type "bar.")
 613
 614     (test "..EEbar"          :name "."       :type "Ebar")
 615     (test "foo.EEbar"        :name "foo"     :type "Ebar")
 616     (test ".foo.EEbar"       :name ".foo"    :type "Ebar")
 617     (test "foo.baz.EEbar"    :name "foo.baz" :type "Ebar")
 618     (test "fooEE.EEbar"      :name "fooE"    :type "Ebar")
 619     (test "fooEEEE.EEbar"    :name "fooEE"   :type "Ebar")))
 620
 621 ;;; Printing of pathnames; see CLHS 22.1.3.1. This section was started
 622 ;;; to confirm that pathnames are printed as their namestrings under
 623 ;;; :escape nil :readably nil.
 624 (with-test (:name :print-as-namestrings)
 625   (loop for (pathname expected . vars) in
 626         `((#p"/foo" "#P\"/foo\"")
 627           (#p"/foo" "#P\"/foo\"" :readably nil)
 628           (#p"/foo" "#P\"/foo\"" :escape nil)
 629           (#p"/foo" "/foo"       :readably nil :escape nil))
 630         for actual = (with-standard-io-syntax
 631                       (apply #'write-to-string pathname vars))
 632         do (assert (string= expected actual)
 633                    ()
 634                    "~S should be ~S, was ~S"
 635                    (list* 'write-to-string pathname vars)
 636                    expected
 637                    actual)))
 638 \f
 639 ;;; we got (truename "/") wrong for about 6 months.  Check that it's
 640 ;;; still right.
 641 (with-test (:name :root-truename)
 642   (let ((pathname (truename "/")))
 643     (assert (equalp pathname (merge-pathnames #p"/")))
 644     (assert (equal (pathname-directory pathname) '(:absolute)))))
 645 \f
 646 ;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
 647 ;;; (Reported by Pascal Bourguignon.
 648 (with-test (:name (namestring :unparse-logical-wild))
 649   (let ((pathname (make-pathname :host "SYS" :directory '(:absolute :wild-inferiors)
 650                                  :name :wild :type nil)))
 651     (assert (string= (namestring pathname) "SYS:**;*"))
 652     (assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\""))))
 653
 654 (with-test (:name (namestring :signals file-error))
 655   (flet ((test (&rest initargs)
 656            (let ((pathname (apply #'make-pathname initargs)))
 657              (assert-error (namestring pathname) file-error))))
 658     (test :name "")
 659     (test :type "foo")))
 660 \f
 661 ;;; reported by James Y Knight on sbcl-devel 2006-05-17
 662 (with-test (:name :merge-back)
 663   (let ((p1 (make-pathname :directory '(:relative "bar")))
 664         (p2 (make-pathname :directory '(:relative :back "foo"))))
 665     (assert (equal (merge-pathnames p1 p2)
 666                    (make-pathname :directory '(:relative :back "foo" "bar"))))))
 667
 668 (with-test (:name (native-namestring :signals file-error :unix))
 669   (flet ((test (&rest initargs)
 670            (let ((pathname (apply #'make-pathname initargs)))
 671              (assert-error (native-namestring pathname) file-error))))
 672     (test :directory '(:absolute (:home "no-such-user")))
 673     (test :directory '(:absolute :wild))
 674     (test :name :wild)
 675     (test :name "foo" :type :wild)
 676     (test :type "bar")))
 677
 678 ;;; construct native namestrings even if the directory is empty (means
 679 ;;; that same as if (:relative))
 680 (with-test (:name (sb-ext:native-namestring 1))
 681   (assert (equal (sb-ext:native-namestring (make-pathname :directory '(:relative)
 682                                                           :name "foo"
 683                                                           :type "txt"))
 684                  (sb-ext:native-namestring (let ((p (make-pathname :directory nil
 685                                                                    :name "foo"
 686                                                                    :type "txt")))
 687                                              (assert (not (pathname-directory p)))
 688                                              p)))))
 689
 690 ;;; reported by Richard Kreuter: PATHNAME and MERGE-PATHNAMES used to
 691 ;;; be unsafely-flushable. Since they are known to return non-nil values
 692 ;;; only, the test-node of the IF is flushed, and since the function
 693 ;;; is unsafely-flushable, out it goes, and bad pathname designators
 694 ;;; breeze through.
 695 ;;;
 696 ;;; These tests rely on using a stream that appears as a file-stream
 697 ;;; but isn't a valid pathname-designator.
 698 (with-test (:name :dont-flush-pathnames)
 699   (assert (eq :false
 700               (if (ignore-errors (pathname sb-sys::*tty*)) :true :false)))
 701   (assert (eq :false
 702               (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false))))
 703
 704 ;;; This used to return "quux/bar.lisp"
 705 (with-test (:name :dpd-output-file)
 706   (assert (equal #p"quux/bar.fasl"
 707                  (let ((*default-pathname-defaults* #p"quux/"))
 708                    (compile-file-pathname "foo.lisp" :output-file "bar"))))
 709   (assert (equal #p"quux/bar.fasl"
 710                  (let ((*default-pathname-defaults* #p"quux/"))
 711                    (compile-file-pathname "bar.lisp")))))
 712 \f
 713 (with-test (:name :wild-enough)
 714   (enough-namestring #p".a*"))
 715 \f
 716
 717 (with-test (:name :translated-wild-version)
 718   (assert (eq 99
 719             (pathname-version
 720              (translate-pathname
 721               (make-pathname :name "foo" :type "bar" :version 99)
 722               (make-pathname :name :wild :type :wild :version :wild)
 723               (make-pathname :name :wild :type :wild :version :wild)))))
 724
 725   (assert (eq 99
 726               (pathname-version
 727                (translate-pathname
 728                 (make-pathname :name "foo" :type "bar" :version 99)
 729                 (make-pathname :name :wild :type :wild :version :wild)
 730                 (make-pathname :name :wild :type :wild :version nil))))))
 731
 732 ;;; enough-namestring relative to root
 733 (with-test (:name :enough-relative-to-root)
 734   (assert (equal "foo" (enough-namestring "/foo" "/"))))
 735 \f
 736 ;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and
 737 ;;; non-NIL strings in NATIVE-NAMESTRING implementations.  Revised by
 738 ;;; RMK 2007-11-28, attempting to preserve the apparent intended
 739 ;;; denotation of SBCL's then-current pathname implementation.
 740 (with-test (:name (sb-ext:native-namestring 2))
 741   (assert (equal
 742            (loop with components = (list nil :unspecific "" "a")
 743                  for name in components
 744                  appending (loop for type in components
 745                                  as pathname = (make-pathname
 746                                                 #+win32 :device #+win32 "C"
 747                                                 :directory '(:absolute "tmp")
 748                                                 :name name :type type)
 749                                  collect (ignore-errors
 750                                           (sb-ext:native-namestring pathname))))
 751            #-win32
 752               #|type  NIL       :UNSPECIFIC   ""        "a"         |#
 753   #|name       |#
 754   #|NIL        |#   '("/tmp/"   "/tmp/"       NIL       NIL
 755   #|:UNSPECIFIC|#     "/tmp/"   "/tmp/"       NIL       NIL
 756   #|""         |#     "/tmp/"   "/tmp/"       "/tmp/."  "/tmp/.a"
 757   #|"a"        |#     "/tmp/a"  "/tmp/a"      "/tmp/a." "/tmp/a.a")
 758
 759            #+win32
 760               #|type  NIL           :UNSPECIFIC   ""            "a"     |#
 761   #|name       |#
 762   #|NIL        |#   '("C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
 763   #|:UNSPECIFIC|#     "C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
 764   #|""         |#     "C:\\tmp\\"   "C:\\tmp\\"   "C:\\tmp\\."  "C:\\tmp\\.a"
 765   #|"a"        |#     "C:\\tmp\\a"  "C:\\tmp\\a"  "C:\\tmp\\a." "C:\\tmp\\a.a"))))
 766
 767 (defun scratch-dir-truename ()
 768   (with-scratch-file (name)
 769     (truename (make-pathname :directory (pathname-directory name)
 770                              :device (pathname-device name)))))
 771
 772 (with-test (:name (delete-file logical-pathname))
 773   (setf (logical-pathname-translations "SB-TEST")
 774         (list (list "**;*.*.*" (make-pathname :name :wild
 775                                               :type :wild
 776                                               :defaults
 777                                               (scratch-dir-truename)))))
 778   (let ((test (pathname "SB-TEST:delete-logical-pathname.tmp")))
 779     (assert (typep test 'logical-pathname))
 780     (with-open-file (f test :direction :output)
 781       (write-line "delete me!" f))
 782     (assert (probe-file test))
 783     (assert (delete-file test))
 784     (assert (not (probe-file test)))))
 785
 786 ;;; Reported by Willem Broekema: Reading #p"\\\\" caused an error due
 787 ;;; to insufficient sanity in input testing in EXTRACT-DEVICE (in
 788 ;;; src;code;win32-pathname).
 789 (with-test (:name :bug-489698 :skipped-on (not :win32))
 790   (assert (equal (make-pathname :directory '(:absolute))
 791                  (read-from-string "#p\"\\\\\\\\\""))))
 792
 793 (with-test (:name :load-logical-pathname-translations)
 794   (let* ((foo (scratch-file-name "translations"))
 795          (bar (scratch-file-name "translations"))
 796          (translations (logical-pathname-translations "SYS")))
 797     (unwind-protect
 798          (progn
 799            (with-open-file (f foo :direction :output)
 800              (prin1 (list (list "*.TEXT" (make-pathname
 801                                           :directory '(:absolute "my" "foo")
 802                                           :name :wild :type "txt")))
 803                     f))
 804            (with-open-file (f bar :direction :output)
 805              (prin1 (list (list "*.CL" (make-pathname
 806                                         :directory '(:absolute "my" "bar")
 807                                         :name :wild :type "lisp"))) f))
 808            (setf (logical-pathname-translations "SYS")
 809                  (list* (list "SITE;LLPNT-FOO.TRANSLATIONS.NEWEST" (truename foo))
 810                         (list "SITE;LLPNT-BAR.TRANSLATIONS.NEWEST" (truename bar))
 811                         translations))
 812            (assert (load-logical-pathname-translations "LLPNT-FOO"))
 813            (assert (load-logical-pathname-translations "LLPNT-BAR"))
 814            (assert
 815             (and
 816              (equal "/my/bar/quux.lisp"
 817                     (namestring (translate-logical-pathname "LLPNT-BAR:QUUX.CL")))
 818              (equal "/my/foo/quux.txt"
 819                     (namestring (translate-logical-pathname "LLPNT-FOO:QUUX.TEXT"))))))
 820       (ignore-errors (delete-file foo))
 821       (ignore-errors (delete-file bar))
 822       (setf (logical-pathname-translations "SYS") translations))))
 823
 824 (with-test (:name :tilde-expansion)
 825   (assert (equal '(:absolute :home "foo") (pathname-directory "~/foo/bar.txt")))
 826   (assert (equal '(:absolute (:home "jdoe") "quux") (pathname-directory "~jdoe/quux/")))
 827   (assert (equal "~/foo/x" (namestring (make-pathname :directory '(:absolute :home "foo")
 828                                                       :name "x"))))
 829   (assert (equal (native-namestring (merge-pathnames "a/b.c" (user-homedir-pathname)))
 830                  (native-namestring #p"~/a/b.c")))
 831   ;; Not a directory.
 832   (assert (equal (native-namestring #p"~foo") "~foo"))
 833   ;; Not at the start of the first directory
 834   (assert (equal (native-namestring #p"foo/~/bar")
 835                  #-win32 "foo/~/bar"
 836                  #+win32 "foo\\~\\bar"))
 837   (equal (native-namestring (merge-pathnames "~/"))
 838          (native-namestring (user-homedir-pathname))))
 839
 840 ;;; lp#673625
 841 (with-test (:name :pathname-escape-first-directory-component
 842             :fails-on :win32)
 843   ;; ~ / :HOME
 844   (assert (equal (pathname-directory #-win32 #p"\\~/foo/"
 845                                      #+win32 #p"^~/foo/")
 846                  '(:relative "~" "foo")))
 847   (assert (equal (native-namestring #-win32 #p"\\~/foo/"
 848                                     #+win32 #p"^~/foo/")
 849                  #-win32 "~/foo/"
 850                  #+win32 "~\\foo\\"))
 851   (assert (equal (namestring (make-pathname :directory '(:absolute "~zot")))
 852                  "\\~zot/"))
 853   ;; * / :WILD
 854   (assert (equal (pathname-directory #p"\\*/") '(:relative "*"))))
 855
 856 (with-test (:name (ensure-directories-exist :with-odd-d-p-d))
 857   (let ((*default-pathname-defaults* #p"/tmp/foo"))
 858     (ensure-directories-exist "/")))
 859
 860 (with-test (:name :long-file-name :skipped-on (not :win32))
 861   (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory"
 862               "use-the-7zip-file-manager"))
 863          (base (truename
 864                 (directory-namestring (or *load-pathname* *compile-file-pathname*))))
 865          (shallow (make-pathname :directory `(:relative ,(car x))))
 866          (shallow (merge-pathnames shallow base))
 867          (deep (make-pathname
 868                 :directory `(:relative ,@(loop repeat 10 appending x))))
 869          (deep (merge-pathnames deep base))
 870          (native (sb-ext:native-namestring deep)))
 871     (assert (> (length native) 260))
 872     (assert (eql 3 (mismatch "\\\\?" native)))
 873     (assert (not (probe-file shallow)))
 874     (unwind-protect
 875          (progn
 876            (ensure-directories-exist deep)
 877            (assert (probe-file deep)))
 878       (sb-ext:delete-directory shallow :recursive t))
 879     (assert (not (probe-file shallow)))))
 880
 881 #+unix
 882 (with-test (:name sb-int:simplify-namestring)
 883   (assert (string= (sb-int:simplify-namestring "./a/b/../c/")
 884                    "a/c/")))
 885
 886 (with-test (:name :back-and-truename)
 887   (probe-file (make-pathname :directory '(:absolute "a" "b" :back))))
 888
 889 (with-test (:name (parse-namestring :displaced))
 890   (let* ((string "abc")
 891          (disp (make-array 0 :element-type (array-element-type string)
 892                              :displaced-to string
 893                              :displaced-index-offset 1)))
 894     (multiple-value-bind (path pos)
 895         (parse-namestring disp)
 896       (assert (equal path #P""))
 897       (assert (zerop pos)))))
 898
 899 (with-test (:name (sb-ext:parse-native-namestring :displaced))
 900   (let* ((string "abc")
 901          (disp (make-array 0 :element-type (array-element-type string)
 902                              :displaced-to string
 903                              :displaced-index-offset 1)))
 904     (multiple-value-bind (path pos)
 905         (sb-ext:parse-native-namestring disp)
 906       (assert (equal path #P""))
 907       (assert (zerop pos)))))
 908
 909 (with-test (:name (:parse-logical-pathname :displaced))
 910   (let* ((string "XSYS:ABC.LISP")
 911          (disp (make-array (1- (length string))
 912                            :element-type (array-element-type string)
 913                            :displaced-to string
 914                            :displaced-index-offset 1)))
 915     (assert (equal (parse-namestring disp) #p"SYS:ABC.LISP"))))
 916
 917 ;;; LOGICAL-PATHAME was missing the specialized pathname comparator
 918 ;;; function in SB_KERNEL::LAYOUT-EQUALP-IMPL
 919 (with-test (:name :logical-pathname-equalp-method)
 920   ;; PATHNAME is not a structure-object but uses the instance EQUALP case.
 921   (checked-compile-and-assert
 922       ()
 923       `(lambda (x y)
 924          (equalp x y))
 925     (((make-pathname) (make-pathname :version :newest)) t))
 926   (let ((s "#p\"sys:contrib/f[1-9].txt\""))
 927     (let ((a (read-from-string s)))
 928       ;; FIXME: maybe this test is bogus now?
 929       ;; ("result shouldn't depend on the pathnames being EQ")
 930       (sb-impl:hashset-remove sb-impl::*pn-table* a)
 931       (let ((b (read-from-string s)))
 932         (assert (not (eq a b)))
 933         (equalp a b)))))
 934
 935 ;;; After the change which added address-based hashing to all INSTANCE types,
 936 ;;; someone forgot to ensure that address-based hashes were not used on
 937 ;;; PATTERN instances which can comprise the subcomponents of a pathname.
 938 ;;; So make sure the hash is based on the string contents of the pattern.
 939 ;;; Read pathnames from strings to guarantee that some magic effect of reading
 940 ;;; pathnames doesn't coalesce them. To be especially certain, zap the cache
 941 ;;; of pathnames between the read-from-string calls.
 942 (with-test (:name :wild-pathnames-string-based-hash)
 943   (let ((string "#p\"file[0-9].txt\""))
 944     (let ((a (read-from-string string)))
 945       (sb-impl:hashset-remove sb-impl::*pn-table* a)
 946       (let ((b (read-from-string string)))
 947         (assert (not (eq a b)))
 948         (assert (eql (sxhash a) (sxhash b)))))))
 949
 950 (with-test (:name :cfp-examples)
 951   (let ((*default-pathname-defaults* #p""))
 952     (assert (equal (compile-file-pathname "a/b/srcfile.lsp" :output-file "build/bin/")
 953                    #P"build/bin/srcfile.fasl"))
 954     (assert (equal (compile-file-pathname "a/b/srcfile.lsp" :output-file "build/bin/f")
 955                    #P"build/bin/f.fasl"))
 956     (assert (equal (compile-file-pathname "a/b/srcfile.lsp" :output-file "build/bin/foo.tmp")
 957                    #P"build/bin/foo.tmp"))
 958     (assert (equal (compile-file-pathname "a/b/srcfile.lsp")
 959                    #P"a/b/srcfile.fasl"))))
 960
 961 (with-test (:name :intern-pathname-non-consy
 962             :skipped-on :interpreter)
 963   (ctu:assert-no-consing (make-pathname :name "hi" :type "txt")))
 964
 965 (defun pathname-peristence-test ()
 966   ;; This probably isn't something that users expect to be able to work,
 967   ;; but I want (rather "need") it to.
 968   (sb-int:dx-let ((s (make-string 6)))
 969     (replace s "mytype")
 970     (make-pathname :name "fred" :type s)))
 971 (compile 'pathname-peristence-test)
 972
 973 (with-test (:name :dx-pathname-parts-dont-crash)
 974   (prin1 (pathname-peristence-test)))
 975
 976 (with-test (:name :internal-pathname-hash-incorporates-version)
 977   (opaque-identity
 978    (loop for i below 1000
 979          collect (make-pathname :host "SYS" :name "FOO" :type "LISP" :version i))))
 980
 981 (with-test (:name :pathname-hash-more-strongly)
 982   ;; examples from xof's email
 983   (assert (/= (sxhash #P"APPVA") (sxhash #P"APPKZ")))
 984   (assert (/= (sxhash #P"AVERA") (sxhash #P"AVEQR")))
 985   (assert (/= (sxhash #P"AVERB") (sxhash #P"AVEQS")))
 986   ;; still more
 987   (assert (/= (sxhash #P"a[bc]d?x") (sxhash #P"a[bc]d?z"))))