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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5