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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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