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

Last change on this file since 14247 was 14247, checked in by Mark Evenson, 8 years ago

abcl-test: ensure that the logical pathname host is defined at compile time.

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