source: trunk/abcl/test/lisp/abcl/pathname-tests.lisp @ 13373

Last change on this file since 13373 was 13373, checked in by Mark Evenson, 10 years ago

PATHNAME.URI-ENCODING.1 is not actually failing.

But PATHNAME.URI-ENCODING.2 definitely is, which should be addressed.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 53.4 KB
Line 
1;;; pathname-tests.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;; $Id: pathname-tests.lisp 13373 2011-07-04 14:03:33Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package #:abcl.test.lisp)
21
22(defun check-physical-pathname (pathname expected-directory expected-name expected-type)
23  (let* ((directory (pathname-directory pathname))
24         (name (pathname-name pathname))
25         (type (pathname-type pathname))
26         (ok t))
27    (unless (and (pathnamep pathname)
28                 (not (typep pathname 'logical-pathname)))
29      (setf ok nil))
30    (unless (and (equal directory expected-directory)
31                 (equal name expected-name)
32                 (equal type expected-type))
33      (setf ok nil))
34    ok))
35
36(defun check-windows-pathname (pathname expected-host expected-device
37                                        expected-directory expected-name
38                                        expected-type)
39  (let* ((host (pathname-host pathname))
40         (device (pathname-device pathname))
41         (directory (pathname-directory pathname))
42         (name (pathname-name pathname))
43         (type (pathname-type pathname))
44         (ok t))
45    (unless (and (pathnamep pathname)
46                 (not (typep pathname 'logical-pathname)))
47      (setf ok nil))
48    (unless (and (equal host expected-host)
49                 (equal device expected-device)
50                 (equal directory expected-directory)
51                 (equal name expected-name)
52                 (equal type expected-type))
53      (setf ok nil))
54    ok))
55
56(defun check-logical-pathname (pathname expected-host expected-directory
57                                        expected-name expected-type
58                                        expected-version)
59  (let* ((host (pathname-host pathname))
60         (directory (pathname-directory pathname))
61         (name (pathname-name pathname))
62         (type (pathname-type pathname))
63         (version (pathname-version pathname))
64         ;; Allegro's logical pathnames don't canonicalize their string
65         ;; components to upper case.
66         (test #-allegro 'equal
67               #+allegro 'equalp)
68         (ok t))
69    (unless (typep pathname 'logical-pathname)
70      (setf ok nil))
71    ;; "The device component of a logical pathname is always :UNSPECIFIC..." 19.3.2.1
72    #-allegro ;; Except on Allegro, where it's NIL.
73    (unless (eq (pathname-device pathname) :unspecific)
74      (setf ok nil))
75    (unless (and (funcall test (if (stringp host) host
76                                    (host-namestring pathname))
77                          expected-host)
78                 (funcall test directory expected-directory)
79                 (funcall test name expected-name)
80                 (funcall test type expected-type)
81                 (eql version expected-version))
82      (setf ok nil))
83    ok))
84
85(defun check-merge-pathnames (pathname default-pathname expected-result)
86  (let* ((result (merge-pathnames pathname default-pathname))
87         (test #-allegro 'equal
88               #+allegro (if (typep result 'logical-pathname)
89                             'equalp
90                             'equal)))
91    (and (funcall test (pathname-host result) (pathname-host expected-result))
92         (funcall test (pathname-directory result) (pathname-directory expected-result))
93         (funcall test (pathname-name result) (pathname-name expected-result))
94         (funcall test (pathname-type result) (pathname-type expected-result)))))
95
96(defun check-translate-pathname (args expected)
97  (declare (optimize safety))
98  (declare (type list args))
99  (declare (type string expected))
100  (let ((result (namestring (apply 'translate-pathname args))))
101    (equal result
102           ;;#-windows
103           expected
104           ;;#+windows (substitute #\\ #\/ expected)
105           )))
106
107(defmacro check-readable (pathname)
108  `(equal ,pathname (read-from-string (write-to-string ,pathname :readably t))))
109
110(defun check-readable-or-signals-error (pathname)
111  (handler-case
112      (equal pathname (read-from-string (write-to-string pathname :readably t)))
113    (print-not-readable () t)))
114
115(defmacro check-namestring (pathname namestring)
116  `(string= (namestring ,pathname)
117            ;;#+windows (substitute #\\ #\/ ,namestring)
118            ;;#-windows
119            ,namestring))
120
121;; Define a logical host.
122(setf (logical-pathname-translations "effluvia")
123      '(("**;*.*.*" "/usr/local/**/*.*")))
124
125(deftest equal.1
126  (equal (make-pathname :name "foo" :type "bar")
127         (make-pathname :name "foo" :type "bar"))
128  t)
129
130(deftest equal.2
131  (equal (make-pathname :name "foo" :type "bar" :version nil)
132         (make-pathname :name "foo" :type "bar" :version :newest))
133  #+(or clisp lispworks) nil
134  #-(or clisp lispworks) t)
135
136(deftest sxhash.1
137  (let* ((p (make-pathname :name "foo" :type "bar" :version nil))
138         (s (sxhash p)))
139    (values (typep s 'fixnum)
140            (>= s 0)))
141  t t)
142
143;; "(equal x y) implies (= (sxhash x) (sxhash y))"
144(deftest sxhash.2
145  (let ((p1 (make-pathname :name "foo" :type "bar" :version nil))
146        (p2 (make-pathname :name "foo" :type "bar" :version :newest)))
147    (if (equal p1 p2)
148        (= (sxhash p1) (sxhash p2))
149        t))
150  t)
151
152;; It's suboptimal if all pathnames return the same SXHASH, but that happens
153;; with SBCL.
154(deftest sxhash.3
155  (= (sxhash #p"/usr/local/bin/sbcl") (sxhash #p"") (sxhash #p"foo.bar"))
156  #+sbcl t
157  #-sbcl nil)
158
159;; "Parsing a null string always succeeds, producing a pathname with all
160;; components (except the host) equal to nil."
161(deftest physical.1
162  (check-physical-pathname #p"" nil nil nil)
163  t)
164
165(deftest physical.2
166  (check-physical-pathname #p"/" '(:absolute) nil nil)
167  t)
168
169(deftest physical.3
170  (check-physical-pathname #p"/foo" '(:absolute) "foo" nil)
171  t)
172
173(deftest physical.4
174  #-lispworks
175  (check-physical-pathname #p"/foo." '(:absolute) "foo" "")
176  #+lispworks
177  (check-physical-pathname #p"/foo." '(:absolute) "foo." nil)
178  t)
179
180(deftest physical.5
181  (check-physical-pathname #p"/foo.bar" '(:absolute) "foo" "bar")
182  t)
183
184(deftest physical.6
185  #-lispworks
186  (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar" "")
187  #+lispworks
188  (check-physical-pathname #p"/foo.bar." '(:absolute) "foo.bar." nil)
189  t)
190
191(deftest physical.7
192  (check-physical-pathname #p"/foo.bar.baz" '(:absolute) "foo.bar" "baz")
193  t)
194
195(deftest physical.8
196  (check-physical-pathname #p"/foo/bar" '(:absolute "foo") "bar" nil)
197  t)
198
199(deftest physical.9
200  (check-physical-pathname #p"/foo..bar" '(:absolute) "foo." "bar")
201  t)
202
203(deftest physical.10
204  (check-physical-pathname #p"foo.bar" nil "foo" "bar")
205  t)
206
207(deftest physical.11
208  (check-physical-pathname #p"foo.bar.baz" nil "foo.bar" "baz")
209  t)
210
211(deftest physical.12
212  (check-physical-pathname #p"foo/" '(:relative "foo") nil nil)
213  t)
214
215(deftest physical.13
216  (check-physical-pathname #p"foo/bar" '(:relative "foo") "bar" nil)
217  t)
218
219(deftest physical.14
220  (check-physical-pathname #p"foo/bar/baz" '(:relative "foo" "bar") "baz" nil)
221  t)
222
223(deftest physical.15
224  (check-physical-pathname #p"foo/bar/" '(:relative "foo" "bar") nil nil)
225  t)
226
227#+allegro
228(deftest physical.16
229  ;; This reduction is wrong.
230  (check-physical-pathname #p"foo/bar/.." '(:relative "foo") nil nil)
231  t)
232
233#+allegro
234(deftest physical.17
235  (check-physical-pathname #p"/foo/../" '(:absolute) nil nil)
236  t)
237
238(deftest physical.18
239  #-lispworks
240  (check-physical-pathname #p".lisprc" nil ".lisprc" nil)
241  #+lispworks
242  (check-physical-pathname #p".lisprc" nil "" "lisprc")
243  t)
244
245(deftest physical.19
246  (check-physical-pathname #p"x.lisprc" nil "x" "lisprc")
247  t)
248
249(deftest physical.20
250  #-allegro
251  (check-physical-pathname (make-pathname :name ".") nil "." nil)
252  #+allegro
253  (check-physical-pathname (make-pathname :name ".") '(:relative) nil nil)
254  t)
255
256(deftest physical.21
257  #-cmu
258  (check-readable (make-pathname :name "."))
259  #+cmu
260  (check-readable-or-signals-error (make-pathname :name "."))
261  t)
262#+(or cmu lispworks (and allegro windows))
263(pushnew 'physical.21 *expected-failures*)
264
265;; #p"."
266(deftest physical.22
267  #+(or allegro abcl cmu)
268  (check-physical-pathname #p"." '(:relative) nil nil)
269  #-(or allegro abcl cmu)
270  ;; No trailing separator character means it's a file.
271  (check-physical-pathname #p"." nil "." nil)
272  t)
273#+lispworks
274(pushnew 'physical.22 *expected-failures*)
275
276(deftest namestring.1
277  (check-namestring #p"."
278                    #+(or abcl allegro cmu) "./"
279                    #-(or abcl allegro cmu) ".")
280  t)
281#+lispworks
282(pushnew 'namestring.1 *expected-failures*)
283
284(deftest physical.23
285  (equal #p"." #p"")
286  nil)
287#+lispworks
288(pushnew 'physical.23 *expected-failures*)
289
290;; #p"./"
291;; Trailing separator character means it's a directory.
292(deftest physical.24
293  (let ((pathname #-windows #p"./"
294                  #+windows #p".\\"))
295    #-(or sbcl)
296    (check-physical-pathname pathname '(:relative) nil nil)
297    #+(or sbcl)
298    ;; Is this more exact?
299    (check-physical-pathname pathname '(:relative ".") nil nil))
300  t)
301#+(or lispworks (and allegro windows))
302(pushnew 'physical.24 *expected-failures*)
303
304(deftest namestring.2
305  (check-namestring #-windows #p"./"
306                    #+windows #p".\\"
307                    "./")
308  t)
309#+lispworks
310(pushnew 'namestring.2 *expected-failures*)
311
312(deftest directory-namestring.1
313  (equal (directory-namestring #p"./")
314         "./")
315  t)
316#+lispworks
317(pushnew 'directory-namestring.1 *expected-failures*)
318
319(deftest physical.25
320  (equal #-windows #p"./"
321         #+windows #p".\\"
322         #p"")
323  nil)
324#+(or lispworks (and allegro windows))
325(pushnew 'physical.25 *expected-failures*)
326
327(deftest physical.26
328  #-allegro
329  (check-physical-pathname (make-pathname :name "..") nil ".." nil)
330  #+allegro
331  (check-physical-pathname (make-pathname :name "..") '(:relative :back) nil nil)
332  t)
333
334#-(or sbcl)
335(deftest physical.27
336  #-cmu
337  (check-readable (make-pathname :name ".."))
338  #+cmu
339  (check-readable-or-signals-error (make-pathname :name ".."))
340  t)
341#+(or clisp cmu lispworks)
342(pushnew 'physical.27 *expected-failures*)
343
344;; #p".."
345(deftest physical.28
346  #+(or allegro (and lispworks windows))
347  (check-physical-pathname #p".." '(:relative :back) nil nil)
348  #+(or abcl cmu (and lispworks unix))
349  (check-physical-pathname #p".." '(:relative :up) nil nil)
350  ;; Other implementations think it's a file.
351  #+(or)
352  ;; If it's a file, to a human its name would be "..". No implementation gets
353  ;; this right.
354  (check-physical-pathname #p".." nil ".." nil)
355  #+(or sbcl clisp)
356  ;; These implementations parse ".." as the name "." followed by another dot and
357  ;; the type string "", which no human would do.
358  (check-physical-pathname #p".." nil "." "")
359  t)
360#+cmu
361(pushnew 'physical.28 *expected-failures*)
362
363(deftest namestring.3
364  (check-namestring #p".."
365                    #+(or abcl allegro cmu lispworks) "../"
366                    #-(or abcl allegro cmu lispworks) "..")
367  t)
368
369;; #p"../"
370(deftest physical.29
371  (let ((pathname #-windows #p"../"
372                  #+windows #p"..\\"))
373    #+(or allegro (and lispworks windows))
374    (check-physical-pathname pathname '(:relative :back) nil nil)
375    #+(or abcl sbcl cmu clisp (and lispworks unix))
376    (check-physical-pathname pathname '(:relative :up) nil nil))
377  t)
378
379(deftest namestring.4
380  (check-namestring #-windows #p"../"
381                    #+windows #p"..\\"
382                    "../")
383  t)
384
385(deftest directory-namestring.2
386  (equal (directory-namestring #-windows #p"../"
387                               #+windows #p"..\\")
388         "../")
389  t)
390
391#-sbcl
392(deftest physical.30
393  #-(or allegro cmu)
394  (string= (namestring (make-pathname :name "..")) "..")
395  #+allegro
396  (string= (namestring (make-pathname :name ".."))
397           #-windows "../"
398           #+windows "..\\")
399  #+cmu
400  (signals-error (make-pathname :name "..") 'warning)
401  t)
402
403(deftest physical.31
404  (string= (namestring (make-pathname :directory '(:relative :up)))
405           "../")
406  t)
407
408#+windows
409(deftest windows.1
410  (equal #p"/foo/bar/baz" #p"\\foo\\bar\\baz")
411  t)
412
413#+windows
414(deftest windows.2
415  (let ((pathname #p"foo.bar"))
416    (check-windows-pathname pathname nil nil nil "foo" "bar"))
417  t)
418
419#+windows
420(deftest windows.3
421  (let ((pathname #p"\\foo.bar"))
422    (check-windows-pathname pathname nil nil '(:absolute) "foo" "bar"))
423  t)
424
425#+windows
426(deftest windows.4
427  (let ((pathname #p"c:\\foo.bar"))
428    #+(or abcl allegro)
429    (check-windows-pathname pathname nil "c" '(:absolute) "foo" "bar")
430    #+clisp
431    (check-windows-pathname pathname nil "C" '(:absolute) "foo" "bar")
432    #+lispworks
433    (check-windows-pathname pathname "c" nil '(:absolute) "foo" "bar"))
434  t)
435
436#+windows
437(deftest windows.5
438  (equal #p"c:\\foo.bar" #p"C:\\FOO.BAR")
439  t)
440
441#+windows
442(deftest pathname.windows.6
443   (equal (pathname-device #p"z:/foo/bar") "z")
444  t)
445
446#+windows
447(deftest pathname.windows.7
448    (equal (pathname-device #p"file:z:/foo/bar") "z")
449  t)
450
451#+windows
452(deftest pathname.windows.8
453    (equal (pathname-device #p"zoo:/foo/bar") nil)
454  t)
455
456(deftest wild.1
457  (check-physical-pathname #p"foo.*" nil "foo" :wild)
458  t)
459
460(deftest wild.2
461  (check-physical-pathname #p"*.*" nil :wild :wild)
462  t)
463
464(deftest wild.3
465  #-(or cmu sbcl)
466  (check-physical-pathname #p"abc*" nil "abc*" nil)
467  #+(or cmu sbcl)
468  (wild-pathname-p #p"abc*")
469  t)
470
471(deftest wild.4
472  #-(or cmu sbcl)
473  (check-physical-pathname #p"abc?" nil "abc?" nil)
474  #+(or cmu sbcl)
475  (wild-pathname-p #p"abc?")
476  t)
477
478(deftest wild.5
479  #-(or cmu sbcl)
480  (check-physical-pathname #p"abc[d-h]" nil "abc[d-h]" nil)
481  #+(or cmu sbcl)
482  (wild-pathname-p #p"abc[d-h]")
483  t)
484
485;; Lots of dots.
486#+(or allegro abcl cmu)
487(deftest lots-of-dots.1
488  (check-physical-pathname #p"..." nil "..." nil)
489  t)
490#+cmu
491(pushnew 'lots-of-dots.1 *expected-failures*)
492
493#+(or allegro abcl cmu)
494(deftest lots-of-dots.2
495  (check-physical-pathname #p"......" nil "......" nil)
496  t)
497#+cmu
498(pushnew 'lots-of-dots.2 *expected-failures*)
499
500;; Silly names.
501#-(or allegro sbcl)
502(deftest silly.1
503  #+(or abcl clisp)
504  (signals-error (make-pathname :name "abc/def") 'error)
505  #-(or abcl clisp)
506  (check-readable (make-pathname :name "abc/def"))
507  t)
508#+(or cmu lispworks)
509(pushnew 'silly.1 *expected-failures*)
510
511(deftest silly.2
512  (signals-error (make-pathname :name "abc/def")
513                 #-cmu 'error
514                 #+cmu 'warning)
515  t)
516
517(deftest silly.3
518  (check-readable-or-signals-error (make-pathname :name ".foo"))
519  t)
520
521(deftest silly.4
522  (check-readable-or-signals-error (make-pathname :type ".foo"))
523  t)
524
525(deftest silly.5
526  (check-readable-or-signals-error (make-pathname :name "abc.def"))
527  t)
528
529(deftest silly.6
530  (check-readable-or-signals-error (make-pathname :type "abc.def"))
531  t)
532
533;; LOGICAL-PATHNAME-TRANSLATIONS
534#-allegro
535(deftest logical-pathname-translations.1
536  #+(or sbcl cmu lispworks)
537  (equal (logical-pathname-translations "effluvia")
538         '(("**;*.*.*" "/usr/local/**/*.*")))
539  #+clisp
540  (equal (logical-pathname-translations "effluvia")
541         '((#p"EFFLUVIA:**;*.*.*" "/usr/local/**/*.*")))
542  #+abcl
543  (equal (logical-pathname-translations "effluvia")
544         '((#p"EFFLUVIA:**;*.*.*" #p"/usr/local/**/*.*")))
545  t)
546
547;; "The null string, "", is not a valid value for any component of a logical
548;; pathname." 19.3.2.2
549(deftest logical-pathname.1
550  #-clisp
551  (signals-error (logical-pathname ":") 'error)
552  #+clisp
553  (check-logical-pathname (logical-pathname ":") "" '(:absolute) nil nil nil)
554  t)
555
556;; Parse error.
557(deftest logical-pathname.2
558  (signals-error (logical-pathname "effluvia::foo.bar")
559                 #-(or allegro clisp) 'parse-error
560                 #+(or allegro clisp) 'type-error)
561  t)
562
563;; If the prefix isn't a defined logical host, it's not a logical pathname.
564#-(or cmu (and clisp windows))
565;; CMUCL parses this as (:ABSOLUTE #<SEARCH-LIST foo>) "bar.baz" "42".
566;; CLISP signals a parse error reading #p"foo:bar.baz.42".
567(deftest logical.1
568  (let ((pathname #p"foo:bar.baz.42"))
569    #+allegro
570    ;; Except in Allegro.
571    (check-logical-pathname pathname "foo" nil "bar" "baz" nil)
572    #-allegro
573    (check-physical-pathname pathname nil "foo:bar.baz" "42"))
574  t)
575#+lispworks
576(pushnew 'logical.1 *expected-failures*)
577
578#+sbcl
579(deftest logical.2
580  ;; Even though "effluvia" is defined as a logical host, "bop" is not a valid
581  ;; logical pathname version, so this can't be a logical pathname.
582  (check-physical-pathname #p"effluvia:bar.baz.bop" nil "effluvia:bar.baz" "bop")
583  t)
584
585(deftest logical.3
586  #-allegro
587  (check-logical-pathname (make-pathname :defaults "effluvia:foo.lisp")
588                          "EFFLUVIA" '(:absolute) "FOO" "LISP" nil)
589  #+allegro
590  (check-logical-pathname (make-pathname :defaults "effluvia:foo.lisp")
591                          "effluvia" nil "foo" "lisp" nil)
592  t)
593
594#-allegro
595(deftest logical.4
596  (check-logical-pathname #p"effluvia:bar.baz.42" "EFFLUVIA" '(:absolute) "BAR" "BAZ" 42)
597  t)
598
599#-allegro
600(deftest logical.5
601  (string= (write-to-string #p"effluvia:bar.baz.42" :escape t)
602           "#P\"EFFLUVIA:BAR.BAZ.42\"")
603  t)
604
605#+allegro
606;; Allegro returns NIL for the device and directory and drops the version
607;; entirely (even from the namestring).
608(deftest logical.6
609  (check-logical-pathname #p"effluvia:bar.baz.42" "effluvia" nil "bar" "baz" nil)
610  t)
611
612#+allegro
613(deftest logical.7
614  (string= (write-to-string #p"effluvia:bar.baz" :escape t)
615           #+allegro-v6.2 "#p\"effluvia:bar.baz\""
616           #+allegro-v7.0 "#P\"effluvia:bar.baz\"")
617  t)
618
619(deftest logical.8
620  (typep (parse-namestring "**;*.*.*" "effluvia") 'logical-pathname)
621  t)
622
623(deftest logical.9
624  (check-namestring (parse-namestring "**;*.*.*" "effluvia")
625                    #-(or allegro lispworks)
626                    "EFFLUVIA:**;*.*.*"
627                    #+allegro
628                    ;; Allegro preserves case and drops the version component.
629                    "effluvia:**;*.*"
630                    #+lispworks
631                    "effluvia:**;*.*.*")
632  t)
633
634#-allegro
635;; The version can be a bignum.
636(deftest logical.10
637  (check-logical-pathname #p"effluvia:bar.baz.2147483648" "EFFLUVIA" '(:absolute) "BAR" "BAZ" 2147483648)
638  t)
639
640#-allegro
641(deftest logical.11
642  (check-namestring #p"effluvia:bar.baz.2147483648" "EFFLUVIA:BAR.BAZ.2147483648")
643  t)
644#+sbcl
645;; SBCL has a bug when the version is a bignum.
646(pushnew 'logical.11 *expected-failures*)
647
648(deftest logical.12
649  (check-namestring #p"effluvia:foo.bar.newest"
650                    #-allegro "EFFLUVIA:FOO.BAR.NEWEST"
651                    #+allegro "effluvia:foo.bar")
652  t)
653
654(deftest logical.13
655  #-allegro
656  (check-logical-pathname #p"effluvia:foo.*" "EFFLUVIA" '(:absolute) "FOO" :wild nil)
657  #+allegro
658  (check-logical-pathname #p"effluvia:foo.*" "effluvia" nil "foo" :wild nil)
659  t)
660
661(deftest logical.14
662  #-allegro
663  (check-logical-pathname #p"effluvia:*.lisp" "EFFLUVIA" '(:absolute) :wild "LISP" nil)
664  #+allegro
665  (check-logical-pathname #p"effluvia:*.lisp" "effluvia" nil :wild "lisp" nil)
666  t)
667
668(deftest logical.15
669  #-allegro
670  (check-logical-pathname #p"effluvia:bar.baz.newest" "EFFLUVIA" '(:absolute) "BAR" "BAZ" :newest)
671  #+allegro
672  (check-logical-pathname #p"effluvia:bar.baz.newest" "effluvia" nil "bar" "baz" nil)
673  t)
674
675(deftest logical.16
676  #-allegro
677  (check-logical-pathname #p"EFFLUVIA:BAR.BAZ.NEWEST" "EFFLUVIA" '(:absolute) "BAR" "BAZ" :newest)
678  #+allegro
679  (check-logical-pathname #p"EFFLUVIA:BAR.BAZ.NEWEST" "EFFLUVIA" nil "BAR" "BAZ" nil)
680  t)
681
682;; The directory component.
683(deftest logical.17
684  (check-logical-pathname #p"effluvia:foo;bar.baz" "EFFLUVIA" '(:absolute "FOO") "BAR" "BAZ" nil)
685  t)
686
687(deftest logical.18
688  (check-namestring #p"effluvia:foo;bar.baz"
689                    #-allegro "EFFLUVIA:FOO;BAR.BAZ"
690                    #+allegro "effluvia:foo;bar.baz")
691  t)
692
693(deftest logical.19
694  #-allegro
695  (check-logical-pathname #p"effluvia:;bar.baz" "EFFLUVIA" '(:relative) "BAR" "BAZ" nil)
696  #+allegro
697  ;; Allegro drops the directory component and removes the semicolon from the
698  ;; namestring.
699  (check-logical-pathname #p"effluvia:;bar.baz" "EFFLUVIA" nil "BAR" "BAZ" nil)
700  t)
701
702(deftest logical.20
703  (check-namestring #p"effluvia:;bar.baz"
704                    #+allegro "effluvia:bar.baz"
705                    #-allegro "EFFLUVIA:;BAR.BAZ")
706  t)
707
708;; "If a relative-directory-marker precedes the directories, the directory
709;; component parsed is as relative; otherwise, the directory component is
710;; parsed as absolute."
711(deftest logical.21
712  (equal (pathname-directory #p"effluvia:foo.baz")
713         #-allegro '(:absolute)
714         #+allegro nil)
715  t)
716
717(deftest logical.22
718  (typep  #p"effluvia:" 'logical-pathname)
719  t)
720
721(deftest logical.23
722  (equal (pathname-directory #p"effluvia:")
723         #-allegro '(:absolute)
724         #+allegro nil)
725  t)
726
727;; PARSE-NAMESTRING
728(deftest parse-namestring.1
729  #-allegro
730  (check-logical-pathname (parse-namestring "effluvia:foo.bar")
731                          "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
732  #+allegro
733  (check-logical-pathname (parse-namestring "effluvia:foo.bar")
734                          "effluvia" nil "foo" "bar" nil)
735  t)
736
737(deftest parse-namestring.2
738  (let ((pathname (parse-namestring "foo.bar" "effluvia")))
739    #-(or allegro lispworks)
740    (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
741    #+allegro
742    (check-logical-pathname pathname "effluvia" nil "foo" "bar" nil)
743    #+lispworks
744    (check-logical-pathname pathname "effluvia" '(:absolute) "FOO" "BAR" nil))
745  t)
746
747(deftest parse-namestring.3
748  (let ((pathname (parse-namestring "foo;bar;baz.fas.3" "effluvia")))
749    #-(or allegro lispworks)
750    (check-logical-pathname pathname "EFFLUVIA" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3)
751    #+allegro
752    (check-logical-pathname pathname "effluvia" '(:absolute "foo" "bar") "baz" "fas" nil)
753    #+lispworks
754    (check-logical-pathname pathname "effluvia" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3)
755    )
756  t)
757
758(deftest parse-namestring.4
759  #-(or abcl clisp cmu lispworks (and allegro windows))
760  (check-physical-pathname (parse-namestring "effluvia:foo.bar" "")
761                           nil "effluvia:foo" "bar")
762  #+abcl
763  ;; Invalid logical host name: ""
764  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
765  #+(or clisp lispworks)
766  ;; Host mismatch.
767  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
768  #+cmu
769  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
770  #+(and allegro windows)
771  ;; "effluvia" is the device
772  (check-physical-pathname (parse-namestring "effluvia:foo.bar" "")
773                           nil "foo" "bar")
774  t)
775
776;; "If host is nil and thing is a syntactically valid logical pathname
777;; namestring containing an explicit host, then it is parsed as a logical
778;; pathname namestring."
779(deftest parse-namestring.5
780  #-allegro
781  (check-logical-pathname (parse-namestring "effluvia:foo.bar" nil)
782                          "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
783  #+allegro
784  (check-logical-pathname (parse-namestring "effluvia:foo.bar" nil)
785                          "effluvia" nil "foo" "bar" nil)
786  t)
787
788;; "If host is nil, default-pathname is a logical pathname, and thing is a
789;; syntactically valid logical pathname namestring without an explicit host,
790;; then it is parsed as a logical pathname namestring on the host that is the
791;; host component of default-pathname."
792(deftest parse-namestring.6
793  #-allegro
794  (check-logical-pathname (parse-namestring "foo" nil #p"effluvia:bar")
795                          "EFFLUVIA" '(:absolute) "FOO" nil nil)
796  #+allegro
797  (check-logical-pathname (parse-namestring "foo" nil #p"effluvia:bar")
798                          "effluvia" nil "foo" nil nil)
799  t)
800
801(deftest parse-namestring.7
802  (let* ((*default-pathname-defaults* (logical-pathname "EFFLUVIA:"))
803         (pathname (parse-namestring "foo.bar")))
804    #-allegro
805    (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
806    #+allegro
807    (check-logical-pathname pathname "effluvia" nil "foo" "bar" nil))
808  t)
809
810(deftest parse-namestring.8
811  (let* ((*default-pathname-defaults* #p"effluvia:bar")
812         (pathname (parse-namestring "foo" nil)))
813    #-allegro
814    (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" nil nil)
815    #+allegro
816    (check-logical-pathname pathname "effluvia" nil "foo" nil nil))
817  t)
818
819;; WILD-PATHNAME-P
820(deftest wild-pathname-p.1
821  (wild-pathname-p #p"effluvia:;*.baz")
822  #+(or cmu sbcl) (:wild :wild-inferiors)
823  #-(or cmu sbcl) t)
824
825;; PATHNAME-MATCH-P
826(deftest pathname-match-p.1
827  (pathname-match-p "/foo/bar/baz" "/*/*/baz")
828  t)
829
830(deftest pathname-match-p.2
831  (pathname-match-p "/foo/bar/baz" "/**/baz")
832  t)
833
834(deftest pathname-match-p.3
835  (pathname-match-p "/foo/bar/quux/baz" "/**/baz")
836  t)
837
838(deftest pathname-match-p.4
839  (pathname-match-p "foo.bar" "/**/*.*")
840  t)
841
842(deftest pathname-match-p.5
843  (pathname-match-p "/usr/local/bin/foo.bar" "/**/foo.bar")
844  t)
845
846(deftest pathname-match-p.6
847  (pathname-match-p "/usr/local/bin/foo.bar" "**/foo.bar")
848  nil)
849
850(deftest pathname-match-p.7
851  (pathname-match-p "/foo/bar.txt" "/**/*.*")
852  t)
853
854(deftest pathname-match-p.8
855  (pathname-match-p "/foo/bar.txt" "**/*.*")
856  nil)
857
858(deftest pathname-match-p.9
859  (pathname-match-p #p"effluvia:foo.bar" #p"effluvia:**;*.*.*")
860  t)
861
862(deftest pathname-match-p.10
863  (pathname-match-p "foo" "foo.*")
864  t)
865
866;; TRANSLATE-PATHNAME
867(deftest translate-pathname.1
868  #-clisp
869  (equal (translate-pathname "foo" "*" "bar") #p"bar")
870  #+clisp
871  (signals-error (translate-pathname "foo" "*" "bar") 'error)
872  t)
873
874(deftest translate-pathname.2
875  (equal (translate-pathname "foo" "*" "*")   #p"foo")
876  t)
877
878(deftest translate-pathname.3
879  #-abcl
880  (string= (pathname-name (translate-pathname "foobar" "*" "foo*"))
881           #-allegro-v7.0 "foofoobar"
882           #+allegro-v7.0 "foo*")
883  #+abcl
884  ;; ABCL doesn't implement this translation. Verify that it signals an error.
885  (signals-error (translate-pathname "foobar" "*" "foo*") 'error)
886  t)
887
888(deftest translate-pathname.4
889  #-abcl
890  (equal (translate-pathname "foobar" "foo*" "*baz")
891         #-allegro-v7.0 #p"barbaz"
892         #+allegro-v7.0 #p"*baz")
893  #+abcl
894  ;; ABCL doesn't implement this translation. Verify that it signals an error.
895  (signals-error (translate-pathname "foobar" "foo*" "*baz") 'error)
896  t)
897
898(deftest translate-pathname.5
899  #-abcl
900  (equal (translate-pathname "foobar" "foo*" "")
901         #+(or allegro clisp) #p"bar"
902         #+(or cmu sbcl lispworks) #p"foobar")
903  #+abcl
904  ;; ABCL doesn't implement this translation. Verify that it signals an error.
905  (signals-error (translate-pathname "foobar" "foo*" "") 'error)
906  t)
907
908(deftest translate-pathname.6
909  (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz")
910  t)
911
912(deftest translate-pathname.7
913  (equal (translate-pathname "bar/foo" "bar/*" "baz/*") #p"baz/foo")
914  t)
915
916(deftest translate-pathname.8
917  (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz")
918  t)
919
920(deftest translate-pathname.9
921  (string= (namestring (translate-pathname "test.txt" "*.txt" "*.text"))
922           "test.text")
923  t)
924
925(deftest translate-pathname.10
926  (equal (translate-pathname "foo" "foo.*" "bar") #p"bar")
927  t)
928
929(deftest translate-pathname.11
930  (equal (translate-pathname "foo" "foo.*" "bar.*") #p"bar")
931  t)
932
933(deftest translate-pathname.12
934  (string= (namestring (translate-pathname "foo.bar" "*.*" "/usr/local/*.*"))
935           "/usr/local/foo.bar")
936  t)
937
938(deftest translate-pathname.13
939  (equal (translate-pathname "foo.bar" "*.*" "/usr/local/*.*")
940         #p"/usr/local/foo.bar")
941  t)
942
943(deftest translate-pathname.14
944  (check-translate-pathname '("/foo/" "/*/" "/usr/local/*/") "/usr/local/foo/")
945  t)
946
947(deftest translate-pathname.15
948  (check-translate-pathname '("/foo/baz/bar.txt" "/**/*.*" "/usr/local/**/*.*")
949                            "/usr/local/foo/baz/bar.txt")
950  t)
951
952(deftest translate-pathname.16
953  (equal (translate-pathname "/foo/" "/*/" "/usr/local/*/bar/") #p"/usr/local/foo/bar/")
954  t)
955
956(deftest translate-pathname.17
957  (equal (translate-pathname "/foo/bar.txt" "/*/*.*" "/usr/local/*/*.*")
958         #P"/usr/local/foo/bar.txt")
959  t)
960
961;; "TRANSLATE-PATHNAME translates SOURCE (that matches FROM-WILDCARD)..."
962(deftest pathname-match-p.11
963  (pathname-match-p "/foo/bar.txt" "**/*.*")
964  nil)
965
966;; Since (pathname-match-p "/foo/bar.txt" "**/*.*" ) => NIL...
967(deftest translate-pathname.18
968  #+(or clisp allegro abcl cmu lispworks)
969  ;; This seems to be the correct behavior.
970  (signals-error (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*") 'error)
971  #+sbcl
972  ;; This appears to be a bug, since SOURCE doesn't match FROM-WILDCARD.
973  (equal (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*")
974         #p"/usr/local/foo/bar.txt")
975  t)
976
977(deftest pathname-match-p.12
978  (pathname-match-p "/foo/bar.txt" "/**/*.*")
979  t)
980
981(deftest translate-pathname.19
982  (equal (translate-pathname "/foo/bar.txt" "/**/*.*" "/usr/local/**/*.*")
983         #p"/usr/local/foo/bar.txt")
984  t)
985
986#-clisp
987(deftest translate-pathname.20
988  (equal (translate-pathname "foo.bar" "/**/*.*" "/usr/local/") #p"/usr/local/foo.bar")
989  t)
990
991;; TRANSLATE-LOGICAL-PATHNAME
992
993;; "PATHNAME is first coerced to a pathname. If the coerced pathname is a
994;; physical pathname, it is returned."
995(deftest translate-logical-pathname.1
996  (equal (translate-logical-pathname #p"/") #p"/")
997  t)
998
999#+(or abcl clisp)
1000(deftest translate-logical-pathname.2
1001  (equal (translate-logical-pathname "effluvia:foo.bar") #p"/usr/local/foo.bar")
1002  t)
1003
1004#+(or sbcl cmu)
1005(deftest translate-logical-pathname.3
1006  ;; Device mismatch.
1007  (and (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar"))
1008           :unspecific)
1009       (eq (pathname-device #p"/usr/local/foo/bar")
1010           nil))
1011  t)
1012
1013(deftest translate-logical-pathname.4
1014  (check-namestring (translate-logical-pathname "effluvia:foo.bar")
1015                    "/usr/local/foo.bar")
1016  t)
1017
1018(deftest translate-logical-pathname.5
1019  (check-namestring (translate-logical-pathname "effluvia:foo;bar.txt")
1020                    "/usr/local/foo/bar.txt")
1021  t)
1022
1023(deftest translate-logical-pathname.6
1024  #-allegro
1025  (check-logical-pathname #p"effluvia:Foo.Bar" "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
1026  #+allegro
1027  ;; Allegro preserves case.
1028  (check-logical-pathname #p"effluvia:Foo.Bar" "effluvia" nil "Foo" "Bar" nil)
1029  t)
1030
1031;; "TRANSLATE-PATHNAME [and thus also TRANSLATE-LOGICAL-PATHNAME] maps
1032;; customary case in SOURCE into customary case in the output pathname."
1033(deftest translate-logical-pathname.7
1034  #-allegro
1035  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
1036                           '(:absolute "usr" "local") "foo" "bar")
1037  #+allegro
1038  ;; Allegro preserves case.
1039  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
1040                           '(:absolute "usr" "local") "Foo" "Bar")
1041  t)
1042
1043(deftest merge-pathnames.1
1044  #-allegro
1045  (check-logical-pathname (merge-pathnames "effluvia:foo.bar")
1046                          "EFFLUVIA" '(:absolute) "FOO" "BAR" :newest)
1047  #+allegro
1048  ;; Allegro's MERGE-PATHNAMES apparently calls TRANSLATE-LOGICAL-PATHNAME.
1049  (check-physical-pathname (merge-pathnames "effluvia:foo.bar")
1050                           '(:absolute "usr" "local") "foo" "bar")
1051  t)
1052
1053(deftest merge-pathnames.2
1054  (equal (merge-pathnames (logical-pathname "effluvia:;foo;bar;")
1055                          (logical-pathname "effluvia:baz;quux.lisp.3"))
1056         #-allegro
1057         (make-pathname :host "EFFLUVIA"
1058                        :device :unspecific
1059                        :directory '(:absolute "BAZ" "FOO" "BAR")
1060                        :name "QUUX"
1061                        :type "LISP"
1062                        :version 3)
1063         #+allegro
1064         (make-pathname :host "effluvia"
1065                        :device nil
1066                        :directory '(:absolute "baz" "foo" "bar")
1067                        :name "quux"
1068                        :type "lisp"
1069                        :version nil)
1070         )
1071  t)
1072
1073(deftest compile-file-pathname.1
1074  (equal (compile-file-pathname "effluvia:foo.lisp")
1075         #+abcl
1076         ;; Is this a bug? (Should version be :NEWEST?)
1077         #p"EFFLUVIA:FOO.ABCL"
1078         #+allegro #p"effluvia:foo.fasl"
1079         #+(or cmu sbcl) #p"EFFLUVIA:FOO.FASL.NEWEST"
1080         #+clisp
1081         ;; Is this a bug?
1082         ;; #p"EFFLUVIA:FOO.fas.NEWEST"
1083         (make-pathname :host "EFFLUVIA" :directory '(:absolute)
1084                        :name "FOO" :type "fas" :version :newest)
1085         #+(and lispworks unix) #p"EFFLUVIA:FOO.UFSL.NEWEST"
1086         #+(and lispworks windows) #p"EFFLUVIA:FOO.FSL.NEWEST")
1087  t)
1088
1089(deftest file-namestring.1
1090  (equal (file-namestring #p"")
1091         #+(or abcl allegro cmu)
1092         nil
1093         #+(or clisp lispworks sbcl)
1094         "")
1095  t)
1096
1097(deftest file-namestring.2
1098  (equal (file-namestring #p"foo") "foo")
1099  t)
1100
1101(deftest file-namestring.3
1102  (let ((pathname (make-pathname :type "foo")))
1103    #+abcl
1104    (equal (file-namestring pathname) nil)
1105    #+allegro
1106    (equal (file-namestring pathname) "NIL.foo") ;; bug
1107    #+(or clisp lispworks)
1108    (equal (file-namestring pathname) ".foo")
1109    #+(or cmu sbcl)
1110    (signals-error (file-namestring pathname) 'error))
1111  t)
1112
1113;; A variant of FILE-NAMESTRING.3 that detects Allegro's bug as a bug.
1114(deftest file-namestring.4
1115  (let ((pathname (make-pathname :type "foo")))
1116    #-(or cmu sbcl)
1117    (not (equal (file-namestring pathname) "NIL.foo"))
1118    #+(or cmu sbcl)
1119    (signals-error (file-namestring pathname) 'error))
1120  t)
1121#+allegro
1122(pushnew 'file-namestring.4 *expected-failures*)
1123
1124(deftest enough-namestring.1
1125  (equal (enough-namestring #p"/foo" #p"/") "foo")
1126  t)
1127#+sbcl
1128(pushnew 'enough-namestring.1 *expected-failures*)
1129
1130(deftest enough-namestring.2
1131  #-windows
1132  (equal (enough-namestring #p"foo/bar" #p"foo") "foo/bar")
1133  #+windows
1134  (equal (enough-namestring #p"foo\\bar" #p"foo") "foo/bar")
1135  t)
1136
1137(deftest enough-namestring.3
1138  (equal (enough-namestring #p"foo/bar" #p"foo/") "bar")
1139  t)
1140#+sbcl
1141(pushnew 'enough-namestring.3 *expected-failures*)
1142
1143;; The following tests are adapted from SBCL's pathnames.impure.lisp.
1144(setf (logical-pathname-translations "demo0")
1145      '(("**;*.*.*" "/tmp/")))
1146(deftest sbcl.1
1147  (pathname-match-p "demo0:file.lisp" (logical-pathname "demo0:tmp;**;*.*.*"))
1148  nil)
1149
1150#-clisp
1151(deftest sbcl.2
1152  (check-namestring (translate-logical-pathname "demo0:file.lisp") "/tmp/file.lisp")
1153  t)
1154
1155(setf (logical-pathname-translations "demo1")
1156      '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
1157;; Remove "**" from the resulting pathname when the source directory is NIL.
1158(deftest sbcl.3
1159  (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
1160         #-windows "/tmp/**/foo.lisp"
1161         #+windows "\\tmp\\**\\foo.lisp")
1162  nil)
1163
1164(deftest sbcl.4
1165  (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp")
1166  t)
1167
1168;;; Check for absolute/relative path confusion.
1169#-allegro
1170(deftest sbcl.5
1171  (pathname-match-p "demo1:;foo.lisp" "demo1:**;*.*.*")
1172  nil)
1173
1174#+(or sbcl cmu)
1175;; BUG Pathnames should match if the following translation is to work.
1176(deftest sbcl.6
1177  (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*")
1178  t)
1179
1180#+clisp
1181(deftest sbcl.7
1182  (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*")
1183  t)
1184
1185(deftest sbcl.8
1186  (check-namestring (translate-logical-pathname "demo1:;foo.lisp")
1187                    #+abcl "/tmp/rel/foo.lisp"
1188                    #+allegro "/tmp/foo.lisp"
1189                    #-(or allegro abcl) "/tmp/rel/foo.lisp")
1190  t)
1191
1192(setf (logical-pathname-translations "demo2")
1193      '(("test;**;*.*" "/tmp/demo2/test")))
1194
1195(deftest sbcl.9
1196  (equal (enough-namestring "demo2:test;foo.lisp")
1197         #+sbcl "DEMO2:;TEST;FOO.LISP"
1198         #+(or abcl cmu lispworks) "DEMO2:TEST;FOO.LISP"
1199         #+allegro-v7.0 "demo2:test;foo.lisp"
1200         #+allegro-v6.2 "/test/foo.lisp" ;; BUG
1201         #+(and clisp unix) "TEST;FOO.LISP"
1202         #+(and clisp windows) "DEMO2:TEST;FOO.LISP")
1203  t)
1204
1205#-(or allegro clisp cmu)
1206(deftest sbcl.10
1207  (signals-error (make-pathname :host "EFFLUVIA" :directory "!bla" :name "bar")
1208                 'error)
1209  t)
1210#-(or allegro cmu)
1211(deftest sbcl.11
1212  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "!bar")
1213                 'error)
1214  t)
1215#-(or allegro cmu)
1216(deftest sbcl.12
1217  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "bar" :type "&baz")
1218                 'error)
1219  t)
1220
1221(deftest sbcl.13
1222  (equal (namestring (parse-namestring "" "EFFLUVIA")) "EFFLUVIA:")
1223  t)
1224
1225(deftest sbcl.14
1226  #-cmu
1227  (equal (namestring (parse-namestring "" :unspecific)) "")
1228  #+cmu
1229  ;; It seems reasonable to signal an error here, since the HOST argument to
1230  ;; PARSE-NAMESTRING is specified to be "a valid pathname host, a logical host,
1231  ;; or NIL".
1232  (signals-error (parse-namestring "" :unspecific) 'type-error)
1233  t)
1234
1235(deftest sbcl.15
1236  (equal (namestring (parse-namestring ""
1237                                       (pathname-host
1238                                        (translate-logical-pathname
1239                                         "EFFLUVIA:"))))
1240         "")
1241  t)
1242
1243;; PARSE-NAMESTRING host mismatch: "If HOST is supplied and not NIL, and THING
1244;; contains a manifest host name, an error of type ERROR is signaled if the
1245;; hosts do not match."
1246(deftest sbcl.16
1247  (signals-error (parse-namestring "effluvia:foo.bar" "demo2") 'error)
1248  t)
1249
1250(setf (logical-pathname-translations "bazooka")
1251      '(("todemo;*.*.*" "demo0:*.*.*")))
1252
1253(deftest sbcl.17
1254  #+allegro ;; BUG
1255  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/todemo/x.y")
1256  #+clisp ;; BUG
1257  (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error)
1258  #-(or allegro clisp)
1259  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/x.y")
1260  t)
1261
1262(deftest sbcl.18
1263  #+clisp ;; BUG
1264  (signals-error (translate-logical-pathname "demo0:x.y") 'error)
1265  #-clisp
1266  (equal (namestring (translate-logical-pathname "demo0:x.y"))
1267         ;;#-windows
1268         "/tmp/x.y"
1269         ;;#+windows "\\tmp\\x.y"
1270         )
1271  t)
1272
1273#-(or allegro clisp)
1274(deftest sbcl.19
1275  (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
1276         (namestring (translate-logical-pathname "demo0:x.y")))
1277  t)
1278
1279;; "If HOST is incorrectly supplied, an error of type TYPE-ERROR is signaled."
1280(deftest sbcl.20
1281  (signals-error (logical-pathname-translations "unregistered-host")
1282                 #+(or clisp lispworks) 'error ;; BUG
1283                 #+cmu 'file-error ;; BUG
1284                 #-(or clisp lispworks cmu) 'type-error)
1285  t)
1286
1287(deftest sbcl.21
1288  (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")
1289  nil)
1290#+(or lispworks (and clisp windows))
1291(pushnew 'sbcl.21 *expected-failures*)
1292
1293(deftest sbcl.22
1294  (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")
1295  t)
1296#+(and clisp windows)
1297(pushnew 'sbcl.22 *expected-failures*)
1298
1299(setf (logical-pathname-translations "test0")
1300      '(("**;*.*.*"              "/library/foo/**/")))
1301
1302(deftest sbcl.23
1303  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux")
1304                    "/library/foo/foo/bar/baz/mum.quux")
1305  t)
1306
1307(setf (logical-pathname-translations "prog")
1308      '(("CODE;*.*.*"             "/lib/prog/")))
1309
1310#-allegro
1311(deftest sbcl.24
1312  (check-namestring (translate-logical-pathname "prog:code;documentation.lisp")
1313                    "/lib/prog/documentation.lisp")
1314  t)
1315
1316(setf (logical-pathname-translations "prog1")
1317      '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
1318        ("CODE;*.*.*"             "/lib/prog/")))
1319
1320#-allegro
1321(deftest sbcl.25
1322  (check-namestring (translate-logical-pathname "prog1:code;documentation.lisp")
1323                    "/lib/prog/docum.lisp")
1324  t)
1325
1326;; "ANSI section 19.3.1.1.5 specifies that translation to a filesystem which
1327;; doesn't have versions should ignore the version slot. CMU CL didn't ignore
1328;; this as it should, but we [i.e. SBCL] do."
1329;; "Some file systems do not have versions. Logical pathname translation to
1330;; such a file system ignores the version." 19.3.1.1.5
1331#-cmu
1332;; CMUCL supports emacs-style versions.
1333(deftest sbcl.26
1334  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")
1335                    "/library/foo/foo/bar/baz/mum.quux")
1336  t)
1337#+lispworks
1338(pushnew 'sbcl.26 *expected-failures*)
1339
1340(setf (logical-pathname-translations "scratch")
1341      '(("**;*.*.*" "/usr/local/doc/**/*")))
1342
1343;; Trivial merge.
1344(deftest sbcl.27
1345  (check-merge-pathnames #p"foo" #p"/usr/local/doc/" #p"/usr/local/doc/foo")
1346  t)
1347
1348;; If pathname does not specify a host, device, directory, name, or type, each
1349;; such component is copied from default-pathname.
1350;; 1) no name, no type
1351(deftest sbcl.28
1352  (check-merge-pathnames #p"/supplied-dir/" #p"/dir/name.type"
1353                         #p"/supplied-dir/name.type")
1354  t)
1355
1356;; 2) no directory, no type
1357(deftest sbcl.29
1358  (check-merge-pathnames #p"supplied-name" #p"/dir/name.type"
1359                         #p"/dir/supplied-name.type")
1360  t)
1361
1362;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
1363;; as a name)
1364(deftest sbcl.30
1365  (check-merge-pathnames (make-pathname :type "supplied-type")
1366                         #p"/dir/name.type"
1367                         #p"/dir/name.supplied-type")
1368  t)
1369
1370;; If (pathname-directory pathname) is a list whose car is
1371;; :relative, and (pathname-directory default-pathname) is a
1372;; list, then the merged directory is [...]
1373(deftest sbcl.31
1374  (check-merge-pathnames #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee"
1375                         #p"/aaa/bbb/ccc/ddd/qqq/www")
1376  t)
1377
1378;; except that if the resulting list contains a string or
1379;; :wild immediately followed by :back, both of them are
1380;; removed.
1381(deftest sbcl.32
1382  (check-merge-pathnames
1383   ;; "../" in a namestring is parsed as :up not :back, so MAKE-PATHNAME.
1384   (make-pathname :directory '(:relative :back "blah"))
1385   #p"/aaa/bbb/ccc/ddd/eee" #P"/aaa/bbb/ccc/blah/eee")
1386  t)
1387
1388;; If (pathname-directory default-pathname) is not a list or
1389;; (pathname-directory pathname) is not a list whose car is
1390;; :relative, the merged directory is (or (pathname-directory
1391;; pathname) (pathname-directory default-pathname))
1392(deftest sbcl.33
1393  (check-merge-pathnames #p"/absolute/path/name" #p"/dir/default-name.type"
1394                         #P"/absolute/path/name.type")
1395  t)
1396
1397(deftest sbcl.34
1398  (check-merge-pathnames #p"scratch:;name2" #p"scratch:foo;"
1399                         #p"SCRATCH:FOO;NAME2")
1400  t)
1401
1402(deftest sbcl.35
1403  (check-merge-pathnames #p"scratch:;foo" #p"/usr/local/doc/"
1404                         #-(or allegro clisp lispworks) #P"SCRATCH:USR;LOCAL;DOC;FOO"
1405                         #+(and allegro unix) #p"/usr/local/doc/foo"
1406                         #+(and allegro windows) #p"scratch:usr;local;doc;foo"
1407                         #+clisp #p"SCRATCH:;FOO"
1408                         #+lispworks #p"SCRATCH:FOO")
1409  t)
1410
1411(deftest sbcl.36
1412  (check-merge-pathnames #p"scratch:supplied-dir;" #p"/dir/name.type"
1413                         #-clisp #p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
1414                         #+clisp
1415                         ;; #p"SCRATCH:SUPPLIED-DIR;name.type.NEWEST"
1416                         (make-pathname :host "SCRATCH"
1417                                        :directory '(:absolute "SUPPLIED-DIR")
1418                                        :name "name"
1419                                        :type "type"))
1420  t)
1421
1422(deftest sbcl.37
1423  (check-merge-pathnames #p"scratch:;supplied-name" #p"/dir/name.type"
1424                         #-(or allegro clisp lispworks)
1425                         #p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
1426                         #+(and allegro unix)
1427                         #p"/usr/local/doc/supplied-name.type"
1428                         #+(and allegro windows)
1429                         #P"scratch:dir;supplied-name.type"
1430                         #+clisp
1431                         ;; #P"SCRATCH:;SUPPLIED-NAME.type.NEWEST"
1432                         (make-pathname :host "SCRATCH"
1433                                        :directory '(:relative)
1434                                        :name "SUPPLIED-NAME"
1435                                        :type "type")
1436                         #+lispworks
1437                         ;; #P"SCRATCH:SUPPLIED-NAME.TYPE.NEWEST"
1438                         (make-pathname :host "SCRATCH"
1439                                        :directory '(:absolute)
1440                                        :name "SUPPLIED-NAME"
1441                                        :type "TYPE"))
1442  t)
1443
1444(deftest sbcl.38
1445  (check-merge-pathnames (make-pathname :host "scratch" :type "supplied-type")
1446                         #p"/dir/name.type"
1447                         #-(or allegro clisp lispworks)
1448                         #p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
1449                         #+(and allegro unix)
1450                         #p"/usr/local/doc/name.supplied-type"
1451                         #+(and allegro windows)
1452                         #P"scratch:dir;name.supplied-type"
1453                         #+clisp
1454                         ;; #P"SCRATCH:dir;name.supplied-type.NEWEST"
1455                         (make-pathname :host "SCRATCH"
1456                                        :directory '(:absolute "dir")
1457                                        :name "name"
1458                                        :type "supplied-type")
1459                         #+lispworks
1460                         ;; #P"SCRATCH:NAME.SUPPLIED-TYPE.NEWEST"
1461                         (make-pathname :host "SCRATCH"
1462                                        :directory '(:absolute)
1463                                        :name "NAME"
1464                                        :type "SUPPLIED-TYPE"))
1465  t)
1466
1467(deftest sbcl.39
1468  (let ((pathname (make-pathname :host "scratch"
1469                                        :directory '(:relative "foo")
1470                                        :name "bar"))
1471        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
1472    #-allegro
1473    (check-merge-pathnames pathname default-pathname
1474                           #-(or clisp lispworks)
1475                           #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
1476                           #+clisp
1477                           ;; #P"SCRATCH:;foo;bar"
1478                           (make-pathname :host "SCRATCH"
1479                                          :directory '(:relative "foo")
1480                                          :name "bar")
1481                           #+lispworks
1482                           #p"SCRATCH:FOO;BAR")
1483    #+(and allegro unix)
1484    (signals-error (merge-pathnames pathname default-pathname) 'error)
1485    #+(and allegro windows)
1486    (check-merge-pathnames pathname default-pathname
1487                           #P"scratch:aaa;bbb;ccc;ddd;foo;bar"))
1488  t)
1489
1490#-lispworks
1491(deftest sbcl.40
1492  (let ((pathname (make-pathname :host "scratch"
1493                                 :directory '(:relative :back "foo")
1494                                 :name "bar"))
1495        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
1496    #-allegro
1497    (check-merge-pathnames pathname default-pathname
1498                           #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
1499                           #+clisp
1500                           ;; #P"SCRATCH:;..;foo;bar.NEWEST"
1501                           (make-pathname :host "SCRATCH"
1502                                          :directory '(:relative :back "foo")
1503                                          :name "bar"))
1504    #+(and allegro unix)
1505    (signals-error (merge-pathnames pathname default-pathname) 'error)
1506    #+(and allegro windows)
1507    (check-merge-pathnames pathname default-pathname
1508                           #P"scratch:aaa;bbb;ccc;foo;bar"))
1509  t)
1510
1511#+lispworks
1512;; "Illegal logical pathname directory component: :BACK."
1513(deftest sbcl.40
1514  (signals-error (make-pathname :host "scratch"
1515                                :directory '(:relative :back "foo")
1516                                :name "bar")
1517                 'error)
1518  t)
1519
1520(deftest sbcl.41
1521  (check-merge-pathnames #p"scratch:absolute;path;name"
1522                         #p"/dir/default-name.type"
1523                         #-clisp #p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
1524                         #+clisp
1525                         ;; #P"SCRATCH:ABSOLUTE;PATH;NAME.type.NEWEST"
1526                         (make-pathname :host "SCRATCH"
1527                                        :directory '(:absolute "ABSOLUTE" "PATH")
1528                                        :name "NAME"
1529                                        :type "type"))
1530  t)
1531
1532(deftest sbcl.42
1533  (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo")
1534  t)
1535#+lispworks
1536(pushnew 'sbcl.42 *expected-failures*)
1537
1538(deftest sbcl.43
1539  (string= (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
1540           "SCRATCH:FOO")
1541  t)
1542
1543#-(or allegro clisp cmu lispworks)
1544(deftest sbcl.44
1545  ;; "The null string, "", is not a valid value for any component of a logical
1546  ;; pathname." 19.3.2.2
1547  (signals-error (setf (logical-pathname-translations "")
1548                       (list '("**;*.*.*" "/**/*.*")))
1549                 'error)
1550  t)
1551
1552#-clisp
1553(deftest sbcl.45
1554  (check-namestring (translate-logical-pathname "/") "/")
1555  t)
1556
1557(deftest sbcl.46
1558  (signals-error (pathname (make-string-input-stream "FOO"))
1559                 #-(or allegro-v6.2 cmu) 'type-error
1560                 #+allegro-v6.2     'stream-error
1561                 #+cmu              'error)
1562  t)
1563
1564(deftest sbcl.47
1565  (signals-error (merge-pathnames (make-string-output-stream))
1566                 #-allegro-v6.2 'type-error
1567                 #+allegro-v6.2 'stream-error)
1568  t)
1569
1570(deftest sbcl.48
1571  (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version :newest))
1572  t)
1573#+lispworks
1574(pushnew 'sbcl.48 *expected-failures*)
1575
1576#-allegro
1577(deftest sbcl.49
1578  (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version 1))
1579  t)
1580#+lispworks
1581(pushnew 'sbcl.49 *expected-failures*)
1582
1583(deftest sbcl.50
1584  #-clisp
1585  (check-readable-or-signals-error (make-pathname :name "foo" :type ".txt"))
1586  #+clisp
1587  (signals-error (make-pathname :name "foo" :type ".txt") 'error)
1588  t)
1589#+(or allegro cmu lispworks)
1590(pushnew 'sbcl.50 *expected-failures*)
1591
1592(deftest sbcl.51
1593  (check-readable-or-signals-error (make-pathname :name "foo." :type "txt"))
1594  t)
1595
1596(deftest sbcl.52
1597  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.1"))
1598  t)
1599
1600(deftest sbcl.53
1601  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.NEWEST"))
1602  t)
1603
1604(deftest sbcl.54
1605  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT"))
1606  t)
1607
1608(deftest sbcl.55
1609  (equal (parse-namestring "foo" nil "/")
1610         (parse-namestring "foo" nil #p"/"))
1611  t)
1612
1613#-allegro
1614(deftest sbcl.56
1615  (let ((test "parse-namestring-test.tmp"))
1616    (unwind-protect
1617        (with-open-file (f test :direction :output)
1618          ;; FIXME: This test is a bit flaky, since we only check that
1619          ;; no error is signalled. The dilemma here is "what is the
1620          ;; correct result when defaults is a _file_, not a
1621          ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
1622          ;; opposed to eg. #P"/path/to/current/foo"), which is
1623          ;; possibly mildly surprising but probably conformant.
1624          (equal (parse-namestring "foo" nil f) #p"foo"))
1625      (when (probe-file test)
1626        (delete-file test))))
1627  t)
1628
1629;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
1630;;; question has a :RELATIVE pathname.
1631(deftest sbcl.57
1632  (equal (enough-namestring #p"foo" #p"./") "foo")
1633  t)
1634
1635;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
1636;;; directory lists.
1637(deftest sbcl.58
1638  (check-namestring #p"/tmp/*/" "/tmp/*/")
1639  t)
1640
1641#-allegro
1642(deftest sbcl.59
1643  (string= (with-standard-io-syntax (write-to-string #p"/foo"))
1644           ;;#-windows "#P\"/foo\""
1645           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1646           ;;#+(and windows lispworks)
1647           "#P\"/foo\"")
1648  t)
1649
1650#-allegro
1651(deftest sbcl.60
1652  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil))
1653           ;;#-windows
1654           "#P\"/foo\""
1655           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1656           ;;#+(and windows lispworks) "#P\"/foo\""
1657           )
1658  t)
1659
1660#-allegro
1661(deftest sbcl.61
1662  (string= (with-standard-io-syntax (write-to-string #p"/foo" :escape nil))
1663           ;;#-windows
1664           "#P\"/foo\""
1665           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1666           ;;#+(and windows lispworks) "#P\"/foo\""
1667           )
1668  t)
1669
1670(deftest sbcl.62
1671  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil :escape nil))
1672           ;;#-windows
1673           "/foo"
1674           ;;#+windows "\\foo"
1675           )
1676  t)
1677
1678(deftest make-pathname.1
1679    (handler-case 
1680        (make-pathname :directory #p"/tmp/")
1681      (type-error () t))
1682  t)
1683
1684(deftest pathname.uri-encoding.1
1685    (signals-error
1686     (let ((s "file:/path with /spaces"))
1687       (equal s
1688              (namestring (pathname s))))
1689     'error)
1690  t)
1691
1692(deftest pathname.uri-encoding.2
1693    (string-equal "/path with/uri-escaped/?characters/"
1694                  (namestring (pathname "file:/path%20with/uri-escaped/%3fcharacters/")))
1695  t)
1696
1697(deftest pathname.load.1
1698    (let ((dir (merge-pathnames "dir+with+plus/"
1699                                *abcl-test-directory*)))
1700      (with-temp-directory (dir)
1701        (let ((file (merge-pathnames "foo.lisp" dir)))
1702          (with-open-file (s file :direction :output)
1703            (write *foo.lisp* :stream s))
1704          (load file))))
1705  t)
1706
1707(deftest pathname.load.2
1708    (let ((dir (merge-pathnames "dir with space/"
1709                                *abcl-test-directory*)))
1710      (with-temp-directory (dir)
1711        (let ((file (merge-pathnames "foo.lisp" dir)))
1712          (with-open-file (s file :direction :output)
1713            (write *foo.lisp* :stream s))
1714          (load file))))
1715  t)
1716
1717(deftest pathname.make-pathname.1
1718    (make-pathname :directory nil :defaults "/home/fare/")
1719  #p"")
1720
1721(deftest pathname.make-pathname.2
1722    (let ((p (make-pathname 
1723              :defaults (make-pathname :name :wild :type :wild :version :wild :directory :wild))))
1724      (values 
1725       (pathname-name p) (pathname-type p) (pathname-version p) (pathname-directory p)))
1726  :wild :wild :wild (:absolute :wild))
1727     
Note: See TracBrowser for help on using the repository browser.