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

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

TRANSLATE-PATHNAME.5 is no longer failing.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 53.3 KB
Line 
1;;; pathname-tests.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;; $Id: pathname-tests.lisp 13459 2011-08-11 15:44:20Z 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  (equal (translate-pathname "foobar" "foo*" "")
900         #+(or allegro clisp) #p"bar"
901         #+(or cmu sbcl lispworks abcl) #p"foobar")
902  t)
903
904(deftest translate-pathname.6
905  (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz")
906  t)
907
908(deftest translate-pathname.7
909  (equal (translate-pathname "bar/foo" "bar/*" "baz/*") #p"baz/foo")
910  t)
911
912(deftest translate-pathname.8
913  (equal (translate-pathname "foo/bar" "*/bar" "*/baz") #p"foo/baz")
914  t)
915
916(deftest translate-pathname.9
917  (string= (namestring (translate-pathname "test.txt" "*.txt" "*.text"))
918           "test.text")
919  t)
920
921(deftest translate-pathname.10
922  (equal (translate-pathname "foo" "foo.*" "bar") #p"bar")
923  t)
924
925(deftest translate-pathname.11
926  (equal (translate-pathname "foo" "foo.*" "bar.*") #p"bar")
927  t)
928
929(deftest translate-pathname.12
930  (string= (namestring (translate-pathname "foo.bar" "*.*" "/usr/local/*.*"))
931           "/usr/local/foo.bar")
932  t)
933
934(deftest translate-pathname.13
935  (equal (translate-pathname "foo.bar" "*.*" "/usr/local/*.*")
936         #p"/usr/local/foo.bar")
937  t)
938
939(deftest translate-pathname.14
940  (check-translate-pathname '("/foo/" "/*/" "/usr/local/*/") "/usr/local/foo/")
941  t)
942
943(deftest translate-pathname.15
944  (check-translate-pathname '("/foo/baz/bar.txt" "/**/*.*" "/usr/local/**/*.*")
945                            "/usr/local/foo/baz/bar.txt")
946  t)
947
948(deftest translate-pathname.16
949  (equal (translate-pathname "/foo/" "/*/" "/usr/local/*/bar/") #p"/usr/local/foo/bar/")
950  t)
951
952(deftest translate-pathname.17
953  (equal (translate-pathname "/foo/bar.txt" "/*/*.*" "/usr/local/*/*.*")
954         #P"/usr/local/foo/bar.txt")
955  t)
956
957;; "TRANSLATE-PATHNAME translates SOURCE (that matches FROM-WILDCARD)..."
958(deftest pathname-match-p.11
959  (pathname-match-p "/foo/bar.txt" "**/*.*")
960  nil)
961
962;; Since (pathname-match-p "/foo/bar.txt" "**/*.*" ) => NIL...
963(deftest translate-pathname.18
964  #+(or clisp allegro abcl cmu lispworks)
965  ;; This seems to be the correct behavior.
966  (signals-error (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*") 'error)
967  #+sbcl
968  ;; This appears to be a bug, since SOURCE doesn't match FROM-WILDCARD.
969  (equal (translate-pathname "/foo/bar.txt" "**/*.*" "/usr/local/**/*.*")
970         #p"/usr/local/foo/bar.txt")
971  t)
972
973(deftest pathname-match-p.12
974  (pathname-match-p "/foo/bar.txt" "/**/*.*")
975  t)
976
977(deftest translate-pathname.19
978  (equal (translate-pathname "/foo/bar.txt" "/**/*.*" "/usr/local/**/*.*")
979         #p"/usr/local/foo/bar.txt")
980  t)
981
982#-clisp
983(deftest translate-pathname.20
984  (equal (translate-pathname "foo.bar" "/**/*.*" "/usr/local/") #p"/usr/local/foo.bar")
985  t)
986
987;; TRANSLATE-LOGICAL-PATHNAME
988
989;; "PATHNAME is first coerced to a pathname. If the coerced pathname is a
990;; physical pathname, it is returned."
991(deftest translate-logical-pathname.1
992  (equal (translate-logical-pathname #p"/") #p"/")
993  t)
994
995#+(or abcl clisp)
996(deftest translate-logical-pathname.2
997  (equal (translate-logical-pathname "effluvia:foo.bar") #p"/usr/local/foo.bar")
998  t)
999
1000#+(or sbcl cmu)
1001(deftest translate-logical-pathname.3
1002  ;; Device mismatch.
1003  (and (eq (pathname-device (translate-logical-pathname "effluvia:foo.bar"))
1004           :unspecific)
1005       (eq (pathname-device #p"/usr/local/foo/bar")
1006           nil))
1007  t)
1008
1009(deftest translate-logical-pathname.4
1010  (check-namestring (translate-logical-pathname "effluvia:foo.bar")
1011                    "/usr/local/foo.bar")
1012  t)
1013
1014(deftest translate-logical-pathname.5
1015  (check-namestring (translate-logical-pathname "effluvia:foo;bar.txt")
1016                    "/usr/local/foo/bar.txt")
1017  t)
1018
1019(deftest translate-logical-pathname.6
1020  #-allegro
1021  (check-logical-pathname #p"effluvia:Foo.Bar" "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
1022  #+allegro
1023  ;; Allegro preserves case.
1024  (check-logical-pathname #p"effluvia:Foo.Bar" "effluvia" nil "Foo" "Bar" nil)
1025  t)
1026
1027;; "TRANSLATE-PATHNAME [and thus also TRANSLATE-LOGICAL-PATHNAME] maps
1028;; customary case in SOURCE into customary case in the output pathname."
1029(deftest translate-logical-pathname.7
1030  #-allegro
1031  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
1032                           '(:absolute "usr" "local") "foo" "bar")
1033  #+allegro
1034  ;; Allegro preserves case.
1035  (check-physical-pathname (translate-logical-pathname #p"effluvia:Foo.Bar")
1036                           '(:absolute "usr" "local") "Foo" "Bar")
1037  t)
1038
1039(deftest merge-pathnames.1
1040  #-allegro
1041  (check-logical-pathname (merge-pathnames "effluvia:foo.bar")
1042                          "EFFLUVIA" '(:absolute) "FOO" "BAR" :newest)
1043  #+allegro
1044  ;; Allegro's MERGE-PATHNAMES apparently calls TRANSLATE-LOGICAL-PATHNAME.
1045  (check-physical-pathname (merge-pathnames "effluvia:foo.bar")
1046                           '(:absolute "usr" "local") "foo" "bar")
1047  t)
1048
1049(deftest merge-pathnames.2
1050  (equal (merge-pathnames (logical-pathname "effluvia:;foo;bar;")
1051                          (logical-pathname "effluvia:baz;quux.lisp.3"))
1052         #-allegro
1053         (make-pathname :host "EFFLUVIA"
1054                        :device :unspecific
1055                        :directory '(:absolute "BAZ" "FOO" "BAR")
1056                        :name "QUUX"
1057                        :type "LISP"
1058                        :version 3)
1059         #+allegro
1060         (make-pathname :host "effluvia"
1061                        :device nil
1062                        :directory '(:absolute "baz" "foo" "bar")
1063                        :name "quux"
1064                        :type "lisp"
1065                        :version nil)
1066         )
1067  t)
1068
1069(deftest compile-file-pathname.1
1070  (equal (compile-file-pathname "effluvia:foo.lisp")
1071         #+abcl
1072         ;; Is this a bug? (Should version be :NEWEST?)
1073         #p"EFFLUVIA:FOO.ABCL"
1074         #+allegro #p"effluvia:foo.fasl"
1075         #+(or cmu sbcl) #p"EFFLUVIA:FOO.FASL.NEWEST"
1076         #+clisp
1077         ;; Is this a bug?
1078         ;; #p"EFFLUVIA:FOO.fas.NEWEST"
1079         (make-pathname :host "EFFLUVIA" :directory '(:absolute)
1080                        :name "FOO" :type "fas" :version :newest)
1081         #+(and lispworks unix) #p"EFFLUVIA:FOO.UFSL.NEWEST"
1082         #+(and lispworks windows) #p"EFFLUVIA:FOO.FSL.NEWEST")
1083  t)
1084
1085(deftest file-namestring.1
1086  (equal (file-namestring #p"")
1087         #+(or abcl allegro cmu)
1088         nil
1089         #+(or clisp lispworks sbcl)
1090         "")
1091  t)
1092
1093(deftest file-namestring.2
1094  (equal (file-namestring #p"foo") "foo")
1095  t)
1096
1097(deftest file-namestring.3
1098  (let ((pathname (make-pathname :type "foo")))
1099    #+abcl
1100    (equal (file-namestring pathname) nil)
1101    #+allegro
1102    (equal (file-namestring pathname) "NIL.foo") ;; bug
1103    #+(or clisp lispworks)
1104    (equal (file-namestring pathname) ".foo")
1105    #+(or cmu sbcl)
1106    (signals-error (file-namestring pathname) 'error))
1107  t)
1108
1109;; A variant of FILE-NAMESTRING.3 that detects Allegro's bug as a bug.
1110(deftest file-namestring.4
1111  (let ((pathname (make-pathname :type "foo")))
1112    #-(or cmu sbcl)
1113    (not (equal (file-namestring pathname) "NIL.foo"))
1114    #+(or cmu sbcl)
1115    (signals-error (file-namestring pathname) 'error))
1116  t)
1117#+allegro
1118(pushnew 'file-namestring.4 *expected-failures*)
1119
1120(deftest enough-namestring.1
1121  (equal (enough-namestring #p"/foo" #p"/") "foo")
1122  t)
1123#+sbcl
1124(pushnew 'enough-namestring.1 *expected-failures*)
1125
1126(deftest enough-namestring.2
1127  #-windows
1128  (equal (enough-namestring #p"foo/bar" #p"foo") "foo/bar")
1129  #+windows
1130  (equal (enough-namestring #p"foo\\bar" #p"foo") "foo/bar")
1131  t)
1132
1133(deftest enough-namestring.3
1134  (equal (enough-namestring #p"foo/bar" #p"foo/") "bar")
1135  t)
1136#+sbcl
1137(pushnew 'enough-namestring.3 *expected-failures*)
1138
1139;; The following tests are adapted from SBCL's pathnames.impure.lisp.
1140(setf (logical-pathname-translations "demo0")
1141      '(("**;*.*.*" "/tmp/")))
1142(deftest sbcl.1
1143  (pathname-match-p "demo0:file.lisp" (logical-pathname "demo0:tmp;**;*.*.*"))
1144  nil)
1145
1146#-clisp
1147(deftest sbcl.2
1148  (check-namestring (translate-logical-pathname "demo0:file.lisp") "/tmp/file.lisp")
1149  t)
1150
1151(setf (logical-pathname-translations "demo1")
1152      '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
1153;; Remove "**" from the resulting pathname when the source directory is NIL.
1154(deftest sbcl.3
1155  (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
1156         #-windows "/tmp/**/foo.lisp"
1157         #+windows "\\tmp\\**\\foo.lisp")
1158  nil)
1159
1160(deftest sbcl.4
1161  (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp")
1162  t)
1163
1164;;; Check for absolute/relative path confusion.
1165#-allegro
1166(deftest sbcl.5
1167  (pathname-match-p "demo1:;foo.lisp" "demo1:**;*.*.*")
1168  nil)
1169
1170#+(or sbcl cmu)
1171;; BUG Pathnames should match if the following translation is to work.
1172(deftest sbcl.6
1173  (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*")
1174  t)
1175
1176#+clisp
1177(deftest sbcl.7
1178  (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*")
1179  t)
1180
1181(deftest sbcl.8
1182  (check-namestring (translate-logical-pathname "demo1:;foo.lisp")
1183                    #+abcl "/tmp/rel/foo.lisp"
1184                    #+allegro "/tmp/foo.lisp"
1185                    #-(or allegro abcl) "/tmp/rel/foo.lisp")
1186  t)
1187
1188(setf (logical-pathname-translations "demo2")
1189      '(("test;**;*.*" "/tmp/demo2/test")))
1190
1191(deftest sbcl.9
1192  (equal (enough-namestring "demo2:test;foo.lisp")
1193         #+sbcl "DEMO2:;TEST;FOO.LISP"
1194         #+(or abcl cmu lispworks) "DEMO2:TEST;FOO.LISP"
1195         #+allegro-v7.0 "demo2:test;foo.lisp"
1196         #+allegro-v6.2 "/test/foo.lisp" ;; BUG
1197         #+(and clisp unix) "TEST;FOO.LISP"
1198         #+(and clisp windows) "DEMO2:TEST;FOO.LISP")
1199  t)
1200
1201#-(or allegro clisp cmu)
1202(deftest sbcl.10
1203  (signals-error (make-pathname :host "EFFLUVIA" :directory "!bla" :name "bar")
1204                 'error)
1205  t)
1206#-(or allegro cmu)
1207(deftest sbcl.11
1208  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "!bar")
1209                 'error)
1210  t)
1211#-(or allegro cmu)
1212(deftest sbcl.12
1213  (signals-error (make-pathname :host "EFFLUVIA" :directory "bla" :name "bar" :type "&baz")
1214                 'error)
1215  t)
1216
1217(deftest sbcl.13
1218  (equal (namestring (parse-namestring "" "EFFLUVIA")) "EFFLUVIA:")
1219  t)
1220
1221(deftest sbcl.14
1222  #-cmu
1223  (equal (namestring (parse-namestring "" :unspecific)) "")
1224  #+cmu
1225  ;; It seems reasonable to signal an error here, since the HOST argument to
1226  ;; PARSE-NAMESTRING is specified to be "a valid pathname host, a logical host,
1227  ;; or NIL".
1228  (signals-error (parse-namestring "" :unspecific) 'type-error)
1229  t)
1230
1231(deftest sbcl.15
1232  (equal (namestring (parse-namestring ""
1233                                       (pathname-host
1234                                        (translate-logical-pathname
1235                                         "EFFLUVIA:"))))
1236         "")
1237  t)
1238
1239;; PARSE-NAMESTRING host mismatch: "If HOST is supplied and not NIL, and THING
1240;; contains a manifest host name, an error of type ERROR is signaled if the
1241;; hosts do not match."
1242(deftest sbcl.16
1243  (signals-error (parse-namestring "effluvia:foo.bar" "demo2") 'error)
1244  t)
1245
1246(setf (logical-pathname-translations "bazooka")
1247      '(("todemo;*.*.*" "demo0:*.*.*")))
1248
1249(deftest sbcl.17
1250  #+allegro ;; BUG
1251  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/todemo/x.y")
1252  #+clisp ;; BUG
1253  (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error)
1254  #-(or allegro clisp)
1255  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/x.y")
1256  t)
1257
1258(deftest sbcl.18
1259  #+clisp ;; BUG
1260  (signals-error (translate-logical-pathname "demo0:x.y") 'error)
1261  #-clisp
1262  (equal (namestring (translate-logical-pathname "demo0:x.y"))
1263         ;;#-windows
1264         "/tmp/x.y"
1265         ;;#+windows "\\tmp\\x.y"
1266         )
1267  t)
1268
1269#-(or allegro clisp)
1270(deftest sbcl.19
1271  (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
1272         (namestring (translate-logical-pathname "demo0:x.y")))
1273  t)
1274
1275;; "If HOST is incorrectly supplied, an error of type TYPE-ERROR is signaled."
1276(deftest sbcl.20
1277  (signals-error (logical-pathname-translations "unregistered-host")
1278                 #+(or clisp lispworks) 'error ;; BUG
1279                 #+cmu 'file-error ;; BUG
1280                 #-(or clisp lispworks cmu) 'type-error)
1281  t)
1282
1283(deftest sbcl.21
1284  (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")
1285  nil)
1286#+(or lispworks (and clisp windows))
1287(pushnew 'sbcl.21 *expected-failures*)
1288
1289(deftest sbcl.22
1290  (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")
1291  t)
1292#+(and clisp windows)
1293(pushnew 'sbcl.22 *expected-failures*)
1294
1295(setf (logical-pathname-translations "test0")
1296      '(("**;*.*.*"              "/library/foo/**/")))
1297
1298(deftest sbcl.23
1299  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux")
1300                    "/library/foo/foo/bar/baz/mum.quux")
1301  t)
1302
1303(setf (logical-pathname-translations "prog")
1304      '(("CODE;*.*.*"             "/lib/prog/")))
1305
1306#-allegro
1307(deftest sbcl.24
1308  (check-namestring (translate-logical-pathname "prog:code;documentation.lisp")
1309                    "/lib/prog/documentation.lisp")
1310  t)
1311
1312(setf (logical-pathname-translations "prog1")
1313      '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
1314        ("CODE;*.*.*"             "/lib/prog/")))
1315
1316#-allegro
1317(deftest sbcl.25
1318  (check-namestring (translate-logical-pathname "prog1:code;documentation.lisp")
1319                    "/lib/prog/docum.lisp")
1320  t)
1321
1322;; "ANSI section 19.3.1.1.5 specifies that translation to a filesystem which
1323;; doesn't have versions should ignore the version slot. CMU CL didn't ignore
1324;; this as it should, but we [i.e. SBCL] do."
1325;; "Some file systems do not have versions. Logical pathname translation to
1326;; such a file system ignores the version." 19.3.1.1.5
1327#-cmu
1328;; CMUCL supports emacs-style versions.
1329(deftest sbcl.26
1330  (check-namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")
1331                    "/library/foo/foo/bar/baz/mum.quux")
1332  t)
1333#+lispworks
1334(pushnew 'sbcl.26 *expected-failures*)
1335
1336(setf (logical-pathname-translations "scratch")
1337      '(("**;*.*.*" "/usr/local/doc/**/*")))
1338
1339;; Trivial merge.
1340(deftest sbcl.27
1341  (check-merge-pathnames #p"foo" #p"/usr/local/doc/" #p"/usr/local/doc/foo")
1342  t)
1343
1344;; If pathname does not specify a host, device, directory, name, or type, each
1345;; such component is copied from default-pathname.
1346;; 1) no name, no type
1347(deftest sbcl.28
1348  (check-merge-pathnames #p"/supplied-dir/" #p"/dir/name.type"
1349                         #p"/supplied-dir/name.type")
1350  t)
1351
1352;; 2) no directory, no type
1353(deftest sbcl.29
1354  (check-merge-pathnames #p"supplied-name" #p"/dir/name.type"
1355                         #p"/dir/supplied-name.type")
1356  t)
1357
1358;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
1359;; as a name)
1360(deftest sbcl.30
1361  (check-merge-pathnames (make-pathname :type "supplied-type")
1362                         #p"/dir/name.type"
1363                         #p"/dir/name.supplied-type")
1364  t)
1365
1366;; If (pathname-directory pathname) is a list whose car is
1367;; :relative, and (pathname-directory default-pathname) is a
1368;; list, then the merged directory is [...]
1369(deftest sbcl.31
1370  (check-merge-pathnames #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee"
1371                         #p"/aaa/bbb/ccc/ddd/qqq/www")
1372  t)
1373
1374;; except that if the resulting list contains a string or
1375;; :wild immediately followed by :back, both of them are
1376;; removed.
1377(deftest sbcl.32
1378  (check-merge-pathnames
1379   ;; "../" in a namestring is parsed as :up not :back, so MAKE-PATHNAME.
1380   (make-pathname :directory '(:relative :back "blah"))
1381   #p"/aaa/bbb/ccc/ddd/eee" #P"/aaa/bbb/ccc/blah/eee")
1382  t)
1383
1384;; If (pathname-directory default-pathname) is not a list or
1385;; (pathname-directory pathname) is not a list whose car is
1386;; :relative, the merged directory is (or (pathname-directory
1387;; pathname) (pathname-directory default-pathname))
1388(deftest sbcl.33
1389  (check-merge-pathnames #p"/absolute/path/name" #p"/dir/default-name.type"
1390                         #P"/absolute/path/name.type")
1391  t)
1392
1393(deftest sbcl.34
1394  (check-merge-pathnames #p"scratch:;name2" #p"scratch:foo;"
1395                         #p"SCRATCH:FOO;NAME2")
1396  t)
1397
1398(deftest sbcl.35
1399  (check-merge-pathnames #p"scratch:;foo" #p"/usr/local/doc/"
1400                         #-(or allegro clisp lispworks) #P"SCRATCH:USR;LOCAL;DOC;FOO"
1401                         #+(and allegro unix) #p"/usr/local/doc/foo"
1402                         #+(and allegro windows) #p"scratch:usr;local;doc;foo"
1403                         #+clisp #p"SCRATCH:;FOO"
1404                         #+lispworks #p"SCRATCH:FOO")
1405  t)
1406
1407(deftest sbcl.36
1408  (check-merge-pathnames #p"scratch:supplied-dir;" #p"/dir/name.type"
1409                         #-clisp #p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
1410                         #+clisp
1411                         ;; #p"SCRATCH:SUPPLIED-DIR;name.type.NEWEST"
1412                         (make-pathname :host "SCRATCH"
1413                                        :directory '(:absolute "SUPPLIED-DIR")
1414                                        :name "name"
1415                                        :type "type"))
1416  t)
1417
1418(deftest sbcl.37
1419  (check-merge-pathnames #p"scratch:;supplied-name" #p"/dir/name.type"
1420                         #-(or allegro clisp lispworks)
1421                         #p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
1422                         #+(and allegro unix)
1423                         #p"/usr/local/doc/supplied-name.type"
1424                         #+(and allegro windows)
1425                         #P"scratch:dir;supplied-name.type"
1426                         #+clisp
1427                         ;; #P"SCRATCH:;SUPPLIED-NAME.type.NEWEST"
1428                         (make-pathname :host "SCRATCH"
1429                                        :directory '(:relative)
1430                                        :name "SUPPLIED-NAME"
1431                                        :type "type")
1432                         #+lispworks
1433                         ;; #P"SCRATCH:SUPPLIED-NAME.TYPE.NEWEST"
1434                         (make-pathname :host "SCRATCH"
1435                                        :directory '(:absolute)
1436                                        :name "SUPPLIED-NAME"
1437                                        :type "TYPE"))
1438  t)
1439
1440(deftest sbcl.38
1441  (check-merge-pathnames (make-pathname :host "scratch" :type "supplied-type")
1442                         #p"/dir/name.type"
1443                         #-(or allegro clisp lispworks)
1444                         #p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
1445                         #+(and allegro unix)
1446                         #p"/usr/local/doc/name.supplied-type"
1447                         #+(and allegro windows)
1448                         #P"scratch:dir;name.supplied-type"
1449                         #+clisp
1450                         ;; #P"SCRATCH:dir;name.supplied-type.NEWEST"
1451                         (make-pathname :host "SCRATCH"
1452                                        :directory '(:absolute "dir")
1453                                        :name "name"
1454                                        :type "supplied-type")
1455                         #+lispworks
1456                         ;; #P"SCRATCH:NAME.SUPPLIED-TYPE.NEWEST"
1457                         (make-pathname :host "SCRATCH"
1458                                        :directory '(:absolute)
1459                                        :name "NAME"
1460                                        :type "SUPPLIED-TYPE"))
1461  t)
1462
1463(deftest sbcl.39
1464  (let ((pathname (make-pathname :host "scratch"
1465                                        :directory '(:relative "foo")
1466                                        :name "bar"))
1467        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
1468    #-allegro
1469    (check-merge-pathnames pathname default-pathname
1470                           #-(or clisp lispworks)
1471                           #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
1472                           #+clisp
1473                           ;; #P"SCRATCH:;foo;bar"
1474                           (make-pathname :host "SCRATCH"
1475                                          :directory '(:relative "foo")
1476                                          :name "bar")
1477                           #+lispworks
1478                           #p"SCRATCH:FOO;BAR")
1479    #+(and allegro unix)
1480    (signals-error (merge-pathnames pathname default-pathname) 'error)
1481    #+(and allegro windows)
1482    (check-merge-pathnames pathname default-pathname
1483                           #P"scratch:aaa;bbb;ccc;ddd;foo;bar"))
1484  t)
1485
1486#-lispworks
1487(deftest sbcl.40
1488  (let ((pathname (make-pathname :host "scratch"
1489                                 :directory '(:relative :back "foo")
1490                                 :name "bar"))
1491        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
1492    #-allegro
1493    (check-merge-pathnames pathname default-pathname
1494                           #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
1495                           #+clisp
1496                           ;; #P"SCRATCH:;..;foo;bar.NEWEST"
1497                           (make-pathname :host "SCRATCH"
1498                                          :directory '(:relative :back "foo")
1499                                          :name "bar"))
1500    #+(and allegro unix)
1501    (signals-error (merge-pathnames pathname default-pathname) 'error)
1502    #+(and allegro windows)
1503    (check-merge-pathnames pathname default-pathname
1504                           #P"scratch:aaa;bbb;ccc;foo;bar"))
1505  t)
1506
1507#+lispworks
1508;; "Illegal logical pathname directory component: :BACK."
1509(deftest sbcl.40
1510  (signals-error (make-pathname :host "scratch"
1511                                :directory '(:relative :back "foo")
1512                                :name "bar")
1513                 'error)
1514  t)
1515
1516(deftest sbcl.41
1517  (check-merge-pathnames #p"scratch:absolute;path;name"
1518                         #p"/dir/default-name.type"
1519                         #-clisp #p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
1520                         #+clisp
1521                         ;; #P"SCRATCH:ABSOLUTE;PATH;NAME.type.NEWEST"
1522                         (make-pathname :host "SCRATCH"
1523                                        :directory '(:absolute "ABSOLUTE" "PATH")
1524                                        :name "NAME"
1525                                        :type "type"))
1526  t)
1527
1528(deftest sbcl.42
1529  (check-namestring (parse-namestring "/foo" (host-namestring #p"/bar")) "/foo")
1530  t)
1531#+lispworks
1532(pushnew 'sbcl.42 *expected-failures*)
1533
1534(deftest sbcl.43
1535  (string= (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
1536           "SCRATCH:FOO")
1537  t)
1538
1539#-(or allegro clisp cmu lispworks)
1540(deftest sbcl.44
1541  ;; "The null string, "", is not a valid value for any component of a logical
1542  ;; pathname." 19.3.2.2
1543  (signals-error (setf (logical-pathname-translations "")
1544                       (list '("**;*.*.*" "/**/*.*")))
1545                 'error)
1546  t)
1547
1548#-clisp
1549(deftest sbcl.45
1550  (check-namestring (translate-logical-pathname "/") "/")
1551  t)
1552
1553(deftest sbcl.46
1554  (signals-error (pathname (make-string-input-stream "FOO"))
1555                 #-(or allegro-v6.2 cmu) 'type-error
1556                 #+allegro-v6.2     'stream-error
1557                 #+cmu              'error)
1558  t)
1559
1560(deftest sbcl.47
1561  (signals-error (merge-pathnames (make-string-output-stream))
1562                 #-allegro-v6.2 'type-error
1563                 #+allegro-v6.2 'stream-error)
1564  t)
1565
1566(deftest sbcl.48
1567  (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version :newest))
1568  t)
1569#+lispworks
1570(pushnew 'sbcl.48 *expected-failures*)
1571
1572#-allegro
1573(deftest sbcl.49
1574  (check-readable-or-signals-error (make-pathname :name "foo" :type "txt" :version 1))
1575  t)
1576#+lispworks
1577(pushnew 'sbcl.49 *expected-failures*)
1578
1579(deftest sbcl.50
1580  #-clisp
1581  (check-readable-or-signals-error (make-pathname :name "foo" :type ".txt"))
1582  #+clisp
1583  (signals-error (make-pathname :name "foo" :type ".txt") 'error)
1584  t)
1585#+(or allegro cmu lispworks)
1586(pushnew 'sbcl.50 *expected-failures*)
1587
1588(deftest sbcl.51
1589  (check-readable-or-signals-error (make-pathname :name "foo." :type "txt"))
1590  t)
1591
1592(deftest sbcl.52
1593  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.1"))
1594  t)
1595
1596(deftest sbcl.53
1597  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT.NEWEST"))
1598  t)
1599
1600(deftest sbcl.54
1601  (check-readable-or-signals-error (parse-namestring "SCRATCH:FOO.TXT"))
1602  t)
1603
1604(deftest sbcl.55
1605  (equal (parse-namestring "foo" nil "/")
1606         (parse-namestring "foo" nil #p"/"))
1607  t)
1608
1609#-allegro
1610(deftest sbcl.56
1611  (let ((test "parse-namestring-test.tmp"))
1612    (unwind-protect
1613        (with-open-file (f test :direction :output)
1614          ;; FIXME: This test is a bit flaky, since we only check that
1615          ;; no error is signalled. The dilemma here is "what is the
1616          ;; correct result when defaults is a _file_, not a
1617          ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
1618          ;; opposed to eg. #P"/path/to/current/foo"), which is
1619          ;; possibly mildly surprising but probably conformant.
1620          (equal (parse-namestring "foo" nil f) #p"foo"))
1621      (when (probe-file test)
1622        (delete-file test))))
1623  t)
1624
1625;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
1626;;; question has a :RELATIVE pathname.
1627(deftest sbcl.57
1628  (equal (enough-namestring #p"foo" #p"./") "foo")
1629  t)
1630
1631;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
1632;;; directory lists.
1633(deftest sbcl.58
1634  (check-namestring #p"/tmp/*/" "/tmp/*/")
1635  t)
1636
1637#-allegro
1638(deftest sbcl.59
1639  (string= (with-standard-io-syntax (write-to-string #p"/foo"))
1640           ;;#-windows "#P\"/foo\""
1641           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1642           ;;#+(and windows lispworks)
1643           "#P\"/foo\"")
1644  t)
1645
1646#-allegro
1647(deftest sbcl.60
1648  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil))
1649           ;;#-windows
1650           "#P\"/foo\""
1651           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1652           ;;#+(and windows lispworks) "#P\"/foo\""
1653           )
1654  t)
1655
1656#-allegro
1657(deftest sbcl.61
1658  (string= (with-standard-io-syntax (write-to-string #p"/foo" :escape nil))
1659           ;;#-windows
1660           "#P\"/foo\""
1661           ;;#+(and windows (not lispworks)) "#P\"\\\\foo\""
1662           ;;#+(and windows lispworks) "#P\"/foo\""
1663           )
1664  t)
1665
1666(deftest sbcl.62
1667  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil :escape nil))
1668           ;;#-windows
1669           "/foo"
1670           ;;#+windows "\\foo"
1671           )
1672  t)
1673
1674(deftest make-pathname.1
1675    (handler-case 
1676        (make-pathname :directory #p"/tmp/")
1677      (type-error () t))
1678  t)
1679
1680(deftest pathname.uri-encoding.1
1681    (signals-error
1682     (let ((s "file:/path with /spaces"))
1683       (equal s
1684              (namestring (pathname s))))
1685     'error)
1686  t)
1687
1688(deftest pathname.uri-encoding.2
1689    (string-equal "/path with/uri-escaped/?characters/"
1690                  (namestring (pathname "file:/path%20with/uri-escaped/%3fcharacters/")))
1691  t)
1692
1693(deftest pathname.load.1
1694    (let ((dir (merge-pathnames "dir+with+plus/"
1695                                *abcl-test-directory*)))
1696      (with-temp-directory (dir)
1697        (let ((file (merge-pathnames "foo.lisp" dir)))
1698          (with-open-file (s file :direction :output)
1699            (write *foo.lisp* :stream s))
1700          (load file))))
1701  t)
1702
1703(deftest pathname.load.2
1704    (let ((dir (merge-pathnames "dir with space/"
1705                                *abcl-test-directory*)))
1706      (with-temp-directory (dir)
1707        (let ((file (merge-pathnames "foo.lisp" dir)))
1708          (with-open-file (s file :direction :output)
1709            (write *foo.lisp* :stream s))
1710          (load file))))
1711  t)
1712
1713(deftest pathname.make-pathname.1
1714    (make-pathname :directory nil :defaults "/home/fare/")
1715  #p"")
1716
1717(deftest pathname.make-pathname.2
1718    (let ((p (make-pathname 
1719              :defaults (make-pathname :name :wild :type :wild :version :wild :directory :wild))))
1720      (values 
1721       (pathname-name p) (pathname-type p) (pathname-version p) (pathname-directory p)))
1722  :wild :wild :wild (:absolute :wild))
1723     
Note: See TracBrowser for help on using the repository browser.