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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5