File: pathnames.impure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (411 lines) | stat: -rw-r--r-- 19,135 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
;;;; miscellaneous tests of pathname-related stuff

;;;; This file is naturally impure because we mess with
;;;; LOGICAL-PATHNAME-TRANSLATIONS.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(load "assertoid.lisp")
(use-package "ASSERTOID")

(setf (logical-pathname-translations "demo0")
      '(("**;*.*.*" "/tmp/")))

;;; In case of a parse error we want to get a condition of type
;;; CL:PARSE-ERROR (or more specifically, of type
;;; SB-KERNEL:NAMESTRING-PARSE-ERROR).
(assert
  (typep (grab-condition (logical-pathname "demo0::bla;file.lisp"))
         'parse-error))

;;; some things SBCL-0.6.9 used not to parse correctly:
;;;
;;; SBCL used to throw an error saying there's no translation.
(assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
               "/tmp/file.lisp"))
;;; We do not match a null directory to every wild path:
(assert (not (pathname-match-p "demo0:file.lisp"
                               (logical-pathname "demo0:tmp;**;*.*.*"))))
;;; Remove "**" from our resulting pathname when the source-dir is NIL:
(setf (logical-pathname-translations "demo1")
      '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
(assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
                    "/tmp/**/foo.lisp")))
;;; That should be correct:
(assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
               "/tmp/foo.lisp"))
;;; Check for absolute/relative path confusion:
(assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
                     "tmp/rel/foo.lisp")))
(assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
               "/tmp/rel/foo.lisp"))

;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to
;;; handle the following case exactly (otherwise we get an error:
;;; "#'IDENTITY CALLED WITH 2 ARGS."
(setf (logical-pathname-translations "demo2")
        '(("test;**;*.*" "/tmp/demo2/test")))
(enough-namestring "demo2:test;foo.lisp")

;;; When a pathname comes from a logical host, it should be in upper
;;; case. (This doesn't seem to be specifically required in the ANSI
;;; spec, but it's left up to the implementors, and the arguments made
;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty
;;; compelling reason for the implementors to choose case
;;; insensitivity and a canonical case.)
(setf (logical-pathname-translations "FOO")
      '(("**;*.*.*" "/full/path/to/foo/**/*.*")))
(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD"
                           :type "conf"))
       (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd"
                           :type "CONF"))
       (pn3 (read-from-string (prin1-to-string pn1))))
  (assert (equal pn1 pn2))
  (assert (equal pn1 pn3)))

;;; In addition to the upper-case constraint above, if the logical-pathname
;;; contains a string component in e.g. the directory, name and type slot,
;;; these should be valid "WORDS", according to CLHS 19.3.1.
;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
;;; a TYPE-ERROR?

(locally
  ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE
  (declare (optimize safety))

  (assert (not (ignore-errors
                (make-pathname :host "FOO" :directory "!bla" :name "bar"))))

  ;; error: name-component not valid
  (assert (not (ignore-errors
                (make-pathname :host "FOO" :directory "bla" :name "!bar"))))

  ;; error: type-component not valid.
  (assert (not (ignore-errors
                (make-pathname :host "FOO" :directory "bla" :name "bar"
                               :type "&baz")))))

;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC
;;; without actually requiring the system to signal an error (apart
;;; from host mismatches).
(assert (equal (namestring (parse-namestring "" "FOO")) "FOO:"))
(assert (equal (namestring (parse-namestring "" :unspecific)) ""))

;;; The third would work if the call were (and it should continue to
;;; work ...)
(parse-namestring ""
                  (pathname-host
                   (translate-logical-pathname
                    "FOO:")))

;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch.
(let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
  (assert (typep cond 'type-error)))

;;; turning one logical pathname into another:
(setf (logical-pathname-translations "foo")
       '(("todemo;*.*.*" "demo0:*.*.*")))
(assert (equal (namestring (translate-logical-pathname "foo:todemo;x.y"))
               (namestring (translate-logical-pathname "demo0:x.y"))))

;;; ANSI, in its wisdom, specifies that it's an error (specifically a
;;; TYPE-ERROR) to query the system about the translations of a string
;;; which doesn't have any translations. It's not clear why we don't
;;; just return NIL in that case, but they make the rules..
(let ((cond (grab-condition (logical-pathname-translations "unregistered-host"))))
  (assert (typep cond 'type-error)))

(assert (not (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")))
(assert (string-equal (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN"))

;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said
;;;   examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS
;;;   (sometimes converted to the Un*x way of things)
;;; but when I looked it up I didn't see the connection. Presumably
;;; there's some code in this section which should be attributed
;;; to something in the ANSI spec, but I don't know what code it is
;;; or what section of the specification has the related code.
(setf (logical-pathname-translations "test0")
        '(("**;*.*.*"              "/library/foo/**/")))
(assert (equal (namestring (translate-logical-pathname
                            "test0:foo;bar;baz;mum.quux"))
               "/library/foo/foo/bar/baz/mum.quux"))
(setf (logical-pathname-translations "prog")
        '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
          ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
          ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
          ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")))
(setf (logical-pathname-translations "prog")
        '(("CODE;*.*.*"             "/lib/prog/")))
(assert (equal (namestring (translate-logical-pathname
                            "prog:code;documentation.lisp"))
               "/lib/prog/documentation.lisp"))
(setf (logical-pathname-translations "prog")
        '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
          ("CODE;*.*.*"             "/lib/prog/")))
(assert (equal (namestring (translate-logical-pathname
                            "prog:code;documentation.lisp"))
               "/lib/prog/docum.lisp"))

;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
;;; which doesn't have versions should ignore the version slot. CMU CL
;;; didn't ignore this as it should, but we do.
(assert (equal (namestring (translate-logical-pathname
                            "test0:foo;bar;baz;mum.quux.3"))
               "/library/foo/foo/bar/baz/mum.quux"))

;;;; MERGE-PATHNAME tests
;;;;
;;;; There are some things we don't bother testing, just because they're
;;;; not meaningful on the underlying filesystem anyway.
;;;;
;;;; Mostly that means that we don't do devices, we don't do versions
;;;; except minimally in LPNs (they get lost in the translation to
;;;; physical hosts, so it's not much of an issue), and we don't do
;;;; hosts except for LPN hosts
;;;;
;;;; Although these tests could conceivably be useful in principle for
;;;; other implementations, they depend quite heavily on the rules for
;;;; namestring parsing, which are implementation-specific. So, success
;;;; or failure in these tests doesn't tell you anything about
;;;; ANSI-compliance unless your PARSE-NAMESTRING works like ours.

;;; Needs to be done at compile time, so that the #p"" read-macro
;;; correctly parses things as logical pathnames. This is not a
;;; problem as was, as this is an impure file and so gets loaded in,
;;; but just for future proofing...
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (logical-pathname-translations "scratch")
        '(("**;*.*.*" "/usr/local/doc/**/*"))))

(loop for (expected-result . params) in
      `(;; trivial merge
        (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/")
        ;; If pathname does not specify a host, device, directory,
        ;; name, or type, each such component is copied from
        ;; default-pathname.
        ;; 1) no name, no type
        (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type")
        ;; 2) no directory, no type
        (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type")
        ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
        ;; as a name)
        (#p"/dir/name.supplied-type"
         ,(make-pathname :type "supplied-type")
         #p"/dir/name.type")
        ;; If (pathname-directory pathname) is a list whose car is
        ;; :relative, and (pathname-directory default-pathname) is a
        ;; list, then the merged directory is [...]
        (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee")
        ;; except that if the resulting list contains a string or
        ;; :wild immediately followed by :back, both of them are
        ;; removed.
        (#P"/aaa/bbb/ccc/blah/eee"
         ;; "../" in a namestring is parsed as :up not :back, so make-pathname
         ,(make-pathname :directory '(:relative :back "blah"))
         #p"/aaa/bbb/ccc/ddd/eee")
        ;; If (pathname-directory default-pathname) is not a list or
        ;; (pathname-directory pathname) is not a list whose car is
        ;; :relative, the merged directory is (or (pathname-directory
        ;; pathname) (pathname-directory default-pathname))
        (#P"/absolute/path/name.type"
         #p"/absolute/path/name"
         #p"/dir/default-name.type")
        ;; === logical pathnames ===
        ;; recognizes a logical pathname namestring when
        ;; default-pathname is a logical pathname
        ;; FIXME: 0.6.12.23 fails this one.
        ;;
        ;; And, as it happens, it's right to fail it. Because
        ;; #p"name1" is read in with the ambient *d-p-d* value, which
        ;; has a physical (Unix) host; therefore, the host of the
        ;; default-pathname argument to merge-pathnames is
        ;; irrelevant. The result is (correctly) different if
        ;; '#p"name1"' is replaced by "name1", below, though it's
        ;; still not what one might expect... -- CSR, 2002-05-09
        #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;")
        ;; or when the namestring begins with the name of a defined
        ;; logical host followed by a colon [I assume that refers to pathname
        ;; rather than default-pathname]
        (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;")
        ;; conduct the previous set of tests again, with a lpn first argument
        (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/")
        (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
         #p"scratch:supplied-dir;"
         #p"/dir/name.type")
        (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
         #p"scratch:;supplied-name"
         #p"/dir/name.type")
        (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
         ,(make-pathname :host "scratch" :type "supplied-type")
         #p"/dir/name.type")
        (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
         ,(make-pathname :host "scratch"
                         :directory '(:relative "foo")
                         :name "bar")
         #p"/aaa/bbb/ccc/ddd/eee")
        (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
         ,(make-pathname :host "scratch"
                         :directory '(:relative :back "foo")
                         :name "bar")
         #p"/aaa/bbb/ccc/ddd/eee")
        (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
         #p"scratch:absolute;path;name" #p"/dir/default-name.type")

        ;; FIXME: test version handling in LPNs
        )
      do (let ((result (apply #'merge-pathnames params)))
           (macrolet ((frob (op)
                        `(assert (equal (,op result) (,op expected-result)))))
             (frob pathname-host)
             (frob pathname-directory)
             (frob pathname-name)
             (frob pathname-type))))

;;; host-namestring testing
(assert (string=
         (namestring (parse-namestring "/foo" (host-namestring #p"/bar")))
         "/foo"))
(assert (string=
         (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR")))
         "SCRATCH:FOO"))
(assert (raises-error?
         (setf (logical-pathname-translations "")
               (list '("**;*.*.*" "/**/*.*")))))

;;; Bug 200: translate-logical-pathname is according to the spec supposed
;;; not to give errors if asked to translate a namestring for a valid
;;; physical pathname.  Failed in 0.7.7.28 and before
(assert (string= (namestring (translate-logical-pathname "/")) "/"))


;;; Not strictly pathname logic testing, but until sbcl-0.7.6.19 we
;;; had difficulty with non-FILE-STREAM stream arguments to pathname
;;; functions (they would cause memory protection errors).  Make sure
;;; that those errors are gone:
(assert (raises-error? (pathname (make-string-input-stream "FOO"))
                       type-error))
(assert (raises-error? (merge-pathnames (make-string-output-stream))
                       type-error))

;;; ensure read/print consistency (or print-not-readable-error) on
;;; pathnames:
(let ((pathnames (list
                  (make-pathname :name "foo" :type "txt" :version :newest)
                  (make-pathname :name "foo" :type "txt" :version 1)
                  (make-pathname :name "foo" :type ".txt")
                  (make-pathname :name "foo." :type "txt")
                  (parse-namestring "SCRATCH:FOO.TXT.1")
                  (parse-namestring "SCRATCH:FOO.TXT.NEWEST")
                  (parse-namestring "SCRATCH:FOO.TXT"))))
  (dolist (p pathnames)
    (print p)
    (handler-case
        (let ((*print-readably* t))
          (assert (equal (read-from-string (format nil "~S" p)) p)))
      (print-not-readable () nil))))

;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the
;;; default argument" ...and streams as well
(assert (equal (parse-namestring "foo" nil "/")
               (parse-namestring "foo" nil #P"/")))
(let ((test "parse-namestring-test.tmp"))
  (unwind-protect
       (with-open-file (f test :direction :output)
         ;; FIXME: This test is a bit flaky, since we only check that
         ;; no error is signalled. The dilemma here is "what is the
         ;; correct result when defaults is a _file_, not a
         ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
         ;; opposed to eg. #P"/path/to/current/foo"), which is
         ;; possibly mildly surprising but probably conformant.
         (assert (parse-namestring "foo" nil f)))
    (when (probe-file test)
      (delete-file test))))

;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
;;; question has a :RELATIVE pathname.
(assert (equal (enough-namestring #p"foo" #p"./") "foo"))

;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
;;; directory lists.
(assert (equal (namestring #p"/tmp/*/") "/tmp/*/"))

;;; Printing of pathnames; see CLHS 22.1.3.1. This section was started
;;; to confirm that pathnames are printed as their namestrings under
;;; :escape nil :readably nil.
(loop for (pathname expected . vars) in
      `((#p"/foo" "#P\"/foo\"")
        (#p"/foo" "#P\"/foo\"" :readably nil)
        (#p"/foo" "#P\"/foo\"" :escape nil)
        (#p"/foo" "/foo"       :readably nil :escape nil))
      for actual = (with-standard-io-syntax
                     (apply #'write-to-string pathname vars))
      do (assert (string= expected actual)
                 ()
                 "~S should be ~S, was ~S"
                 (list* 'write-to-string pathname vars)
                 expected
                 actual))

;;; we got (truename "/") wrong for about 6 months.  Check that it's
;;; still right.
(let ((pathname (truename "/")))
  (assert (equalp pathname #p"/"))
  (assert (equal (pathname-directory pathname) '(:absolute))))

;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
;;; (Reported by Pascal Bourguignon.
(let ((pathname (make-pathname :host "SYS" :directory '(:absolute :wild-inferiors)
                               :name :wild :type nil)))
  (assert (string= (namestring pathname) "SYS:**;*"))
  (assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\"")))

;;; reported by James Y Knight on sbcl-devel 2006-05-17
(let ((p1 (make-pathname :directory '(:relative "bar")))
      (p2 (make-pathname :directory '(:relative :back "foo"))))
  (assert (equal (merge-pathnames p1 p2)
                 (make-pathname :directory '(:relative :back "foo" "bar")))))

;;; construct native namestrings even if the directory is empty (means
;;; that same as if (:relative))
(assert (equal (sb-ext:native-namestring (make-pathname :directory '(:relative)
                                                        :name "foo"
                                                        :type "txt"))
               (sb-ext:native-namestring (let ((p (make-pathname :directory nil
                                                                 :name "foo"
                                                                 :type "txt")))
                                           (assert (not (pathname-directory p)))
                                           p))))

;;; reported by Richard Kreuter: PATHNAME and MERGE-PATHNAMES used to
;;; be unsafely-flushable. Since they are known to return non-nil values
;;; only, the test-node of the IF is flushed, and since the function
;;; is unsafely-flushable, out it goes, and bad pathname designators
;;; breeze through.
;;;
;;; These tests rely on using a stream that appears as a file-stream
;;; but isn't a valid pathname-designator.
(assert (eq :false
            (if (ignore-errors (pathname sb-sys::*tty*)) :true :false)))
(assert (eq :false
            (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false)))

;;; This used to return "quux/bar.lisp"
(assert (equal #p"quux/bar.fasl"
               (let ((*default-pathname-defaults* #p"quux/"))
                 (compile-file-pathname "foo.lisp" :output-file "bar"))))
(assert (equal #p"quux/bar.fasl"
               (let ((*default-pathname-defaults* #p"quux/"))
                 (compile-file-pathname "bar.lisp"))))

;;;; success