/[cmucl]/src/code/pathname.lisp
ViewVC logotype

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79 - (hide annotations)
Sat Sep 24 01:26:37 2005 UTC (8 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.78: +2 -2 lines
Oops.  ENOUGH-NAMESTRING is supposed to return a namestring, not a
pathname object.
1 wlott 1.1 ;;; -*- Package: LISP -*-
2     ;;; **********************************************************************
3     ;;; This code was written as part of the CMU Common Lisp project at
4     ;;; Carnegie Mellon University, and has been placed in the public domain.
5     ;;;
6     (ext:file-comment
7 rtoy 1.79 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pathname.lisp,v 1.79 2005/09/24 01:26:37 rtoy Exp $")
8 wlott 1.1 ;;;
9     ;;; **********************************************************************
10     ;;;
11     ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
12     ;;;
13 ram 1.17 ;;; Written by William Lott, Paul Gleichauf and Rob MacLachlan.
14 wlott 1.1 ;;; Earlier version written by Jim Large and Rob MacLachlan
15     ;;;
16     ;;; **********************************************************************
17    
18     (in-package "LISP")
19    
20 pw 1.45 (export '(pathname pathnamep logical-pathname
21 wlott 1.1 parse-namestring merge-pathnames make-pathname
22     pathname-host pathname-device pathname-directory pathname-name
23     pathname-type pathname-version namestring file-namestring
24     directory-namestring host-namestring enough-namestring
25     wild-pathname-p pathname-match-p translate-pathname
26     translate-logical-pathname logical-pathname-translations
27     load-logical-pathname-translations *default-pathname-defaults*))
28    
29     (in-package "EXTENSIONS")
30 wlott 1.9 (export '(search-list search-list-defined-p clear-search-list
31 pw 1.44 enumerate-search-list *autoload-translations*))
32 wlott 1.1
33     (in-package "LISP")
34    
35 pw 1.44 (defvar *autoload-translations* nil
36     "When non-nil, attempt to load \"library:<host>.translations\" to resolve
37     an otherwise undefined logical host.")
38    
39 wlott 1.1
40 phg 1.16 ;;;; HOST structures
41 wlott 1.1
42 phg 1.16 ;;; The host structure holds the functions that both parse the pathname
43     ;;; information into sturcture slot entries, and after translation the inverse
44     ;;; (unparse) functions.
45     ;;;
46     (defstruct (host
47     (:print-function %print-host))
48     (parse (required-argument) :type function)
49     (unparse (required-argument) :type function)
50     (unparse-host (required-argument) :type function)
51     (unparse-directory (required-argument) :type function)
52     (unparse-file (required-argument) :type function)
53     (unparse-enough (required-argument) :type function)
54     (customary-case (required-argument) :type (member :upper :lower)))
55 phg 1.13
56 phg 1.16 ;;; %PRINT-HOST -- Internal
57     ;;;
58     (defun %print-host (host stream depth)
59     (declare (ignore depth))
60 pw 1.53 (print-unreadable-object (host stream :type t)))
61 phg 1.16
62 rtoy 1.77 (defun %print-logical-host (host stream depth)
63     (declare (ignore depth))
64     (print-unreadable-object (host stream :type t)
65     (write (logical-host-name host) :stream stream)))
66    
67 phg 1.16 (defstruct (logical-host
68     (:include host
69     (:parse #'parse-logical-namestring)
70     (:unparse #'unparse-logical-namestring)
71 ram 1.17 (:unparse-host
72     #'(lambda (x) (logical-host-name (%pathname-host x))))
73 phg 1.16 (:unparse-directory #'unparse-logical-directory)
74 ram 1.17 (:unparse-file #'unparse-unix-file)
75 dtc 1.36 (:unparse-enough #'unparse-enough-namestring)
76 toy 1.57 (:customary-case :upper))
77 rtoy 1.77 (:print-function %print-logical-host)
78 toy 1.57 (:make-load-form-fun make-logical-host-load-form-fun))
79 phg 1.16 (name "" :type simple-base-string)
80     (translations nil :type list)
81     (canon-transls nil :type list))
82    
83 toy 1.57 (defun make-logical-host-load-form-fun (logical-host)
84     (values `(find-logical-host ',(logical-host-name logical-host))
85     nil))
86    
87 ram 1.17 ;;; The various magic tokens that are allowed to appear in pretty much all
88     ;;; pathname components.
89     ;;;
90     (deftype component-tokens ()
91     '(member nil :unspecific :wild))
92    
93 phg 1.16 ;;;; Pathname structures
94    
95 wlott 1.1 (defstruct (pathname
96     (:conc-name %pathname-)
97     (:print-function %print-pathname)
98     (:constructor
99     %make-pathname (host device directory name type version))
100     (:predicate pathnamep)
101     (:make-load-form-fun :just-dump-it-normally))
102 phg 1.13 ;; Slot holds the host, at present either a UNIX or logical host.
103 wlott 1.1 (host nil :type (or host null))
104 phg 1.13 ;; Device is the name of a logical or physical device holding files.
105 dtc 1.32 (device nil :type (or simple-string component-tokens))
106 phg 1.13 ;; A list of strings that are the component subdirectory components.
107 wlott 1.1 (directory nil :type list)
108 phg 1.13 ;; The filename.
109 ram 1.17 (name nil :type (or simple-string pattern component-tokens))
110 phg 1.13 ;; The type extension of the file.
111 ram 1.17 (type nil :type (or simple-string pattern component-tokens))
112 phg 1.13 ;; The version number of the file, a positive integer, but not supported
113     ;; on standard UNIX filesystems.
114 ram 1.17 (version nil :type (or integer component-tokens (member :newest))))
115 wlott 1.1
116 phg 1.13 ;;; %PRINT-PATHNAME -- Internal
117     ;;;
118     ;;; The printed representation of the pathname structure.
119     ;;;
120 wlott 1.1 (defun %print-pathname (pathname stream depth)
121     (declare (ignore depth))
122     (let ((namestring (handler-case (namestring pathname)
123     (error nil))))
124     (cond (namestring
125 dtc 1.39 (if (or *print-escape* *print-readably*)
126 rtoy 1.67 (format stream "#P~S" namestring)
127 dtc 1.39 (format stream "~A" namestring)))
128 wlott 1.1 (*print-readably*
129 rtoy 1.69 (error 'print-not-readable :object pathname))
130 wlott 1.1 (t
131     (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
132 pw 1.28 Directory=~S, Name=~S, Type=~S, Version=~S>")
133 wlott 1.1 stream
134     (%pathname-host pathname)
135     (%pathname-device pathname)
136     (%pathname-directory pathname)
137     (%pathname-name pathname)
138     (%pathname-type pathname)
139     (%pathname-version pathname))))))
140    
141 phg 1.16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 phg 1.13 ;;;
143 phg 1.16 ;;; Logical pathnames have the following format:
144     ;;;
145     ;;; logical-namestring ::=
146     ;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
147     ;;;
148     ;;; host ::= word
149     ;;; directory ::= word | wildcard-word | **
150     ;;; name ::= word | wildcard-word
151     ;;; type ::= word | wildcard-word
152     ;;; version ::= pos-int | newest | NEWEST | *
153     ;;; word ::= {uppercase-letter | digit | -}+
154     ;;; wildcard-word ::= [word] '* {word '*}* [word]
155     ;;; pos-int ::= integer > 0
156     ;;;
157     ;;; Physical pathnames include all these slots and a device slot.
158     ;;;
159     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
160 wlott 1.1
161 phg 1.16 ;; Logical pathnames are a subclass of pathname, their class relations are
162     ;; mimiced using structures for efficency.
163    
164     (defstruct (logical-pathname
165     (:conc-name %logical-pathname-)
166     (:print-function %print-logical-pathname)
167     (:include pathname)
168 ram 1.17 (:constructor %make-logical-pathname
169     (host device directory name type version))
170 phg 1.16 (:make-load-form-fun :just-dump-it-normally)))
171 ram 1.19
172     (declaim (freeze-type logical-pathname logical-host))
173 phg 1.16
174     ;;; %PRINT-LOGICAL-PATHNAME -- Internal
175 phg 1.13 ;;;
176 phg 1.16 ;;; The printed representation of the logical-pathname structure.
177     ;;; The potential conflict with search-lists requires isolating the printed
178     ;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
179     ;;;
180 rtoy 1.68 ;;; Is there really a potential conflict? CMUCL does not allow
181     ;;; search-list hosts and logical pathname hosts have the same name.
182     ;;; Hence, if we use #P to print them out, we can always read them
183     ;;; back without confusion. (rtoy)
184     ;;;
185 phg 1.16 (defun %print-logical-pathname (pathname stream depth)
186 wlott 1.1 (declare (ignore depth))
187 phg 1.16 (let ((namestring (handler-case (namestring pathname)
188     (error nil))))
189     (cond (namestring
190 dtc 1.39 (if (or *print-escape* *print-readably*)
191 rtoy 1.68 (format stream "#P~S" namestring)
192 dtc 1.39 (format stream "~A" namestring)))
193 phg 1.16 (*print-readably*
194 rtoy 1.69 (error 'print-not-readable :object pathname))
195 phg 1.16 (t
196     (funcall (formatter "#<Unprintable pathname, Host=~S, ~
197     Directory=~S, File=~S, Name=~S, Version=~S>")
198     stream
199     (%pathname-host pathname)
200     (%pathname-directory pathname)
201     (%pathname-name pathname)
202     (%pathname-type pathname)
203     (%pathname-version pathname))))))
204 wlott 1.1
205 pw 1.28 ;;; %MAKE-PATHNAME-OBJECT -- internal
206     ;;;
207     ;;; A pathname is logical if the host component is a logical-host.
208     ;;; This constructor is used to make an instance of the correct type
209     ;;; from parsed arguments.
210    
211     (defun %make-pathname-object (host device directory name type version)
212     (if (typep host 'logical-host)
213 rtoy 1.65 (flet ((upcasify (thing)
214     (typecase thing
215     (list
216     (mapcar #'(lambda (x)
217     (if (stringp x)
218     (string-upcase x)
219     x))
220     thing))
221     (simple-base-string
222     (string-upcase thing))
223     (t
224     thing))))
225     (%make-logical-pathname host :unspecific
226     (upcasify directory)
227     (upcasify name)
228     (upcasify type)
229     (upcasify version)))
230 pw 1.28 (%make-pathname host device directory name type version)))
231    
232 phg 1.16 ;;; *LOGICAL-HOSTS* --internal.
233     ;;;
234     ;;; Hash table searching maps a logical-pathname's host to their physical
235     ;;; pathname translation.
236    
237     (defvar *logical-hosts* (make-hash-table :test #'equal))
238    
239 ram 1.17 ;;; PATH-DESIGNATOR -- internal type
240 phg 1.16 ;;;
241     (deftype path-designator ()
242     "A path specification, either a string, stream or pathname."
243 ram 1.17 '(or string stream pathname))
244 phg 1.16
245 wlott 1.1
246     ;;;; Patterns
247    
248 phg 1.13 ;;; Patterns are a list of entries and wildcards used for pattern matches
249     ;;; of translations.
250    
251 wlott 1.1 (defstruct (pattern
252     (:print-function %print-pattern)
253     (:make-load-form-fun :just-dump-it-normally)
254     (:constructor make-pattern (pieces)))
255     (pieces nil :type list))
256    
257 phg 1.13 ;;; %PRINT-PATTERN -- Internal
258     ;;;
259 wlott 1.1 (defun %print-pattern (pattern stream depth)
260     (declare (ignore depth))
261     (print-unreadable-object (pattern stream :type t)
262     (if *print-pretty*
263     (let ((*print-escape* t))
264     (pprint-fill stream (pattern-pieces pattern) nil))
265     (prin1 (pattern-pieces pattern) stream))))
266    
267 phg 1.13 ;;; PATTERN= -- Internal
268     ;;;
269 wlott 1.1 (defun pattern= (pattern1 pattern2)
270     (declare (type pattern pattern1 pattern2))
271     (let ((pieces1 (pattern-pieces pattern1))
272     (pieces2 (pattern-pieces pattern2)))
273     (and (= (length pieces1) (length pieces2))
274     (every #'(lambda (piece1 piece2)
275     (typecase piece1
276     (simple-string
277     (and (simple-string-p piece2)
278     (string= piece1 piece2)))
279     (cons
280     (and (consp piece2)
281     (eq (car piece1) (car piece2))
282     (string= (cdr piece1) (cdr piece2))))
283     (t
284     (eq piece1 piece2))))
285     pieces1
286     pieces2))))
287    
288 phg 1.13 ;;; PATTERN-MATCHES -- Internal
289     ;;;
290 pw 1.30 ;;; If the string matches the pattern returns the multiple values T and a
291 phg 1.16 ;;; list of the matched strings.
292     ;;;
293 phg 1.13 (defun pattern-matches (pattern string)
294     (declare (type pattern pattern)
295     (type simple-string string))
296     (let ((len (length string)))
297     (labels ((maybe-prepend (subs cur-sub chars)
298     (if cur-sub
299     (let* ((len (length chars))
300     (new (make-string len))
301     (index len))
302     (dolist (char chars)
303     (setf (schar new (decf index)) char))
304     (cons new subs))
305     subs))
306     (matches (pieces start subs cur-sub chars)
307     (if (null pieces)
308     (if (= start len)
309     (values t (maybe-prepend subs cur-sub chars))
310     (values nil nil))
311     (let ((piece (car pieces)))
312     (etypecase piece
313     (simple-string
314     (let ((end (+ start (length piece))))
315     (and (<= end len)
316     (string= piece string
317     :start2 start :end2 end)
318     (matches (cdr pieces) end
319     (maybe-prepend subs cur-sub chars)
320     nil nil))))
321     (list
322     (ecase (car piece)
323     (:character-set
324     (and (< start len)
325     (let ((char (schar string start)))
326 rtoy 1.66 (if (find char (second piece) :test #'char=)
327 phg 1.13 (matches (cdr pieces) (1+ start) subs t
328     (cons char chars))))))))
329     ((member :single-char-wild)
330     (and (< start len)
331     (matches (cdr pieces) (1+ start) subs t
332     (cons (schar string start) chars))))
333 ram 1.17 ((member :multi-char-wild)
334 phg 1.13 (multiple-value-bind
335     (won new-subs)
336     (matches (cdr pieces) start subs t chars)
337     (if won
338     (values t new-subs)
339     (and (< start len)
340     (matches pieces (1+ start) subs t
341     (cons (schar string start)
342     chars)))))))))))
343     (multiple-value-bind
344     (won subs)
345     (matches (pattern-pieces pattern) 0 nil nil nil)
346     (values won (reverse subs))))))
347 wlott 1.1
348 phg 1.16
349 ram 1.17 ;;; DIRECTORY-COMPONENTS-MATCH -- Internal
350 phg 1.16 ;;;
351 dtc 1.35 ;;; Pathname-match-p for directory components. If thing is empty
352     ;;; then it matches :wild, (:absolute :wild-inferiors), or (:relative
353     ;;; :wild-inferiors).
354 phg 1.16 ;;;
355 ram 1.17 (defun directory-components-match (thing wild)
356     (or (eq thing wild)
357     (eq wild :wild)
358     (and (consp wild)
359     (let ((wild1 (first wild)))
360 dtc 1.35 (cond ((and (null thing) (member wild1 '(:absolute :relative)))
361     (equal (rest wild) '(:wild-inferiors)))
362     ((eq wild1 :wild-inferiors)
363     (let ((wild-subdirs (rest wild)))
364     (or (null wild-subdirs)
365     (loop
366     (when (directory-components-match thing
367     wild-subdirs)
368     (return t))
369     (pop thing)
370     (unless thing (return nil))))))
371     ((consp thing)
372     (and (components-match (first thing) wild1)
373     (directory-components-match (rest thing)
374     (rest wild)))))))))
375 phg 1.16
376    
377 phg 1.13 ;;; COMPONENTS-MATCH -- Internal
378     ;;;
379 ram 1.17 ;;; Return true if pathname component Thing is matched by Wild. Not
380     ;;; commutative.
381 phg 1.13 ;;;
382 ram 1.17 (defun components-match (thing wild)
383     (declare (type (or pattern symbol simple-string integer) thing wild))
384     (or (eq thing wild)
385     (eq wild :wild)
386     (typecase thing
387 phg 1.13 (simple-base-string
388 ram 1.17 ;; String is matched by itself, a matching pattern or :WILD.
389     (typecase wild
390 phg 1.16 (pattern
391 ram 1.17 (values (pattern-matches wild thing)))
392 phg 1.13 (simple-base-string
393 ram 1.17 (string= thing wild))))
394 phg 1.13 (pattern
395 ram 1.17 ;; A pattern is only matched by an identical pattern.
396     (and (pattern-p wild) (pattern= thing wild)))
397     (integer
398     ;; an integer (version number) is matched by :WILD or the same
399     ;; integer. This branch will actually always be NIL as long is the
400     ;; version is a fixnum.
401     (eql thing wild)))))
402 phg 1.13
403 ram 1.17
404 phg 1.13 ;;; COMPARE-COMPONENT -- Internal
405     ;;;
406     ;;; A predicate for comparing two pathname slot component sub-entries.
407     ;;;
408 wlott 1.1 (defun compare-component (this that)
409     (or (eql this that)
410     (typecase this
411     (simple-string
412     (and (simple-string-p that)
413     (string= this that)))
414     (pattern
415     (and (pattern-p that)
416     (pattern= this that)))
417     (cons
418     (and (consp that)
419     (compare-component (car this) (car that))
420     (compare-component (cdr this) (cdr that)))))))
421    
422    
423 phg 1.13 ;;;; Pathname functions.
424 wlott 1.1
425 phg 1.13 ;;; Implementation determined defaults to pathname slots.
426 wlott 1.1
427     (defvar *default-pathname-defaults*)
428    
429 phg 1.13 ;;; PATHNAME= -- Internal
430     ;;;
431 wlott 1.1 (defun pathname= (pathname1 pathname2)
432 phg 1.16 (declare (type pathname pathname1)
433     (type pathname pathname2))
434 wlott 1.1 (and (eq (%pathname-host pathname1)
435     (%pathname-host pathname2))
436     (compare-component (%pathname-device pathname1)
437     (%pathname-device pathname2))
438     (compare-component (%pathname-directory pathname1)
439     (%pathname-directory pathname2))
440     (compare-component (%pathname-name pathname1)
441     (%pathname-name pathname2))
442     (compare-component (%pathname-type pathname1)
443     (%pathname-type pathname2))
444     (compare-component (%pathname-version pathname1)
445     (%pathname-version pathname2))))
446    
447 phg 1.13 ;;; WITH-PATHNAME -- Internal
448 phg 1.16 ;;; Converts the expr, a pathname designator (a pathname, or string, or
449 phg 1.13 ;;; stream), into a pathname.
450     ;;;
451 wlott 1.1 (defmacro with-pathname ((var expr) &body body)
452     `(let ((,var (let ((,var ,expr))
453     (etypecase ,var
454     (pathname ,var)
455     (string (parse-namestring ,var))
456 toy 1.61 (file-stream (file-name ,var))
457     (stream:file-simple-stream (file-name ,var))))))
458 wlott 1.1 ,@body))
459    
460 phg 1.16 ;;; WITH-HOST -- Internal
461     ;;;
462     ;;; Converts the var, a host or string name for a host, into a logical-host
463     ;;; structure or nil if not defined.
464     ;;;
465 pw 1.28 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
466     ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
467     ;;;
468 phg 1.16 (defmacro with-host ((var expr) &body body)
469     `(let ((,var (let ((,var ,expr))
470     (typecase ,var
471     (logical-host ,var)
472 pw 1.28 (string (find-logical-host ,var nil))
473 phg 1.16 (t nil)))))
474     ,@body))
475 wlott 1.1
476 phg 1.13 ;;; PATHNAME -- Interface
477     ;;;
478 wlott 1.1 (defun pathname (thing)
479 phg 1.13 "Convert thing (a pathname, string or stream) into a pathname."
480 phg 1.16 (declare (type path-designator thing))
481 wlott 1.1 (with-pathname (pathname thing)
482     pathname))
483    
484 phg 1.13 ;;; MAYBE-DIDDLE-CASE -- Internal
485     ;;;
486     ;;; Change the case of thing if diddle-p T.
487     ;;;
488 wlott 1.1 (defun maybe-diddle-case (thing diddle-p)
489 ram 1.17 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
490 wlott 1.1 (labels ((check-for (pred in)
491 ram 1.17 (typecase in
492 wlott 1.1 (pattern
493     (dolist (piece (pattern-pieces in))
494     (when (typecase piece
495     (simple-string
496     (check-for pred piece))
497     (cons
498     (case (car in)
499     (:character-set
500     (check-for pred (cdr in))))))
501     (return t))))
502     (list
503     (dolist (x in)
504     (when (check-for pred x)
505     (return t))))
506     (simple-base-string
507     (dotimes (i (length in))
508     (when (funcall pred (schar in i))
509     (return t))))
510 ram 1.17 (t nil)))
511 wlott 1.1 (diddle-with (fun thing)
512 ram 1.17 (typecase thing
513 wlott 1.1 (pattern
514     (make-pattern
515     (mapcar #'(lambda (piece)
516     (typecase piece
517     (simple-base-string
518 pw 1.29 (funcall fun piece))
519 wlott 1.1 (cons
520     (case (car piece)
521     (:character-set
522     (cons :character-set
523     (funcall fun (cdr piece))))
524     (t
525     piece)))
526     (t
527     piece)))
528     (pattern-pieces thing))))
529     (list
530     (mapcar fun thing))
531 phg 1.12 (simple-base-string
532     (funcall fun thing))
533 ram 1.17 (t
534 phg 1.12 thing))))
535 wlott 1.1 (let ((any-uppers (check-for #'upper-case-p thing))
536     (any-lowers (check-for #'lower-case-p thing)))
537     (cond ((and any-uppers any-lowers)
538     ;; Mixed case, stays the same.
539     thing)
540 phg 1.12 (any-uppers
541     ;; All uppercase, becomes all lower case.
542     (diddle-with #'(lambda (x) (if (stringp x)
543     (string-downcase x)
544     x)) thing))
545     (any-lowers
546     ;; All lowercase, becomes all upper case.
547     (diddle-with #'(lambda (x) (if (stringp x)
548     (string-upcase x)
549     x)) thing))
550     (t
551     ;; No letters? I guess just leave it.
552     thing))))
553 wlott 1.1 thing))
554    
555 ram 1.17
556 phg 1.13 ;;; MERGE-DIRECTORIES -- Internal
557     ;;;
558 wlott 1.1 (defun merge-directories (dir1 dir2 diddle-case)
559 wlott 1.6 (if (or (eq (car dir1) :absolute)
560     (null dir2))
561 wlott 1.1 dir1
562     (let ((results nil))
563     (flet ((add (dir)
564     (if (and (eq dir :back)
565     results
566     (not (eq (car results) :back)))
567     (pop results)
568     (push dir results))))
569     (dolist (dir (maybe-diddle-case dir2 diddle-case))
570     (add dir))
571     (dolist (dir (cdr dir1))
572     (add dir)))
573     (reverse results))))
574    
575 phg 1.13 ;;; MERGE-PATHNAMES -- Interface
576     ;;;
577 wlott 1.1 (defun merge-pathnames (pathname
578     &optional
579     (defaults *default-pathname-defaults*)
580     (default-version :newest))
581 phg 1.13 "Construct a filled in pathname by completing the unspecified components
582     from the defaults."
583 phg 1.16 (declare (type path-designator pathname)
584     (type path-designator defaults)
585     (values pathname))
586 wlott 1.1 (with-pathname (defaults defaults)
587 wlott 1.2 (let ((pathname (let ((*default-pathname-defaults* defaults))
588     (pathname pathname))))
589 wlott 1.1 (let* ((default-host (%pathname-host defaults))
590     (pathname-host (%pathname-host pathname))
591     (diddle-case
592     (and default-host pathname-host
593     (not (eq (host-customary-case default-host)
594     (host-customary-case pathname-host))))))
595 pw 1.28 (%make-pathname-object
596     (or pathname-host default-host)
597     (or (%pathname-device pathname)
598     (maybe-diddle-case (%pathname-device defaults)
599     diddle-case))
600     (merge-directories (%pathname-directory pathname)
601     (%pathname-directory defaults)
602     diddle-case)
603     (or (%pathname-name pathname)
604     (maybe-diddle-case (%pathname-name defaults)
605     diddle-case))
606     (or (%pathname-type pathname)
607     (maybe-diddle-case (%pathname-type defaults)
608     diddle-case))
609 toy 1.55 (or (if (null (%pathname-name pathname))
610     (or (%pathname-version pathname)
611     (%pathname-version defaults))
612     (%pathname-version pathname))
613 pw 1.28 default-version))))))
614 wlott 1.1
615 phg 1.13 ;;; IMPORT-DIRECTORY -- Internal
616     ;;;
617 wlott 1.1 (defun import-directory (directory diddle-case)
618     (etypecase directory
619     (null nil)
620 ram 1.17 ((member :wild) '(:absolute :wild-inferiors))
621     ((member :unspecific) '(:relative))
622 wlott 1.1 (list
623     (collect ((results))
624     (ecase (pop directory)
625     (:absolute
626     (results :absolute)
627     (when (search-list-p (car directory))
628     (results (pop directory))))
629     (:relative
630     (results :relative)))
631     (dolist (piece directory)
632 ram 1.17 (cond ((member piece '(:wild :wild-inferiors :up :back))
633 phg 1.12 (results piece))
634 wlott 1.1 ((or (simple-string-p piece) (pattern-p piece))
635     (results (maybe-diddle-case piece diddle-case)))
636     ((stringp piece)
637     (results (maybe-diddle-case (coerce piece 'simple-string)
638     diddle-case)))
639     (t
640     (error "~S is not allowed as a directory component." piece))))
641     (results)))
642     (simple-string
643     `(:absolute
644     ,(maybe-diddle-case directory diddle-case)))
645     (string
646     `(:absolute
647     ,(maybe-diddle-case (coerce directory 'simple-string)
648     diddle-case)))))
649    
650 phg 1.13 ;;; MAKE-PATHNAME -- Interface
651     ;;;
652 rtoy 1.72 (defun make-pathname (&key (host nil hostp)
653 ram 1.11 (device nil devp)
654     (directory nil dirp)
655     (name nil namep)
656     (type nil typep)
657     (version nil versionp)
658 phg 1.16 defaults
659     (case :local))
660 ram 1.27 "Makes a new pathname from the component arguments. Note that host is
661     a host-structure or string."
662 rtoy 1.72 (declare (type (or null string host component-tokens) host)
663 dtc 1.32 (type (or string component-tokens) device)
664 ram 1.17 (type (or list string pattern component-tokens) directory)
665     (type (or string pattern component-tokens) name type)
666     (type (or integer component-tokens (member :newest)) version)
667 phg 1.16 (type (or path-designator null) defaults)
668 wlott 1.1 (type (member :common :local) case))
669 phg 1.16 (let* ((defaults (when defaults
670     (with-pathname (defaults defaults) defaults)))
671 wlott 1.1 (default-host (if defaults
672     (%pathname-host defaults)
673 pmai 1.60 (%pathname-host *default-pathname-defaults*)))
674 ram 1.27 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
675     ;; string (as a logical-host) for the host part. We map that
676     ;; string into the corresponding logical host structure.
677 pw 1.28
678     ;; pw@snoopy.mv.com:
679     ;; HyperSpec says for the arg to MAKE-PATHNAME;
680     ;; "host---a valid physical pathname host. ..."
681     ;; where it probably means -- a valid pathname host.
682     ;; "valid pathname host n. a valid physical pathname host or
683     ;; a valid logical pathname host."
684     ;; and defines
685     ;; "valid physical pathname host n. any of a string,
686     ;; a list of strings, or the symbol :unspecific,
687     ;; that is recognized by the implementation as the name of a host."
688     ;; "valid logical pathname host n. a string that has been defined
689     ;; as the name of a logical host. ..."
690     ;; HS is silent on what happens if the :host arg is NOT one of these.
691     ;; It seems an error message is appropriate.
692     (host (typecase host
693 toy 1.57 (host host) ; A valid host, use it.
694     ((string 0) default-host) ; "" cannot be a logical host
695 pw 1.28 (string (find-logical-host host t)) ; logical-host or lose.
696 rtoy 1.72 (t
697     ;; If the user specifically set :host to be NIL, use
698     ;; it. Otherwise, we use the default host.
699     (if (and hostp (null host))
700     nil
701     default-host))))
702     (diddle-args
703     ;; What to do if no host is given? Can't figure out the
704     ;; customary case, so I (rtoy) am going to assume we don't
705     ;; need to diddle args.
706     (and host (eq (host-customary-case host) :lower)
707     (eq case :common)))
708 wlott 1.1 (diddle-defaults
709 rtoy 1.72 ;; Same for diddle-defaults. Do nothing if no host was given.
710     (and host (not (eq (host-customary-case host)
711     (host-customary-case default-host)))))
712 phg 1.16 (dev (if devp device (if defaults (%pathname-device defaults))))
713     (dir (import-directory directory diddle-args))
714     (ver (cond
715     (versionp version)
716     (defaults (%pathname-version defaults))
717     (t nil))))
718     (when (and defaults (not dirp))
719     (setf dir
720     (merge-directories dir
721     (%pathname-directory defaults)
722     diddle-defaults)))
723 pw 1.47
724     ;; A bit of sanity checking on user arguments.
725     (flet ((check-component-validity (name name-or-type)
726 pw 1.49 (when (stringp name)
727     (let ((unix-directory-separator #\/))
728 pmai 1.60 (when (eq host (%pathname-host *default-pathname-defaults*))
729 pw 1.49 (when (find unix-directory-separator name)
730     (warn "Silly argument for a unix ~A: ~S"
731     name-or-type name)))))))
732 pw 1.47 (check-component-validity name :pathname-name)
733 rtoy 1.74 (check-component-validity type :pathname-type)
734     (mapc #'(lambda (d)
735     (check-component-validity d :directory))
736 rtoy 1.78 (cdr dir))
737     (when (and (stringp name)
738     (or (string= name "..") (string= name ".")))
739     (warn "Silly argument for a unix PATHNAME-NAME: ~S" name)))
740 rtoy 1.74
741     ;; More sanity checking
742     (when dir
743     ;; Try to canonicalize the directory component. :absolute
744     ;; followed by a bunch of "/" deletes the leading "/"'s.
745     ;; :relative followed by "." anywhere gets them all deleted.
746     (ecase (first dir)
747     (:absolute
748     (do ((p (cdr dir) (cdr p)))
749     ((or (null p)
750     (not (equal "/" (car p))))
751     (setf (cdr dir) p))))
752     (:relative
753     (setf (cdr dir) (delete "." (cdr dir) :test #'equal)))))
754 toy 1.63 ;; CLHS 19.2.2.4.3 says :absolute or :wild-inferiors immediately
755     ;; followed by :up or :back signals a file-error.
756    
757     (let ((d (or (member :wild-inferiors dir)
758     (member :absolute dir))))
759     (when (and d (rest d) (member (second d) '(:up :back)))
760 rtoy 1.73 ;; What should we put in the for pathname part of file-error?
761     ;; I'm just going to use the directory but removing the
762     ;; offending :up or :back. Or would just (make-pathname) be
763     ;; enough?
764     ;;
765     ;; Or instead of checking here, we could check whenever we
766     ;; "use" the file system (CLHS 19.2.2.4.3). But that's a lot
767     ;; harder to do.
768     (error 'simple-file-error
769     :pathname (make-pathname :directory (remove-if #'(lambda (x)
770     (member x '(:up :back)))
771     dir))
772     :format-control "Illegal pathname: ~
773     Directory with ~S immediately followed by ~S"
774     :format-arguments (list (first d) (second d)))))
775 phg 1.16
776 ram 1.11 (macrolet ((pick (var varp field)
777 ram 1.17 `(cond ((or (simple-string-p ,var)
778 wlott 1.1 (pattern-p ,var))
779     (maybe-diddle-case ,var diddle-args))
780     ((stringp ,var)
781     (maybe-diddle-case (coerce ,var 'simple-string)
782     diddle-args))
783 ram 1.11 (,varp
784 wlott 1.1 (maybe-diddle-case ,var diddle-args))
785     (defaults
786     (maybe-diddle-case (,field defaults)
787     diddle-defaults))
788     (t
789     nil))))
790 pw 1.28 (%make-pathname-object host
791     dev ; forced to :unspecific when logical-host
792     dir
793     (pick name namep %pathname-name)
794     (pick type typep %pathname-type)
795     ver))))
796 wlott 1.1
797 phg 1.13 ;;; PATHNAME-HOST -- Interface
798     ;;;
799 wlott 1.1 (defun pathname-host (pathname &key (case :local))
800 phg 1.13 "Accessor for the pathname's host."
801 phg 1.16 (declare (type path-designator pathname)
802 wlott 1.1 (type (member :local :common) case)
803 pmai 1.60 (values (or string null))
804 wlott 1.1 (ignore case))
805 pmai 1.60 (host-namestring pathname))
806 wlott 1.1
807 phg 1.13 ;;; PATHNAME-DEVICE -- Interface
808     ;;;
809 wlott 1.1 (defun pathname-device (pathname &key (case :local))
810 phg 1.13 "Accessor for pathname's device."
811 phg 1.16 (declare (type path-designator pathname)
812 wlott 1.1 (type (member :local :common) case))
813     (with-pathname (pathname pathname)
814     (maybe-diddle-case (%pathname-device pathname)
815     (and (eq case :common)
816     (eq (host-customary-case
817     (%pathname-host pathname))
818     :lower)))))
819    
820 phg 1.13 ;;; PATHNAME-DIRECTORY -- Interface
821     ;;;
822 wlott 1.1 (defun pathname-directory (pathname &key (case :local))
823 phg 1.13 "Accessor for the pathname's directory list."
824 phg 1.16 (declare (type path-designator pathname)
825 wlott 1.1 (type (member :local :common) case))
826     (with-pathname (pathname pathname)
827     (maybe-diddle-case (%pathname-directory pathname)
828     (and (eq case :common)
829     (eq (host-customary-case
830     (%pathname-host pathname))
831     :lower)))))
832 phg 1.13 ;;; PATHNAME-NAME -- Interface
833     ;;;
834 wlott 1.1 (defun pathname-name (pathname &key (case :local))
835 phg 1.13 "Accessor for the pathname's name."
836 phg 1.16 (declare (type path-designator pathname)
837 wlott 1.1 (type (member :local :common) case))
838     (with-pathname (pathname pathname)
839     (maybe-diddle-case (%pathname-name pathname)
840     (and (eq case :common)
841     (eq (host-customary-case
842     (%pathname-host pathname))
843     :lower)))))
844    
845 phg 1.13 ;;; PATHNAME-TYPE
846     ;;;
847 wlott 1.1 (defun pathname-type (pathname &key (case :local))
848 phg 1.13 "Accessor for the pathname's name."
849 phg 1.16 (declare (type path-designator pathname)
850 wlott 1.1 (type (member :local :common) case))
851     (with-pathname (pathname pathname)
852     (maybe-diddle-case (%pathname-type pathname)
853     (and (eq case :common)
854     (eq (host-customary-case
855     (%pathname-host pathname))
856     :lower)))))
857 phg 1.16
858 phg 1.13 ;;; PATHNAME-VERSION
859     ;;;
860 wlott 1.1 (defun pathname-version (pathname)
861 phg 1.13 "Accessor for the pathname's version."
862 phg 1.16 (declare (type path-designator pathname))
863 wlott 1.1 (with-pathname (pathname pathname)
864     (%pathname-version pathname)))
865    
866 phg 1.13
867     ;;;; Namestrings
868    
869     ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal
870     ;;;
871     (defun %print-namestring-parse-error (condition stream)
872     (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
873     (namestring-parse-error-complaint condition)
874     (namestring-parse-error-arguments condition)
875     (namestring-parse-error-namestring condition)
876     (namestring-parse-error-offset condition)))
877    
878 rtoy 1.71 (define-condition namestring-parse-error (parse-error type-error)
879 ram 1.24 ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
880     (arguments :reader namestring-parse-error-arguments :initarg :arguments
881     :initform nil)
882     (namestring :reader namestring-parse-error-namestring :initarg :namestring)
883     (offset :reader namestring-parse-error-offset :initarg :offset))
884 phg 1.13 (:report %print-namestring-parse-error))
885    
886    
887 ram 1.17 ;;; %PARSE-NAMESTRING -- Internal
888 phg 1.16 ;;;
889 ram 1.17 ;;; Handle the case where parse-namestring is actually parsing a namestring.
890     ;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing,
891     ;;; call the parser, then check if the host matches.
892     ;;;
893     (defun %parse-namestring (namestr host defaults start end junk-allowed)
894 dtc 1.41 (declare (type string namestr)
895 pw 1.48 (type (or host string null) host)
896     (type pathname defaults)
897 dtc 1.41 (type index start)
898     (type (or index null) end))
899 ram 1.17 (if junk-allowed
900     (handler-case
901     (%parse-namestring namestr host defaults start end nil)
902     (namestring-parse-error (condition)
903     (values nil (namestring-parse-error-offset condition))))
904     (let* ((end (or end (length namestr)))
905 pw 1.48 (host (if (and host (stringp host))
906     (find-logical-host host)
907     host))
908 pmai 1.60 (default-host (%pathname-host defaults))
909 ram 1.17 (parse-host (or host
910     (extract-logical-host-prefix namestr start end)
911 pw 1.48 default-host)))
912 ram 1.17 (unless parse-host
913     (error "When Host arg is not supplied, Defaults arg must ~
914     have a non-null PATHNAME-HOST."))
915 phg 1.16
916 ram 1.17 (multiple-value-bind
917     (new-host device directory file type version)
918     (funcall (host-parse parse-host) namestr start end)
919     (when (and host new-host (not (eq new-host host)))
920     (error "Host in namestring: ~S~@
921     does not match explicit host argument: ~S"
922 pw 1.43 namestr host))
923 ram 1.17 (let ((pn-host (or new-host parse-host)))
924 pw 1.28 (values (%make-pathname-object
925     pn-host device directory file type version)
926 ram 1.17 end))))))
927    
928    
929     ;;; EXTRACT-LOGICAL-HOST-PREFIX -- Internal
930 phg 1.16 ;;;
931 ram 1.17 ;;; If namestr begins with a colon-terminated, defined, logical host, then
932     ;;; return that host, otherwise return NIL.
933 phg 1.16 ;;;
934 ram 1.17 (defun extract-logical-host-prefix (namestr start end)
935 phg 1.16 (declare (type simple-base-string namestr)
936     (type index start end)
937 ram 1.17 (values (or logical-host null)))
938     (let ((colon-pos (position #\: namestr :start start :end end)))
939     (if colon-pos
940 pw 1.50 (find-logical-host (nstring-upcase (subseq namestr start colon-pos))
941     nil)
942 pw 1.43 nil)))
943 phg 1.16
944 phg 1.13 ;;; PARSE-NAMESTRING -- Interface
945     ;;;
946     (defun parse-namestring (thing
947     &optional host (defaults *default-pathname-defaults*)
948     &key (start 0) end junk-allowed)
949 phg 1.16 "Converts pathname, a pathname designator, into a pathname structure,
950     for a physical pathname, returns the printed representation. Host may be
951     a physical host structure or host namestring."
952     (declare (type path-designator thing)
953 toy 1.57 (type (or list string host (member :unspecific)) host)
954 phg 1.16 (type pathname defaults)
955 phg 1.13 (type index start)
956 dtc 1.41 (type (or index null) end))
957 toy 1.57 ;; Generally, redundant specification of information in software,
958     ;; whether in code or in comments, is bad. However, the ANSI spec
959     ;; for this is messy enough that it's hard to hold in short-term
960     ;; memory, so I've recorded these redundant notes on the
961     ;; implications of the ANSI spec.
962     ;;
963     ;; According to the ANSI spec, HOST can be a valid pathname host, or
964     ;; a logical host, or NIL.
965     ;;
966     ;; A valid pathname host can be a valid physical pathname host or a
967     ;; valid logical pathname host.
968     ;;
969     ;; A valid physical pathname host is "any of a string, a list of
970     ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
971     ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
972     ;; that means :UNSPECIFIC: though someday we might want to
973     ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
974     ;; '("RTFM" "MIT" "EDU"), that's not supported now.
975     ;;
976     ;; A valid logical pathname host is a string which has been defined as
977     ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
978     ;;
979     (let ((host (etypecase host
980     ((string 0)
981     ;; This is a special host. It's not valid as a
982     ;; logical host, so it is a sensible thing to
983     ;; designate the physical Unix host object. So
984     ;; we do that.
985     *unix-host*)
986     (string
987     ;; In general ANSI-compliant Common Lisps, a
988     ;; string might also be a physical pathname host,
989     ;; but ANSI leaves this up to the implementor,
990     ;; and in CMUCL we don't do it, so it must be a
991     ;; logical host.
992     (find-logical-host host))
993     ((or null (member :unspecific))
994     ;; CLHS says that HOST=:UNSPECIFIC has
995     ;; implementation-defined behavior. We
996     ;; just turn it into NIL.
997     nil)
998     (list
999     ;; ANSI also allows LISTs to designate hosts,
1000     ;; but leaves its interpretation
1001     ;; implementation-defined. Our interpretation
1002     ;; is that it's unsupported.:-|
1003     (error "A LIST representing a pathname host is not ~
1004     supported in this implementation:~% ~S"
1005     host))
1006     (host
1007     host))))
1008     (declare (type (or null host) host))
1009 dtc 1.40 (etypecase thing
1010 ram 1.17 (simple-string
1011     (%parse-namestring thing host defaults start end junk-allowed))
1012     (string
1013     (%parse-namestring (coerce thing 'simple-string)
1014     host defaults start end junk-allowed))
1015     (pathname
1016 dtc 1.31 (let ((host (if host host (%pathname-host defaults))))
1017     (unless (eq host (%pathname-host thing))
1018 phg 1.16 (error "Hosts do not match: ~S and ~S."
1019 dtc 1.31 host (%pathname-host thing))))
1020 phg 1.16 (values thing start))
1021     (stream
1022 ram 1.21 (let ((name (file-name thing)))
1023     (unless name
1024 rtoy 1.70 (error 'simple-type-error
1025     :datum thing
1026     :expected-type 'pathname
1027     :format-control "Can't figure out the file associated with stream:~% ~S"
1028     :format-arguments (list thing)))
1029 toy 1.57 (values name nil))))))
1030 phg 1.13
1031 ram 1.17
1032 phg 1.13 ;;; NAMESTRING -- Interface
1033     ;;;
1034 wlott 1.1 (defun namestring (pathname)
1035 phg 1.12 "Construct the full (name)string form of the pathname."
1036 phg 1.16 (declare (type path-designator pathname)
1037     (values (or null simple-base-string)))
1038 wlott 1.1 (with-pathname (pathname pathname)
1039 wlott 1.23 (when pathname
1040 rtoy 1.75 (let ((host (or (%pathname-host pathname)
1041     ;; Is this what we really want? Does a NIL host
1042     ;; really mean to get it from *d-p-d* and, if
1043     ;; that's NIL, use *unix-host*?
1044     (%pathname-host *default-pathname-defaults*)
1045     *unix-host*)
1046     ))
1047 wlott 1.23 (unless host
1048     (error "Cannot determine the namestring for pathnames with no ~
1049     host:~% ~S" pathname))
1050     (funcall (host-unparse host) pathname)))))
1051 wlott 1.1
1052 ram 1.17
1053 phg 1.13 ;;; HOST-NAMESTRING -- Interface
1054     ;;;
1055 wlott 1.1 (defun host-namestring (pathname)
1056 phg 1.13 "Returns a string representation of the name of the host in the pathname."
1057 phg 1.16 (declare (type path-designator pathname)
1058     (values (or null simple-base-string)))
1059 wlott 1.1 (with-pathname (pathname pathname)
1060     (let ((host (%pathname-host pathname)))
1061     (if host
1062     (funcall (host-unparse-host host) pathname)
1063     (error
1064     "Cannot determine the namestring for pathnames with no host:~% ~S"
1065     pathname)))))
1066    
1067 phg 1.13 ;;; DIRECTORY-NAMESTRING -- Interface
1068     ;;;
1069 wlott 1.1 (defun directory-namestring (pathname)
1070 phg 1.13 "Returns a string representation of the directories used in the pathname."
1071 phg 1.16 (declare (type path-designator pathname)
1072     (values (or null simple-base-string)))
1073 wlott 1.1 (with-pathname (pathname pathname)
1074     (let ((host (%pathname-host pathname)))
1075     (if host
1076     (funcall (host-unparse-directory host) pathname)
1077     (error
1078     "Cannot determine the namestring for pathnames with no host:~% ~S"
1079     pathname)))))
1080    
1081 phg 1.13 ;;; FILE-NAMESTRING -- Interface
1082     ;;;
1083 wlott 1.1 (defun file-namestring (pathname)
1084 phg 1.13 "Returns a string representation of the name used in the pathname."
1085 phg 1.16 (declare (type path-designator pathname)
1086     (values (or null simple-base-string)))
1087 wlott 1.1 (with-pathname (pathname pathname)
1088     (let ((host (%pathname-host pathname)))
1089     (if host
1090     (funcall (host-unparse-file host) pathname)
1091     (error
1092     "Cannot determine the namestring for pathnames with no host:~% ~S"
1093     pathname)))))
1094    
1095 phg 1.13 ;;; ENOUGH-NAMESTRING -- Interface
1096     ;;;
1097 wlott 1.1 (defun enough-namestring (pathname
1098     &optional (defaults *default-pathname-defaults*))
1099 phg 1.13 "Returns an abbreviated pathname sufficent to identify the pathname relative
1100     to the defaults."
1101 phg 1.16 (declare (type path-designator pathname))
1102 wlott 1.1 (with-pathname (pathname pathname)
1103     (let ((host (%pathname-host pathname)))
1104     (if host
1105     (with-pathname (defaults defaults)
1106 rtoy 1.77 ;; Give up if the hosts are different. I (rtoy) don't
1107     ;; think it makes sense to do anything if the hosts are
1108     ;; different.
1109     (if (equal host (%pathname-host defaults))
1110     (funcall (host-unparse-enough host) pathname defaults)
1111 rtoy 1.79 (namestring pathname)))
1112 wlott 1.1 (error
1113     "Cannot determine the namestring for pathnames with no host:~% ~S"
1114     pathname)))))
1115    
1116    
1117     ;;;; Wild pathnames.
1118    
1119 phg 1.13 ;;; WILD-PATHNAME-P -- Interface
1120     ;;;
1121 wlott 1.1 (defun wild-pathname-p (pathname &optional field-key)
1122 phg 1.13 "Predicate for determining whether pathname contains any wildcards."
1123 phg 1.16 (declare (type path-designator pathname)
1124 wlott 1.1 (type (member nil :host :device :directory :name :type :version)
1125     field-key))
1126     (with-pathname (pathname pathname)
1127 ram 1.17 (flet ((frob (x)
1128     (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
1129     (ecase field-key
1130     ((nil)
1131     (or (wild-pathname-p pathname :host)
1132     (wild-pathname-p pathname :device)
1133     (wild-pathname-p pathname :directory)
1134     (wild-pathname-p pathname :name)
1135     (wild-pathname-p pathname :type)
1136     (wild-pathname-p pathname :version)))
1137     (:host (frob (%pathname-host pathname)))
1138 dtc 1.38 (:device (frob (%pathname-device pathname)))
1139 ram 1.17 (:directory (some #'frob (%pathname-directory pathname)))
1140     (:name (frob (%pathname-name pathname)))
1141     (:type (frob (%pathname-type pathname)))
1142     (:version (frob (%pathname-version pathname)))))))
1143 wlott 1.1
1144 ram 1.17
1145     ;;; PATHNAME-MATCH-P -- Interface
1146 phg 1.13 ;;;
1147 phg 1.16 (defun pathname-match-p (in-pathname in-wildname)
1148 phg 1.12 "Pathname matches the wildname template?"
1149 phg 1.16 (declare (type path-designator in-pathname))
1150     (with-pathname (pathname in-pathname)
1151     (with-pathname (wildname in-wildname)
1152 ram 1.17 (macrolet ((frob (field &optional (op 'components-match ))
1153 wlott 1.1 `(or (null (,field wildname))
1154 ram 1.17 (,op (,field pathname) (,field wildname)))))
1155 phg 1.16 (and (or (null (%pathname-host wildname))
1156 ram 1.17 (eq (%pathname-host wildname) (%pathname-host pathname)))
1157 wlott 1.1 (frob %pathname-device)
1158 ram 1.17 (frob %pathname-directory directory-components-match)
1159 wlott 1.1 (frob %pathname-name)
1160     (frob %pathname-type)
1161 ram 1.17 (frob %pathname-version))))))
1162 wlott 1.1
1163 ram 1.17
1164 phg 1.13 ;;; SUBSTITUTE-INTO -- Internal
1165     ;;;
1166 ram 1.17 ;;; Place the substitutions into the pattern and return the string or pattern
1167     ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
1168     ;;; in case we are translating between hosts with difference conventional case.
1169     ;;; The second value is the tail of subs with all of the values that we used up
1170     ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
1171     ;;; as a single string, so we ignore subsequent contiguous wildcards.
1172 phg 1.16 ;;;
1173 ram 1.17 (defun substitute-into (pattern subs diddle-case)
1174 wlott 1.1 (declare (type pattern pattern)
1175 phg 1.16 (type list subs)
1176 dtc 1.40 (values (or simple-base-string pattern) list))
1177 wlott 1.1 (let ((in-wildcard nil)
1178     (pieces nil)
1179     (strings nil))
1180     (dolist (piece (pattern-pieces pattern))
1181     (cond ((simple-string-p piece)
1182 ram 1.17 (push piece strings)
1183 wlott 1.1 (setf in-wildcard nil))
1184     (in-wildcard)
1185     (t
1186 ram 1.17 (setf in-wildcard t)
1187     (unless subs
1188     (error "Not enough wildcards in FROM pattern to match ~
1189     TO pattern:~% ~S"
1190     pattern))
1191 wlott 1.1 (let ((sub (pop subs)))
1192 ram 1.17 (typecase sub
1193 wlott 1.1 (pattern
1194     (when strings
1195     (push (apply #'concatenate 'simple-string
1196     (nreverse strings))
1197     pieces))
1198     (dolist (piece (pattern-pieces sub))
1199 ram 1.17 (push piece pieces)))
1200 wlott 1.1 (simple-string
1201 ram 1.17 (push sub strings))
1202     (t
1203     (error "Can't substitute this into the middle of a word:~
1204     ~% ~S"
1205     sub)))))))
1206    
1207 wlott 1.1 (when strings
1208 phg 1.16 (push (apply #'concatenate 'simple-string (nreverse strings))
1209 wlott 1.1 pieces))
1210 ram 1.17 (values
1211     (maybe-diddle-case
1212     (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
1213     (car pieces)
1214     (make-pattern (nreverse pieces)))
1215     diddle-case)
1216     subs)))
1217 wlott 1.1
1218 ram 1.17
1219     ;;; DIDNT-MATCH-ERROR -- Internal
1220     ;;;
1221     ;;; Called when we can't see how source and from matched.
1222     ;;;
1223     (defun didnt-match-error (source from)
1224     (error "Pathname components from Source and From args to TRANSLATE-PATHNAME~@
1225     did not match:~% ~S ~S"
1226     source from))
1227    
1228    
1229 phg 1.13 ;;; TRANSLATE-COMPONENT -- Internal
1230     ;;;
1231 ram 1.17 ;;; Do TRANSLATE-COMPONENT for all components except host and directory.
1232 phg 1.13 ;;;
1233 ram 1.17 (defun translate-component (source from to diddle-case)
1234 wlott 1.1 (typecase to
1235     (pattern
1236 ram 1.17 (typecase from
1237     (pattern
1238     (typecase source
1239     (pattern
1240     (if (pattern= from source)
1241     source
1242     (didnt-match-error source from)))
1243     (simple-string
1244     (multiple-value-bind
1245     (won subs)
1246     (pattern-matches from source)
1247     (if won
1248     (values (substitute-into to subs diddle-case))
1249     (didnt-match-error source from))))
1250     (t
1251     (maybe-diddle-case source diddle-case))))
1252     ((member :wild)
1253     (values (substitute-into to (list source) diddle-case)))
1254     (t
1255     (if (components-match source from)
1256     (maybe-diddle-case source diddle-case)
1257     (didnt-match-error source from)))))
1258 wlott 1.1 ((member nil :wild)
1259 ram 1.17 (maybe-diddle-case source diddle-case))
1260 wlott 1.1 (t
1261     (if (components-match source from)
1262     to
1263 ram 1.17 (didnt-match-error source from)))))
1264 wlott 1.1
1265 ram 1.17
1266     ;;; COMPUTE-DIRECTORY-SUBSTITUTIONS -- Internal
1267     ;;;
1268     ;;; Return a list of all the things that we want to substitute into the TO
1269     ;;; pattern (the things matched by from on source.) When From contains
1270     ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1271     ;;; subdirectories.
1272     ;;;
1273     (defun compute-directory-substitutions (orig-source orig-from)
1274     (let ((source orig-source)
1275     (from orig-from))
1276     (collect ((subs))
1277     (loop
1278     (unless source
1279     (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
1280     (didnt-match-error orig-source orig-from))
1281     (subs ())
1282     (return))
1283     (unless from (didnt-match-error orig-source orig-from))
1284     (let ((from-part (pop from))
1285     (source-part (pop source)))
1286     (typecase from-part
1287     (pattern
1288     (typecase source-part
1289     (pattern
1290     (if (pattern= from-part source-part)
1291     (subs source-part)
1292     (didnt-match-error orig-source orig-from)))
1293     (simple-string
1294     (multiple-value-bind
1295     (won new-subs)
1296     (pattern-matches from-part source-part)
1297     (if won
1298     (dolist (sub new-subs)
1299     (subs sub))
1300     (didnt-match-error orig-source orig-from))))
1301     (t
1302     (didnt-match-error orig-source orig-from))))
1303     ((member :wild)
1304     (subs source-part))
1305     ((member :wild-inferiors)
1306     (let ((remaining-source (cons source-part source)))
1307     (collect ((res))
1308     (loop
1309     (when (directory-components-match remaining-source from)
1310     (return))
1311     (unless remaining-source
1312     (didnt-match-error orig-source orig-from))
1313     (res (pop remaining-source)))
1314     (subs (res))
1315     (setq source remaining-source))))
1316     (simple-string
1317     (unless (and (simple-string-p source-part)
1318     (string= from-part source-part))
1319     (didnt-match-error orig-source orig-from)))
1320     (t
1321     (didnt-match-error orig-source orig-from)))))
1322     (subs))))
1323    
1324    
1325 phg 1.13 ;;; TRANSLATE-DIRECTORIES -- Internal
1326     ;;;
1327 ram 1.17 ;;; Called by TRANSLATE-PATHNAME on the directory components of its argument
1328     ;;; pathanames to produce the result directory component. If any leaves the
1329     ;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE
1330 dtc 1.36 ;;; is taken from the source directory, except if TO is :ABSOLUTE, in which
1331     ;;; case the result will be :ABSOLUTE.
1332 ram 1.17 ;;;
1333     (defun translate-directories (source from to diddle-case)
1334     (if (not (and source to from))
1335 dtc 1.37 (let ((source (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case))
1336     source)))
1337     (if (null to)
1338     source
1339     (collect ((res))
1340     (res (cond ((null source) (first to))
1341     ((eq (first to) :absolute) :absolute)
1342     (t (first source))))
1343     (let ((match (rest source)))
1344     (dolist (to-part (rest to))
1345     (cond ((eq to-part :wild)
1346     (when match
1347     (res (first match))
1348     (setf match nil)))
1349     ((eq to-part :wild-inferiors)
1350     (when match
1351     (dolist (src-part match)
1352     (res src-part))
1353     (setf match nil)))
1354     (t
1355     (res to-part)))))
1356     (res))))
1357 ram 1.17 (collect ((res))
1358 dtc 1.35 (res (if (eq (first to) :absolute)
1359     :absolute
1360     (first source)))
1361 ram 1.17 (let ((subs-left (compute-directory-substitutions (rest source)
1362     (rest from))))
1363     (dolist (to-part (rest to))
1364     (typecase to-part
1365     ((member :wild)
1366     (assert subs-left)
1367     (let ((match (pop subs-left)))
1368     (when (listp match)
1369     (error ":WILD-INFERIORS not paired in from and to ~
1370     patterns:~% ~S ~S" from to))
1371 dtc 1.33 (res (maybe-diddle-case match diddle-case))))
1372 ram 1.17 ((member :wild-inferiors)
1373     (assert subs-left)
1374     (let ((match (pop subs-left)))
1375     (unless (listp match)
1376     (error ":WILD-INFERIORS not paired in from and to ~
1377     patterns:~% ~S ~S" from to))
1378     (dolist (x match)
1379     (res (maybe-diddle-case x diddle-case)))))
1380     (pattern
1381     (multiple-value-bind
1382     (new new-subs-left)
1383     (substitute-into to-part subs-left diddle-case)
1384     (setf subs-left new-subs-left)
1385 dtc 1.33 (res new)))
1386 ram 1.17 (t (res to-part)))))
1387     (res))))
1388 wlott 1.1
1389 ram 1.17
1390 phg 1.13 ;;; TRANSLATE-PATHNAME -- Interface
1391     ;;;
1392 wlott 1.1 (defun translate-pathname (source from-wildname to-wildname &key)
1393 phg 1.13 "Use the source pathname to translate the from-wildname's wild and
1394     unspecified elements into a completed to-pathname based on the to-wildname."
1395 phg 1.16 (declare (type path-designator source from-wildname to-wildname))
1396 wlott 1.1 (with-pathname (source source)
1397     (with-pathname (from from-wildname)
1398     (with-pathname (to to-wildname)
1399 rtoy 1.76 (unless (pathname-match-p source from)
1400     (didnt-match-error source from))
1401 ram 1.17 (let* ((source-host (%pathname-host source))
1402     (to-host (%pathname-host to))
1403     (diddle-case
1404     (and source-host to-host
1405     (not (eq (host-customary-case source-host)
1406     (host-customary-case to-host))))))
1407     (macrolet ((frob (field &optional (op 'translate-component))
1408     `(let ((result (,op (,field source)
1409     (,field from)
1410     (,field to)
1411     diddle-case)))
1412 wlott 1.1 (if (eq result :error)
1413     (error "~S doesn't match ~S" source from)
1414 ram 1.17 result))))
1415 pw 1.28 (%make-pathname-object
1416     (or to-host source-host)
1417     (frob %pathname-device)
1418     (frob %pathname-directory translate-directories)
1419     (frob %pathname-name)
1420     (frob %pathname-type)
1421     (frob %pathname-version))))))))
1422 wlott 1.1
1423    
1424     ;;;; Search lists.
1425    
1426     ;;; The SEARCH-LIST structure.
1427     ;;;
1428     (defstruct (search-list
1429     (:print-function %print-search-list)
1430     (:make-load-form-fun
1431     (lambda (search-list)
1432     (values `(intern-search-list ',(search-list-name search-list))
1433     nil))))
1434     ;;
1435     ;; The name of this search-list. Always stored in lowercase.
1436     (name (required-argument) :type simple-string)
1437     ;;
1438     ;; T if this search-list has been defined. Otherwise NIL.
1439     (defined nil :type (member t nil))
1440     ;;
1441     ;; The list of expansions for this search-list. Each expansion is the list
1442     ;; of directory components to use in place of this search-list.
1443 ram 1.21 (expansions nil :type list))
1444 ram 1.4
1445 wlott 1.1 (defun %print-search-list (sl stream depth)
1446     (declare (ignore depth))
1447     (print-unreadable-object (sl stream :type t)
1448     (write-string (search-list-name sl) stream)))
1449    
1450     ;;; *SEARCH-LISTS* -- internal.
1451     ;;;
1452     ;;; Hash table mapping search-list names to search-list structures.
1453     ;;;
1454     (defvar *search-lists* (make-hash-table :test #'equal))
1455    
1456 pw 1.43 ;;; FIND-SEARCH-LIST -- internal
1457     ;;;
1458     (defun find-search-list (name &optional (flame-not-found-p t))
1459     (let ((search-list (gethash (string-downcase name) *search-lists*)))
1460     (if search-list search-list
1461     (when flame-not-found-p
1462     (error "Search-list ~a not defined." name)))))
1463    
1464 wlott 1.1 ;;; INTERN-SEARCH-LIST -- internal interface.
1465     ;;;
1466     ;;; When search-lists are encountered in namestrings, they are converted to
1467     ;;; search-list structures right then, instead of waiting until the search
1468     ;;; list used. This allows us to verify ahead of time that there are no
1469     ;;; circularities and makes expansion much quicker.
1470     ;;;
1471     (defun intern-search-list (name)
1472     (let ((name (string-downcase name)))
1473     (or (gethash name *search-lists*)
1474     (let ((new (make-search-list :name name)))
1475     (setf (gethash name *search-lists*) new)
1476     new))))
1477    
1478     ;;; CLEAR-SEARCH-LIST -- public.
1479     ;;;
1480     ;;; Clear the definition. Note: we can't remove it from the hash-table
1481     ;;; because there may be pathnames still refering to it. So we just clear
1482 pw 1.43 ;;; out the expansions and set defined to NIL.
1483 wlott 1.1 ;;;
1484     (defun clear-search-list (name)
1485     "Clear the current definition for the search-list NAME. Returns T if such
1486     a definition existed, and NIL if not."
1487     (let* ((name (string-downcase name))
1488     (search-list (gethash name *search-lists*)))
1489     (when (and search-list (search-list-defined search-list))
1490     (setf (search-list-defined search-list) nil)
1491     (setf (search-list-expansions search-list) nil)
1492     t)))
1493    
1494     ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
1495     ;;;
1496     ;;; Again, we can't actually remove the entries from the hash-table, so we
1497     ;;; just mark them as being undefined.
1498     ;;;
1499     (defun clear-all-search-lists ()
1500     "Clear the definition for all search-lists. Only use this if you know
1501     what you are doing."
1502     (maphash #'(lambda (name search-list)
1503     (declare (ignore name))
1504     (setf (search-list-defined search-list) nil)
1505     (setf (search-list-expansions search-list) nil))
1506     *search-lists*)
1507     nil)
1508    
1509     ;;; EXTRACT-SEARCH-LIST -- internal.
1510     ;;;
1511     ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
1512     ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
1513     ;;; is true) or return NIL (if FLAME-IF-NONE is false).
1514     ;;;
1515     (defun extract-search-list (pathname flame-if-none)
1516     (with-pathname (pathname pathname)
1517     (let* ((directory (%pathname-directory pathname))
1518     (search-list (cadr directory)))
1519     (cond ((search-list-p search-list)
1520     search-list)
1521     (flame-if-none
1522 wlott 1.8 (error "~S doesn't start with a search-list." pathname))
1523 wlott 1.1 (t
1524     nil)))))
1525    
1526     ;;; SEARCH-LIST -- public.
1527     ;;;
1528     ;;; We have to convert the internal form of the search-list back into a
1529     ;;; bunch of pathnames.
1530     ;;;
1531     (defun search-list (pathname)
1532     "Return the expansions for the search-list starting PATHNAME. If PATHNAME
1533     does not start with a search-list, then an error is signaled. If
1534     the search-list has not been defined yet, then an error is signaled.
1535 phg 1.16 The expansion for a search-list can be set with SETF."
1536 wlott 1.1 (with-pathname (pathname pathname)
1537     (let ((search-list (extract-search-list pathname t))
1538 pmai 1.60 (host (%pathname-host pathname)))
1539 wlott 1.1 (if (search-list-defined search-list)
1540     (mapcar #'(lambda (directory)
1541     (make-pathname :host host
1542     :directory (cons :absolute directory)))
1543     (search-list-expansions search-list))
1544     (error "Search list ~S has not been defined yet." pathname)))))
1545 wlott 1.9
1546     ;;; SEARCH-LIST-DEFINED-P -- public.
1547     ;;;
1548     (defun search-list-defined-p (pathname)
1549     "Returns T if the search-list starting PATHNAME is currently defined, and
1550     NIL otherwise. An error is signaled if PATHNAME does not start with a
1551     search-list."
1552     (with-pathname (pathname pathname)
1553     (search-list-defined (extract-search-list pathname t))))
1554 wlott 1.1
1555     ;;; %SET-SEARCH-LIST -- public setf method
1556     ;;;
1557     ;;; Set the expansion for the search-list in PATHNAME. If this would result
1558     ;;; in any circularities, we flame out. If anything goes wrong, we leave the
1559     ;;; old defintion intact.
1560     ;;;
1561     (defun %set-search-list (pathname values)
1562     (let ((search-list (extract-search-list pathname t)))
1563     (labels
1564     ((check (target-list path)
1565     (when (eq search-list target-list)
1566     (error "That would result in a circularity:~% ~
1567     ~A~{ -> ~A~} -> ~A"
1568     (search-list-name search-list)
1569     (reverse path)
1570     (search-list-name target-list)))
1571     (when (search-list-p target-list)
1572     (push (search-list-name target-list) path)
1573     (dolist (expansion (search-list-expansions target-list))
1574     (check (car expansion) path))))
1575     (convert (pathname)
1576     (with-pathname (pathname pathname)
1577     (when (or (pathname-name pathname)
1578     (pathname-type pathname)
1579     (pathname-version pathname))
1580     (error "Search-lists cannot expand into pathnames that have ~
1581     a name, type, or ~%version specified:~% ~S"
1582     pathname))
1583     (let ((directory (pathname-directory pathname)))
1584 wlott 1.7 (let ((expansion
1585     (if directory
1586     (ecase (car directory)
1587     (:absolute (cdr directory))
1588     (:relative (cons (intern-search-list "default")
1589     (cdr directory))))
1590     (list (intern-search-list "default")))))
1591 wlott 1.1 (check (car expansion) nil)
1592     expansion)))))
1593     (setf (search-list-expansions search-list)
1594     (if (listp values)
1595     (mapcar #'convert values)
1596     (list (convert values)))))
1597     (setf (search-list-defined search-list) t))
1598     values)
1599    
1600     ;;; ENUMERATE-SEARCH-LIST -- public.
1601     ;;;
1602     (defmacro enumerate-search-list ((var pathname &optional result) &body body)
1603     "Execute BODY with VAR bound to each successive possible expansion for
1604     PATHNAME and then return RESULT. Note: if PATHNAME does not contain a
1605     search-list, then BODY is executed exactly once. Everything is wrapped
1606     in a block named NIL, so RETURN can be used to terminate early. Note:
1607     VAR is *not* bound inside of RESULT."
1608     (let ((body-name (gensym)))
1609     `(block nil
1610     (flet ((,body-name (,var)
1611     ,@body))
1612     (%enumerate-search-list ,pathname #',body-name)
1613     ,result))))
1614    
1615     (defun %enumerate-search-list (pathname function)
1616 ram 1.22 (let* ((pathname (if (logical-pathname-p pathname)
1617     (translate-logical-pathname pathname)
1618     pathname))
1619 ram 1.21 (search-list (extract-search-list pathname nil)))
1620 wlott 1.1 (cond
1621     ((not search-list)
1622     (funcall function pathname))
1623     ((not (search-list-defined search-list))
1624     (error "Undefined search list: ~A"
1625     (search-list-name search-list)))
1626     (t
1627     (let ((tail (cddr (pathname-directory pathname))))
1628     (dolist (expansion
1629     (search-list-expansions search-list))
1630     (%enumerate-search-list (make-pathname :defaults pathname
1631     :directory
1632     (cons :absolute
1633     (append expansion
1634     tail)))
1635     function)))))))
1636 phg 1.12
1637    
1638     ;;;; Logical pathname support. ANSI 92-102 specification.
1639 phg 1.16 ;;;; As logical-pathname translations are loaded they are canonicalized as
1640     ;;;; patterns to enable rapid efficent translation into physical pathnames.
1641 phg 1.12
1642 ram 1.17 ;;;; Utilities:
1643 phg 1.12
1644 ram 1.17 ;;; LOGICAL-WORD-OR-LOSE -- Internal
1645 phg 1.13 ;;;
1646 ram 1.17 ;;; Canonicalize a logical pathanme word by uppercasing it checking that it
1647     ;;; contains only legal characters.
1648 phg 1.16 ;;;
1649 ram 1.17 (defun logical-word-or-lose (word)
1650     (declare (string word))
1651     (let ((word (string-upcase word)))
1652     (dotimes (i (length word))
1653     (let ((ch (schar word i)))
1654     (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1655     (error 'namestring-parse-error
1656     :complaint "Logical namestring character ~
1657     is not alphanumeric or hyphen:~% ~S"
1658     :arguments (list ch)
1659     :namestring word :offset i))))
1660     word))
1661 phg 1.12
1662 ram 1.17
1663     ;;; FIND-LOGICAL-HOST -- Internal
1664     ;;;
1665     ;;; Given a logical host or string, return a logical host. If Error-p is
1666     ;;; NIL, then return NIL when no such host exists.
1667     ;;;
1668     (defun find-logical-host (thing &optional (errorp t))
1669     (etypecase thing
1670     (string
1671 pw 1.50 (let* ((valid-hostname
1672     (catch 'error-bailout
1673     (handler-bind
1674     ((namestring-parse-error
1675     (lambda(c)(declare (ignore c))
1676     (unless errorp
1677     (throw 'error-bailout nil)))))
1678     (logical-word-or-lose thing))))
1679     (found
1680     (and valid-hostname
1681     (or (gethash valid-hostname *logical-hosts*)
1682 pw 1.46 (and *autoload-translations*
1683 pw 1.50 (ignore-errors
1684 pw 1.51 (load-logical-pathname-translations
1685     valid-hostname))
1686 pw 1.50 (gethash valid-hostname *logical-hosts*))))))
1687 ram 1.17 (if (or found (not errorp))
1688     found
1689 dtc 1.34 (error 'simple-file-error
1690     :pathname thing
1691     :format-control "Logical host not yet defined: ~S"
1692     :format-arguments (list thing)))))
1693 ram 1.17 (logical-host thing)))
1694 pw 1.43
1695 phg 1.16 ;;; INTERN-LOGICAL-HOST -- Internal
1696 phg 1.13 ;;;
1697 ram 1.17 ;;; Given a logical host name or host, return a logical host, creating a new
1698     ;;; one if necessary.
1699 phg 1.16 ;;;
1700 ram 1.17 (defun intern-logical-host (thing)
1701     (declare (values logical-host))
1702     (or (find-logical-host thing nil)
1703     (let* ((name (logical-word-or-lose thing))
1704     (new (make-logical-host :name name)))
1705 phg 1.16 (setf (gethash name *logical-hosts*) new)
1706     new)))
1707 phg 1.12
1708 ram 1.17
1709     ;;;; Logical pathname parsing:
1710    
1711     ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal
1712 phg 1.13 ;;;
1713 ram 1.17 ;;; Deal with multi-char wildcards in a logical pathname token.
1714 phg 1.16 ;;;
1715 ram 1.17 (defun maybe-make-logical-pattern (namestring chunks)
1716     (let ((chunk (caar chunks)))
1717     (collect ((pattern))
1718     (let ((last-pos 0)
1719     (len (length chunk)))
1720     (declare (fixnum last-pos))
1721     (loop
1722     (when (= last-pos len) (return))
1723     (let ((pos (or (position #\* chunk :start last-pos) len)))
1724     (if (= pos last-pos)
1725     (when (pattern)
1726     (error 'namestring-parse-error
1727     :complaint "Double asterisk inside of logical ~
1728     word: ~S"
1729     :arguments (list chunk)
1730     :namestring namestring
1731     :offset (+ (cdar chunks) pos)))
1732     (pattern (subseq chunk last-pos pos)))
1733     (if (= pos len)
1734     (return)
1735     (pattern :multi-char-wild))
1736     (setq last-pos (1+ pos)))))
1737     (assert (pattern))
1738     (if (cdr (pattern))
1739     (make-pattern (pattern))
1740     (let ((x (car (pattern))))
1741     (if (eq x :multi-char-wild)
1742     :wild
1743     x))))))
1744 phg 1.12
1745 ram 1.17
1746     ;;; LOGICAL-CHUNKIFY -- Internal
1747 phg 1.13 ;;;
1748 ram 1.17 ;;; Return a list of conses where the cdr is the start position and the car
1749     ;;; is a string (token) or character (punctuation.)
1750 phg 1.13 ;;;
1751 ram 1.17 (defun logical-chunkify (namestr start end)
1752     (collect ((chunks))
1753     (do ((i start (1+ i))
1754 toy 1.62 (prev start))
1755 ram 1.17 ((= i end)
1756     (when (> end prev)
1757     (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1758     (let ((ch (schar namestr i)))
1759     (unless (or (alpha-char-p ch) (digit-char-p ch)
1760     (member ch '(#\- #\*)))
1761     (when (> i prev)
1762     (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1763     (setq prev (1+ i))
1764     (unless (member ch '(#\; #\: #\.))
1765     (error 'namestring-parse-error
1766     :complaint "Illegal character for logical pathname:~% ~S"
1767     :arguments (list ch)
1768     :namestring namestr
1769     :offset i))
1770     (chunks (cons ch i)))))
1771     (chunks)))
1772 phg 1.12
1773    
1774 phg 1.13 ;;; PARSE-LOGICAL-NAMESTRING -- Internal
1775     ;;;
1776 phg 1.16 ;;; Break up a logical-namestring, always a string, into its constituent
1777     ;;; parts.
1778 phg 1.13 ;;;
1779 ram 1.17 (defun parse-logical-namestring (namestr start end)
1780 phg 1.12 (declare (type simple-base-string namestr)
1781 ram 1.17 (type index start end))
1782     (collect ((directory))
1783     (let ((host nil)
1784     (name nil)
1785     (type nil)
1786     (version nil))
1787     (labels ((expecting (what chunks)
1788     (unless (and chunks (simple-string-p (caar chunks)))
1789     (error 'namestring-parse-error
1790 pmai 1.54 :complaint "Expecting ~A, got ~:[nothing~;~:*~S~]."
1791 ram 1.17 :arguments (list what (caar chunks))
1792     :namestring namestr
1793     :offset (if chunks (cdar chunks) end)))
1794     (caar chunks))
1795     (parse-host (chunks)
1796     (case (caadr chunks)
1797     (#\:
1798     (setq host
1799     (find-logical-host (expecting "a host name" chunks)))
1800     (parse-relative (cddr chunks)))
1801     (t
1802     (parse-relative chunks))))
1803     (parse-relative (chunks)
1804     (case (caar chunks)
1805     (#\;
1806     (directory :relative)
1807     (parse-directory (cdr chunks)))
1808     (t
1809 pw 1.30 (directory :absolute) ; Assumption! Maybe revoked later.
1810 ram 1.17 (parse-directory chunks))))
1811     (parse-directory (chunks)
1812     (case (caadr chunks)
1813     (#\;
1814     (directory
1815     (let ((res (expecting "a directory name" chunks)))
1816     (cond ((string= res "..") :up)
1817     ((string= res "**") :wild-inferiors)
1818     (t
1819     (maybe-make-logical-pattern namestr chunks)))))
1820     (parse-directory (cddr chunks)))
1821     (t
1822     (parse-name chunks))))
1823     (parse-name (chunks)
1824     (when chunks
1825     (expecting "a file name" chunks)
1826     (setq name (maybe-make-logical-pattern namestr chunks))
1827     (expecting-dot (cdr chunks))))
1828     (expecting-dot (chunks)
1829     (when chunks
1830     (unless (eql (caar chunks) #\.)
1831     (error 'namestring-parse-error
1832     :complaint "Expecting a dot, got ~S."
1833     :arguments (list (caar chunks))
1834     :namestring namestr
1835     :offset (cdar chunks)))
1836     (if type
1837     (parse-version (cdr chunks))
1838     (parse-type (cdr chunks)))))
1839     (parse-type (chunks)
1840     (expecting "a file type" chunks)
1841     (setq type (maybe-make-logical-pattern namestr chunks))
1842     (expecting-dot (cdr chunks)))
1843     (parse-version (chunks)
1844     (let ((str (expecting "a positive integer, * or NEWEST"
1845     chunks)))
1846     (cond
1847     ((string= str "*") (setq version :wild))
1848     ((string= str "NEWEST") (setq version :newest))
1849     (t
1850     (multiple-value-bind
1851     (res pos)
1852     (parse-integer str :junk-allowed t)
1853     (unless (and res (plusp res))
1854     (error 'namestring-parse-error
1855     :complaint "Expected a positive integer, ~
1856     got ~S"
1857     :arguments (list str)
1858     :namestring namestr
1859     :offset (+ pos (cdar chunks))))
1860     (setq version res)))))
1861     (when (cdr chunks)
1862     (error 'namestring-parse-error
1863     :complaint "Extra stuff after end of file name."
1864     :namestring namestr
1865     :offset (cdadr chunks)))))
1866     (parse-host (logical-chunkify namestr start end)))
1867 pw 1.30 (values host :unspecific
1868 toy 1.59 (directory)
1869 pw 1.30 name type version))))
1870 phg 1.12
1871 ram 1.17
1872     ;;; Can't defvar here because not all host methods are loaded yet.
1873     (declaim (special *logical-pathname-defaults*))
1874    
1875     ;;; LOGICAL-PATHNAME -- Public
1876 phg 1.13 ;;;
1877 ram 1.17 (defun logical-pathname (pathspec)
1878     "Converts the pathspec argument to a logical-pathname and returns it."
1879     (declare (type (or logical-pathname string stream) pathspec)
1880     (values logical-pathname))
1881     (if (typep pathspec 'logical-pathname)
1882     pathspec
1883     (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1884     (when (eq (%pathname-host res)
1885     (%pathname-host *logical-pathname-defaults*))
1886 pw 1.43 (error
1887     'simple-type-error
1888     :format-control "Logical namestring does not specify a host:~% ~S"
1889     :format-arguments (list pathspec)
1890     :datum pathspec
1891     :expected-type '(satisfies logical-pathname-namestring-p)))
1892 rtoy 1.71 ;; Make sure the result is a logical pathname. This can
1893     ;; happen if the pathspec is stream, and the stream was opened
1894     ;; with a pathname instead of a logical-pathname.
1895     (check-type res logical-pathname)
1896 ram 1.17 res)))
1897 phg 1.12
1898 pw 1.43
1899 ram 1.17
1900     ;;;; Logical pathname unparsing:
1901    
1902 phg 1.13 ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal
1903     ;;;
1904 phg 1.12 (defun unparse-logical-directory (pathname)
1905 ram 1.17 (declare (type pathname pathname))
1906     (collect ((pieces))
1907     (let ((directory (%pathname-directory pathname)))
1908     (when directory
1909     (ecase (pop directory)
1910     (:absolute) ;; Nothing special.
1911     (:relative (pieces ";")))
1912     (dolist (dir directory)
1913     (cond ((or (stringp dir) (pattern-p dir))
1914     (pieces (unparse-logical-piece dir))
1915     (pieces ";"))
1916     ((eq dir :wild)
1917     (pieces "*;"))
1918     ((eq dir :wild-inferiors)
1919     (pieces "**;"))
1920     (t
1921     (error "Invalid directory component: ~S" dir))))))
1922     (apply #'concatenate 'simple-string (pieces))))
1923 phg 1.12
1924 ram 1.17
1925 phg 1.13 ;;; UNPARSE-LOGICAL-PIECE -- Internal
1926     ;;;
1927 phg 1.12 (defun unparse-logical-piece (thing)
1928     (etypecase thing
1929 ram 1.17 (simple-string thing)
1930 phg 1.12 (pattern
1931     (collect ((strings))
1932 ram 1.17 (dolist (piece (pattern-pieces thing))
1933     (etypecase piece
1934     (simple-string (strings piece))
1935     (keyword
1936     (cond ((eq piece :wild-inferiors)
1937     (strings "**"))
1938     ((eq piece :multi-char-wild)
1939     (strings "*"))
1940     (t (error "Invalid keyword: ~S" piece))))))
1941     (apply #'concatenate 'simple-string (strings))))))
1942 phg 1.12
1943 dtc 1.36 ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
1944     ;;;
1945     (defun unparse-enough-namestring (pathname defaults)
1946     (let* ((path-dir (pathname-directory pathname))
1947 rtoy 1.77 (def-dir (pathname-directory defaults))
1948     (enough-dir
1949     ;; Go down the directory lists to see what matches. What's
1950     ;; left is what we want, more or less. But there has to be
1951     ;; something in common.
1952     (cond ((and (eq (first path-dir) (first def-dir))
1953     (eq (first path-dir) :absolute)
1954     (second path-dir)
1955     (second def-dir)
1956     (equal (second path-dir) (second def-dir)))
1957     ;; Both paths are :absolute, so find where the common
1958     ;; parts end and return what's left
1959     (do* ((p (rest path-dir) (rest p))
1960     (d (rest def-dir) (rest d)))
1961     ((or (endp p) (endp d)
1962     (not (equal (first p) (first d))))
1963     `(:relative ,@p))))
1964     (t
1965     ;; Both paths are absolute, but there's nothing in
1966     ;; common, so return the original. Or one path is
1967     ;; :relative, so just return the original path. If
1968     ;; the original path is :relative, then that's the
1969     ;; right one. If PATH-DIR is :absolute, we want to
1970     ;; return that except when DEF-DIR is :absolute, as
1971     ;; handled above. so return the original directory.
1972     path-dir))))
1973     (namestring (make-pathname :host (%pathname-host pathname)
1974     :directory enough-dir
1975     :name (pathname-name pathname)
1976     :type (pathname-type pathname)
1977     :version (pathname-version pathname)))))
1978 phg 1.12
1979 phg 1.13 ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1980     ;;;
1981 phg 1.12 (defun unparse-logical-namestring (pathname)
1982     (declare (type logical-pathname pathname))
1983     (concatenate 'simple-string
1984 ram 1.17 (logical-host-name (%pathname-host pathname)) ":"
1985 phg 1.12 (unparse-logical-directory pathname)
1986 ram 1.17 (unparse-unix-file pathname)))
1987 phg 1.12
1988 ram 1.17
1989     ;;;; Logical pathname translations:
1990 phg 1.12
1991 ram 1.17 ;;; CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS -- Internal
1992 phg 1.13 ;;;
1993     ;;; Verify that the list of translations consists of lists and prepare
1994 phg 1.16 ;;; canonical translations (parse pathnames and expand out wildcards into
1995     ;;; patterns).
1996 phg 1.13 ;;;
1997 ram 1.17 (defun canonicalize-logical-pathname-translations (transl-list host)
1998     (declare (type list transl-list) (type host host)
1999     (values list))
2000     (collect ((res))
2001     (dolist (tr transl-list)
2002     (unless (and (consp tr) (= (length tr) 2))
2003     (error "Logical pathname translation is not a two-list:~% ~S"
2004     tr))
2005     (let ((from (first tr)))
2006     (res (list (if (typep from 'logical-pathname)
2007     from
2008     (parse-namestring from host))
2009     (pathname (second tr))))))
2010     (res)))
2011 phg 1.12
2012 ram 1.17
2013 phg 1.13 ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public
2014     ;;;
2015 phg 1.12 (defun logical-pathname-translations (host)
2016     "Return the (logical) host object argument's list of translations."
2017 ram 1.17 (declare (type (or string logical-host) host)
2018 phg 1.12 (values list))
2019 ram 1.17 (logical-host-translations (find-logical-host host)))
2020 phg 1.12
2021 phg 1.13 ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public
2022     ;;;
2023 phg 1.12 (defun (setf logical-pathname-translations) (translations host)
2024     "Set the translations list for the logical host argument.
2025     Return translations."
2026 ram 1.17 (declare (type (or string logical-host) host)
2027 phg 1.12 (type list translations)
2028     (values list))
2029    
2030 toy 1.63 (let ((maybe-search-list-host (concatenate 'string host ":")))
2031 rtoy 1.64 (when (and (not (logical-pathname-p (pathname maybe-search-list-host)))
2032     (search-list-defined-p maybe-search-list-host))
2033 toy 1.63 (cerror "Clobber search-list host with logical pathname host"
2034     "~S names a CMUCL search-list"
2035     host)))
2036 ram 1.17 (let ((host (intern-logical-host host)))
2037     (setf (logical-host-canon-transls host)
2038     (canonicalize-logical-pathname-translations translations host))
2039     (setf (logical-host-translations host) translations)))
2040    
2041    
2042 phg 1.12 ;;; The search mechanism for loading pathname translations uses the CMUCL
2043     ;;; extension of search-lists. The user can add to the library: search-list
2044     ;;; using setf. The file for translations should have the name defined by
2045 phg 1.14 ;;; the hostname (a string) and with type component "translations".
2046 phg 1.12
2047 phg 1.13 ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
2048     ;;;
2049 pw 1.43 (defun load-logical-pathname-translations (host)
2050     "Search for a logical pathname named host, if not already defined. If already
2051     defined no attempt to find or load a definition is attempted and NIL is
2052     returned. If host is not already defined, but definition is found and loaded
2053     successfully, T is returned, else error."
2054     (declare (type string host)
2055     (values (member t nil)))
2056 pw 1.44 (let ((*autoload-translations* nil))
2057     (unless (or (string-equal host "library")
2058     (find-logical-host host nil))
2059     (with-open-file (in-str (make-pathname :defaults "library:"
2060     :name (string-downcase host)
2061     :type "translations"))
2062     (if *load-verbose*
2063     (format *error-output*
2064     ";; Loading pathname translations from ~A~%"
2065     (namestring (truename in-str))))
2066     (setf (logical-pathname-translations host) (read in-str)))
2067     t)))
2068 phg 1.12
2069 phg 1.13 ;;; TRANSLATE-LOGICAL-PATHNAME -- Public
2070     ;;;
2071 phg 1.12 (defun translate-logical-pathname (pathname &key)
2072     "Translates pathname to a physical pathname, which is returned."
2073 phg 1.16 (declare (type path-designator pathname)
2074     (values (or null pathname)))
2075 ram 1.17 (typecase pathname
2076     (logical-pathname
2077     (dolist (x (logical-host-canon-transls (%pathname-host pathname))
2078 dtc 1.34 (error 'simple-file-error
2079     :pathname pathname
2080     :format-control "No translation for ~S"
2081     :format-arguments (list pathname)))
2082 ram 1.17 (destructuring-bind (from to) x
2083     (when (pathname-match-p pathname from)
2084     (return (translate-logical-pathname
2085     (translate-pathname pathname from to)))))))
2086     (pathname pathname)
2087 ram 1.22 (stream (translate-logical-pathname (pathname pathname)))
2088 toy 1.58 (t (translate-logical-pathname (pathname pathname)))))
2089 phg 1.12
2090 ram 1.17 (defvar *logical-pathname-defaults*
2091     (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific
2092     nil nil nil nil))

  ViewVC Help
Powered by ViewVC 1.1.5