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

Diff of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15 by phg, Fri Sep 4 15:17:24 1992 UTC revision 1.16 by phg, Thu Jul 15 18:02:46 1993 UTC
# Line 36  Line 36 
36  (in-package "LISP")  (in-package "LISP")
37    
38    
39  ;;;; Structures and types.  ;;;; HOST structures
40    
41  ;;; Pathname structure holds the essential properties of the parsed path.  ;;;   The host structure holds the functions that both parse the pathname
42    ;;; information into sturcture slot entries, and after translation the inverse
43    ;;; (unparse) functions.
44    ;;;
45    (defstruct (host
46                (:print-function %print-host))
47      (parse (required-argument) :type function)
48      (unparse (required-argument) :type function)
49      (unparse-host (required-argument) :type function)
50      (unparse-directory (required-argument) :type function)
51      (unparse-file (required-argument) :type function)
52      (unparse-enough (required-argument) :type function)
53      (customary-case (required-argument) :type (member :upper :lower)))
54    
55    ;;; %PRINT-HOST -- Internal
56    ;;;
57    (defun %print-host (host stream depth)
58      (declare (ignore depth))
59      (print-unreadable-object (host stream :type t :identity t)))
60    
61    (defstruct (logical-host
62                (:include host
63                          (:parse #'parse-logical-namestring)
64                          (:unparse #'unparse-logical-namestring)
65                          (:unparse-host #'unparse-logical-host)
66                          (:unparse-directory #'unparse-logical-directory)
67                          (:unparse-file #'unparse-logical-file)
68                          (:unparse-enough #'identity)
69                          (:customary-case :upper)))
70      (name "" :type simple-base-string)
71      (translations nil :type list)
72      (canon-transls nil :type list))
73    
74    
75    ;;;; Pathname structures
76    
77  (defstruct (pathname  (defstruct (pathname
78              (:conc-name %pathname-)              (:conc-name %pathname-)
# Line 50  Line 84 
84    ;; Slot holds the host, at present either a UNIX or logical host.    ;; Slot holds the host, at present either a UNIX or logical host.
85    (host nil :type (or host null))    (host nil :type (or host null))
86    ;; Device is the name of a logical or physical device holding files.    ;; Device is the name of a logical or physical device holding files.
87    (device nil :type (member nil :unspecific))    (device nil :type (or null (member :unspecific)))
88    ;; A list of strings that are the component subdirectory components.    ;; A list of strings that are the component subdirectory components.
89    (directory nil :type list)    (directory nil :type list)
90    ;; The filename.    ;; The filename.
91    (name nil :type (or simple-string pattern null))    (name nil :type (or simple-string pattern null (member :wild)))
92    ;; The type extension of the file.    ;; The type extension of the file.
93    (type nil :type (or simple-string pattern null (member :unspecific)))    (type nil :type (or simple-string pattern null (member :wild :unspecific)))
94    ;; The version number of the file, a positive integer, but not supported    ;; The version number of the file, a positive integer, but not supported
95    ;; on standard UNIX filesystems.    ;; on standard UNIX filesystems.
96    (version nil :type (or integer null (member :newest :wild))))    (version nil :type (or integer null (member :newest :wild))))
# Line 97  Line 131 
131                      (%pathname-type pathname)                      (%pathname-type pathname)
132                      (%pathname-version pathname))))))                      (%pathname-version pathname))))))
133    
134  ;;;; HOST structure  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   
 ;;;   The host structure holds the functions that both parse the pathname  
 ;;; information into sturcture slot entries, and after translation the inverse  
 ;;; (unparse) functions.  
135  ;;;  ;;;
136  (defstruct (host  ;;; Logical pathnames have the following format:
137              (:print-function %print-host))  ;;;
138    (parse (required-argument) :type function)  ;;; logical-namestring ::=
139    (unparse (required-argument) :type function)  ;;;         [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
140    (unparse-host (required-argument) :type function)  ;;;
141    (unparse-directory (required-argument) :type function)  ;;; host ::= word
142    (unparse-file (required-argument) :type function)  ;;; directory ::= word | wildcard-word | **
143    (unparse-enough (required-argument) :type function)  ;;; name ::= word | wildcard-word
144    (customary-case (required-argument) :type (member :upper :lower)))  ;;; type ::= word | wildcard-word
145    ;;; version ::= pos-int | newest | NEWEST | *
146    ;;; word ::= {uppercase-letter | digit | -}+
147    ;;; wildcard-word ::= [word] '* {word '*}* [word]
148    ;;; pos-int ::= integer > 0
149    ;;;
150    ;;; Physical pathnames include all these slots and a device slot.
151    ;;;
152    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153    
154  ;;; %PRINT-HOST -- Internal  ;; Logical pathnames are a subclass of pathname, their class relations are
155    ;; mimiced using structures for efficency.
156    
157    (defstruct (logical-pathname
158                (:conc-name %logical-pathname-)
159                (:print-function %print-logical-pathname)
160                (:include pathname)
161                (:constructor
162                 %make-logical-pathname (host device directory name type version))
163                (:predicate logical-pathname-p)
164                (:make-load-form-fun :just-dump-it-normally)))
165    
166    ;;; %PRINT-LOGICAL-PATHNAME -- Internal
167  ;;;  ;;;
168  (defun %print-host (host stream depth)  ;;;   The printed representation of the logical-pathname structure.
169    ;;; The potential conflict with search-lists requires isolating the printed
170    ;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
171    ;;;
172    (defun %print-logical-pathname (pathname stream depth)
173    (declare (ignore depth))    (declare (ignore depth))
174    (print-unreadable-object (host stream :type t :identity t)))    (let ((namestring (handler-case (namestring pathname)
175                          (error nil))))
176        (cond (namestring
177               (format stream "#.(logical-pathname ~S)" namestring))
178              (*print-readably*
179               (error "~S Cannot be printed readably." pathname))
180              (*print-pretty*
181               (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
182                 (funcall (formatter
183                           "~2IUnprintable pathname: ~_Host=~S, ~_~
184                            Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
185                            Type=~S, ~_Version=~S")
186                          stream
187                          (%pathname-host pathname)
188                          (%pathname-directory pathname)
189                          (%pathname-name pathname)
190                          (%pathname-type pathname)
191                          (%pathname-version pathname))))
192              (t
193               (funcall (formatter "#<Unprintable pathname, Host=~S,  ~
194                                    Directory=~S, File=~S, Name=~S, Version=~S>")
195                        stream
196                        (%pathname-host pathname)
197                        (%pathname-directory pathname)
198                        (%pathname-name pathname)
199                        (%pathname-type pathname)
200                        (%pathname-version pathname))))))
201    
202    ;;; *LOGICAL-HOSTS* --internal.
203    ;;;
204    ;;; Hash table searching maps a logical-pathname's host to their physical
205    ;;; pathname translation.
206    
207    (defvar *logical-hosts* (make-hash-table :test #'equal))
208    
209    ;;; PATHSPEC -- internal type
210    ;;;
211    (deftype path-designator ()
212      "A path specification, either a string, stream or pathname."
213      '(or simple-base-string stream pathname))
214    
215    
216  ;;;; Patterns  ;;;; Patterns
# Line 164  Line 257 
257    
258  ;;; PATTERN-MATCHES -- Internal  ;;; PATTERN-MATCHES -- Internal
259  ;;;  ;;;
260    ;;;   If the string matches the pattern returns the multiple valuse T and a
261    ;;; list of the matched strings.
262    ;;;
263  (defun pattern-matches (pattern string)  (defun pattern-matches (pattern string)
264    (declare (type pattern pattern)    (declare (type pattern pattern)
265             (type simple-string string))             (type simple-string string))
# Line 204  Line 300 
300                          (and (< start len)                          (and (< start len)
301                               (matches (cdr pieces) (1+ start) subs t                               (matches (cdr pieces) (1+ start) subs t
302                                        (cons (schar string start) chars))))                                        (cons (schar string start) chars))))
303                         ((member :multi-char-wild)                         ((member :wild :multi-char-wild)
304                          (multiple-value-bind                          (multiple-value-bind
305                              (won new-subs)                              (won new-subs)
306                              (matches (cdr pieces) start subs t chars)                              (matches (cdr pieces) start subs t chars)
# Line 219  Line 315 
315            (matches (pattern-pieces pattern) 0 nil nil nil)            (matches (pattern-pieces pattern) 0 nil nil nil)
316          (values won (reverse subs))))))          (values won (reverse subs))))))
317    
318    ;;; VERIFY-WORD-CHAR-P -- Internal
319    ;;;
320    (defun verify-word-char-p (ch)
321      (if (or (eq ch #\-)
322              (and (char<= #\A ch) (char<= ch #\Z))
323              (and (char<= #\0 ch) (char<= ch #\9)))
324          t
325          nil))
326    
327    (defun verify-wild-word-char-p (ch)
328      (if (or (and (char<= #\A ch) (char<= ch #\Z))
329              (and (char<= #\0 ch) (char<= ch #\9)))
330          t
331          nil))
332    
333    ;;; VERIFY-WORD-P -- Internal
334    ;;;
335    (defun verify-word-p (wd)
336      (declare (type simple-base-string wd))
337      (let ((ch nil))
338        (dotimes (j (length wd))
339          (setf ch (schar wd j))
340          (unless (verify-word-char-p ch)
341            (error "~S is not a wildcard word, it contains an illegal character ~
342                    ~S" wd ch))))
343      t)
344    
345    ;;; HOSTS-MATCH-P -- Internal
346    ;;;
347    ;;;   Predicate for host matching.  No :wild hosts permitted.
348    ;;;
349    (defun hosts-match-p (from-host to-host)
350      (declare (type (or host simple-base-string) from-host to-host))
351      (typecase from-host
352        (logical-host ; Subclass on logical-host first.
353         (typecase to-host
354           (logical-host
355            (eq from-host to-host))
356           (host
357            nil)
358           (simple-base-string
359            (eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
360        (host
361         (typecase to-host
362           (logical-host
363            nil)
364           (host
365            (eq from-host to-host))
366           (simple-base-string
367            (eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
368        (simple-base-string
369         (verify-word-p from-host)
370         (typecase to-host
371           (logical-host
372            (eq to-host (gethash (string-upcase from-host) *logical-hosts*)))
373           (simple-base-string
374            (verify-word-p to-host)
375            (string-equal from-host to-host))))))
376    
377    ;;; WILDCARD-WORD-PARSE -- Internal
378    ;;;
379    ;;;   Parse a potential wildcard-word for its subcomponents as a pattern,
380    ;;; and return an error if the syntax is inconsistent.
381    ;;;
382    (defun wildcard-word-parse (wd)
383      (declare (type simple-base-string wd)
384               (values (or simple-base-string pattern)))
385      (let* ((c nil)
386             (*-p (position #\* wd))
387             (start 0)
388             (end (length wd))
389             (end-1 (1- end))
390             (piece nil)
391             (pat nil))
392        (when (and (not *-p) (verify-word-p wd))
393          (return-from wildcard-word-parse wd))
394        (dotimes (j end)
395          (setf c (schar wd j))
396         (when (eq c #\*)
397            ;; Finish the preceeding word, place in pattern.
398            (setf piece (subseq wd start j))
399            (when (< 0 (length piece))
400              (push piece pat))
401            (push :wild pat)
402            (setf *-p t
403                  start (1+ j))
404            (when (and (< j end-1) (eq (schar wd (1+ j)) #\*))
405                  (error "~S is not a wildcard word, it contains a **." wd)))
406          ;; Verify c is a legitimate wildcard character.
407          (unless (verify-wild-word-char-p c)
408            (error "~S is not a wildcard word, it contains an illegal character: ~
409                    ~S" wd c))
410          (when (= j end-1)
411            (setf piece (subseq wd start (1+ j)))
412            (when (< 0 (length piece))
413              (push piece pat))))
414        (values (make-pattern (nreverse pat)))))
415    
416  ;;; COMPONENTS-MATCH -- Internal  ;;; COMPONENTS-MATCH -- Internal
417  ;;;  ;;;
418  ;;;   Wilds in to are matched against from where both are either lists  ;;;   Wilds in "to" are matched against "from" where both are strings,
419  ;;; containing :wild and :wild-inferiors, patterns or strings.  ;;; patterns or lists containing :wild and :wild-inferiors.
420  ;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory  ;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory
421  ;;; component. Not communative.  ;;; component. Not communative. Result is a Boolean or a member result.
422  ;;;  ;;;
423  (defun components-match (from to)  (defun components-match (from to)
424      (declare (type (or simple-base-string symbol pattern cons fixnum) from)
425               (type (or simple-base-string symbol pattern cons fixnum) to))
426    (or (eq from to)    (or (eq from to)
427        (typecase from        (typecase from
428          (simple-base-string          (simple-base-string
429             ;; Match can either be a identical pattern modulo wildcards or the
430             ;; same string.
431           (typecase to           (typecase to
432             (pattern             (pattern
433              (values (pattern-matches to from)))              (values (pattern-matches to from)))
434             (simple-base-string             (simple-base-string
435              (string-equal from to))))              (string-equal from to))))
436          (pattern          (pattern
437             ;; Match is a identical pattern.
438           (and (pattern-p to) (pattern= from to)))           (and (pattern-p to) (pattern= from to)))
439          ((member :wild) ; :WILD component matches any string, or pattern or NIL.          ((member :wild)
440             ;; :WILD component matches any string, or pattern or NIL.
441           (or (stringp to)           (or (stringp to)
442               (logical-host-p to)               (logical-host-p to)
443               (pattern-p to)               (pattern-p to)
444               (member to '(nil :unspecific :newest :wild :wild-inferiors))))               (member to '(nil :unspecific :newest :wild :wild-inferiors))))
445          ((member :newest)          ((member :newest)
446           (member to '(:wild)))           ;; :newest matches itself, a wildcard or a positive integer version
447          (cons ; Watch for wildcards.           ;; number.
448             (or (member to '(:wild :newest)) (and (integerp to) (plusp to))))
449            (cons ;; A list that may include wildcards.
450           (and (consp from)           (and (consp from)
451                (let ((from1 (first from))                (let ((from1 (first from))
452                      (from2 nil)                      (from2 nil)
# Line 276  Line 478 
478           (and (pattern-p from)           (and (pattern-p from)
479                (equal (pattern-pieces from) '(:multi-char-wild)))))))                (equal (pattern-pieces from) '(:multi-char-wild)))))))
480    
   
 ;;;; Utilities.  
   
481  ;;; COMPARE-COMPONENT  -- Internal  ;;; COMPARE-COMPONENT  -- Internal
482  ;;;  ;;;
483  ;;; A predicate for comparing two pathname slot component sub-entries.  ;;; A predicate for comparing two pathname slot component sub-entries.
# Line 307  Line 506 
506  ;;; PATHNAME= -- Internal  ;;; PATHNAME= -- Internal
507  ;;;  ;;;
508  (defun pathname= (pathname1 pathname2)  (defun pathname= (pathname1 pathname2)
509      (declare (type pathname pathname1)
510               (type pathname pathname2))
511    (and (eq (%pathname-host pathname1)    (and (eq (%pathname-host pathname1)
512             (%pathname-host pathname2))             (%pathname-host pathname2))
513         (compare-component (%pathname-device pathname1)         (compare-component (%pathname-device pathname1)
# Line 321  Line 522 
522                            (%pathname-version pathname2))))                            (%pathname-version pathname2))))
523    
524  ;;; WITH-PATHNAME -- Internal  ;;; WITH-PATHNAME -- Internal
525  ;;;   Converts the var, a pathname designator (a pathname, or string, or  ;;;   Converts the expr, a pathname designator (a pathname, or string, or
526  ;;; stream), into a pathname.  ;;; stream), into a pathname.
527  ;;;  ;;;
528  (defmacro with-pathname ((var expr) &body body)  (defmacro with-pathname ((var expr) &body body)
# Line 332  Line 533 
533                     (stream (parse-namestring (file-name ,var)))))))                     (stream (parse-namestring (file-name ,var)))))))
534       ,@body))       ,@body))
535    
536    ;;; WITH-HOST -- Internal
537    ;;;
538    ;;; Converts the var, a host or string name for a host, into a logical-host
539    ;;; structure or nil if not defined.
540    ;;;
541    (defmacro with-host ((var expr) &body body)
542      `(let ((,var (let ((,var ,expr))
543                     (typecase ,var
544                       (logical-host ,var)
545                       (string (gethash ,var *logical-hosts*))
546                       (t nil)))))
547         ,@body))
548    
549  ;;; PATHNAME -- Interface  ;;; PATHNAME -- Interface
550  ;;;  ;;;
551  (defun pathname (thing)  (defun pathname (thing)
552    "Convert thing (a pathname, string or stream) into a pathname."    "Convert thing (a pathname, string or stream) into a pathname."
553    (declare (type pathnamelike thing))    (declare (type path-designator thing))
554    (with-pathname (pathname thing)    (with-pathname (pathname thing)
555      pathname))      pathname))
556    
# Line 443  Line 656 
656                          (default-version :newest))                          (default-version :newest))
657    "Construct a filled in pathname by completing the unspecified components    "Construct a filled in pathname by completing the unspecified components
658     from the defaults."     from the defaults."
659      (declare (type path-designator pathname)
660               (type path-designator defaults)
661               (values pathname))
662    (with-pathname (defaults defaults)    (with-pathname (defaults defaults)
663      (let ((pathname (let ((*default-pathname-defaults* defaults))      (let ((pathname (let ((*default-pathname-defaults* defaults))
664                        (pathname pathname))))                        (pathname pathname))))
# Line 507  Line 723 
723    
724  ;;; MAKE-PATHNAME -- Interface  ;;; MAKE-PATHNAME -- Interface
725  ;;;  ;;;
726  (defun make-pathname (&key (host nil hostp)  (defun make-pathname (&key host
727                             (device nil devp)                             (device nil devp)
728                             (directory nil dirp)                             (directory nil dirp)
729                             (name nil namep)                             (name nil namep)
730                             (type nil typep)                             (type nil typep)
731                             (version nil versionp)                             (version nil versionp)
732                             defaults (case :local))                             defaults
733                               (case :local))
734    "Makes a new pathname from the component arguments.  Note that host is a host-    "Makes a new pathname from the component arguments.  Note that host is a host-
735     structure."     structure."
736    (declare (type (or host null) host)    (declare (type (or host null) host)
# Line 522  Line 739 
739             (type (or null string pattern (member :wild)) name)             (type (or null string pattern (member :wild)) name)
740             (type (or null string pattern (member :unspecific :wild)) type)             (type (or null string pattern (member :unspecific :wild)) type)
741             (type (or null integer (member :unspecific :wild :newest)) version)             (type (or null integer (member :unspecific :wild :newest)) version)
742             (type (or pathnamelike null) defaults)             (type (or path-designator null) defaults)
743             (type (member :common :local) case))             (type (member :common :local) case))
744    (let* ((defaults (if defaults    (let* ((defaults (when defaults
745                         (with-pathname (defaults defaults) defaults)))                       (with-pathname (defaults defaults) defaults)))
746           (default-host (if defaults           (default-host (if defaults
747                             (%pathname-host defaults)                             (%pathname-host defaults)
748                             (pathname-host *default-pathname-defaults*)))                             (pathname-host *default-pathname-defaults*)))
749           (host (if hostp host default-host))           (host (or host default-host))
750           (diddle-args (and (eq case :common)           (diddle-args (and (eq case :common)
751                             (eq (host-customary-case host) :lower)))                             (eq (host-customary-case host) :lower)))
752           (diddle-defaults           (diddle-defaults
753            (not (eq (host-customary-case host)            (not (eq (host-customary-case host)
754                     (host-customary-case default-host)))))                     (host-customary-case default-host))))
755             (dev (if devp device (if defaults (%pathname-device defaults))))
756             (dir (import-directory directory diddle-args))
757             (ver (cond
758                   (versionp version)
759                   (defaults (%pathname-version defaults))
760                   (t nil))))
761        (when (and defaults (not dirp))
762          (setf dir
763                (merge-directories dir
764                                   (%pathname-directory defaults)
765                                   diddle-defaults)))
766    
767      (macrolet ((pick (var varp field)      (macrolet ((pick (var varp field)
768                   `(cond ((eq ,var :wild)                   `(cond ((eq ,var :wild)
769                           (make-pattern (list :multi-char-wild)))                           (make-pattern (list :multi-char-wild)))
# Line 551  Line 780 
780                                              diddle-defaults))                                              diddle-defaults))
781                          (t                          (t
782                           nil))))                           nil))))
783        (%make-pathname        (if (logical-host-p host)
784         host            (%make-logical-pathname
785         (if devp device (if defaults (%pathname-device defaults)))             host
786         (let ((dir (import-directory directory diddle-args)))             nil
787           (if (and defaults (not dirp))             dir
788               (merge-directories dir             (pick name namep %pathname-name)
789                                  (%pathname-directory defaults)             (pick type typep %pathname-type)
790                                  diddle-defaults)             ver)
791               dir))            (%make-pathname
792         (pick name namep %pathname-name)             host
793         (pick type typep %pathname-type)             dev
794         (cond             dir
795           (versionp version)             (pick name namep %pathname-name)
796           (defaults (%pathname-version defaults))             (pick type typep %pathname-type)
797           (t nil))))))             ver)))))
798    
799  ;;; PATHNAME-HOST -- Interface  ;;; PATHNAME-HOST -- Interface
800  ;;;  ;;;
801  (defun pathname-host (pathname &key (case :local))  (defun pathname-host (pathname &key (case :local))
802    "Accessor for the pathname's host."    "Accessor for the pathname's host."
803    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
804             (type (member :local :common) case)             (type (member :local :common) case)
805               (values host)
806             (ignore case))             (ignore case))
807    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
808      (%pathname-host pathname)))      (%pathname-host pathname)))
# Line 581  Line 811 
811  ;;;  ;;;
812  (defun pathname-device (pathname &key (case :local))  (defun pathname-device (pathname &key (case :local))
813    "Accessor for pathname's device."    "Accessor for pathname's device."
814    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
815             (type (member :local :common) case))             (type (member :local :common) case))
816    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
817      (maybe-diddle-case (%pathname-device pathname)      (maybe-diddle-case (%pathname-device pathname)
# Line 594  Line 824 
824  ;;;  ;;;
825  (defun pathname-directory (pathname &key (case :local))  (defun pathname-directory (pathname &key (case :local))
826    "Accessor for the pathname's directory list."    "Accessor for the pathname's directory list."
827    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
828             (type (member :local :common) case))             (type (member :local :common) case))
829    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
830      (maybe-diddle-case (%pathname-directory pathname)      (maybe-diddle-case (%pathname-directory pathname)
# Line 606  Line 836 
836  ;;;  ;;;
837  (defun pathname-name (pathname &key (case :local))  (defun pathname-name (pathname &key (case :local))
838    "Accessor for the pathname's name."    "Accessor for the pathname's name."
839    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
840             (type (member :local :common) case))             (type (member :local :common) case))
841    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
842      (maybe-diddle-case (%pathname-name pathname)      (maybe-diddle-case (%pathname-name pathname)
# Line 619  Line 849 
849  ;;;  ;;;
850  (defun pathname-type (pathname &key (case :local))  (defun pathname-type (pathname &key (case :local))
851    "Accessor for the pathname's name."    "Accessor for the pathname's name."
852    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
853             (type (member :local :common) case))             (type (member :local :common) case))
854    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
855      (maybe-diddle-case (%pathname-type pathname)      (maybe-diddle-case (%pathname-type pathname)
# Line 627  Line 857 
857                              (eq (host-customary-case                              (eq (host-customary-case
858                                   (%pathname-host pathname))                                   (%pathname-host pathname))
859                                  :lower)))))                                  :lower)))))
860    
861  ;;; PATHNAME-VERSION  ;;; PATHNAME-VERSION
862  ;;;  ;;;
863  (defun pathname-version (pathname)  (defun pathname-version (pathname)
864    "Accessor for the pathname's version."    "Accessor for the pathname's version."
865    (declare (type pathnamelike pathname))    (declare (type path-designator pathname))
866    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
867      (%pathname-version pathname)))      (%pathname-version pathname)))
868    
# Line 654  Line 885 
885     (offset :init-form (required-argument)))     (offset :init-form (required-argument)))
886    (:report %print-namestring-parse-error))    (:report %print-namestring-parse-error))
887    
888  ;;; %PARSE-NAMESTRING -- Internal  ;;; %PARSE-PHYSICAL-NAMESTRING -- Internal
889  ;;;  ;;;
890  (defun %parse-namestring (namestr start end host junk-allowed)  (defun %parse-physical-namestring (namestr things-host start end junk-allowed)
891    (declare (type string namestr)    (declare (type host things-host)
892             (type index start end)             (type string namestr)
893             (type host host)             (type index start end))
            (values (or null pathname) index))  
894    (cond (junk-allowed    (cond (junk-allowed
895           (handler-case (%parse-namestring namestr start end host nil)           (handler-case
896                 (%parse-physical-namestring namestr things-host start end nil)
897             (namestring-parse-error (condition)             (namestring-parse-error (condition)
898                 (values nil (namestring-parse-error-offset condition)))))               (values nil (namestring-parse-error-offset condition)))))
899          ((simple-string-p namestr)          ((simple-string-p namestr)
900           (multiple-value-bind           (multiple-value-bind
901               (new-host device directory file type version)               (new-host device directory file type version)
902               (funcall (host-parse host) namestr start end)               (funcall (host-parse things-host) namestr start end)
903             (values (%make-pathname (or new-host host)             (declare (ignore new-host))
904                                     device             (values
905                                     directory              (%make-pathname things-host device directory file type version)
906                                     file              end)))
                                    type  
                                    version)  
                    end)))  
907          (t          (t
908           (%parse-namestring (coerce namestr 'simple-string)           (%parse-physical-namestring (coerce namestr 'simple-base-string)
909                              start end host nil))))                                       things-host
910                                         start end nil))))
911    
912    ;;; %PARSE-LOGICAL-NAMESTRING -- Internal
913    ;;;
914    (defun %parse-logical-namestring (namestr things-host start end junk-allowed)
915      (declare (type logical-host things-host)
916               (type string namestr)
917               (type index start end))
918      (cond (junk-allowed
919             (handler-case
920                 (%parse-logical-namestring namestr things-host start end nil)
921               (namestring-parse-error
922                (condition)
923                (values nil (namestring-parse-error-offset condition)))))
924            ((simple-string-p namestr)
925             (multiple-value-bind
926                 (lpath end)
927                 (parse-logical-namestring namestr :host things-host
928                                           :start start :end end)
929               (values lpath end)))
930            (t
931             (%parse-logical-namestring (coerce namestr 'simple-base-string)
932                                        things-host
933                                        start end nil))))
934    
935    ;;; EXTRACT-PATH-PREFIX -- Internal
936    ;;;
937    ;;;   Extract the host or search-list prefix from the beginning of the
938    ;;; namestring, use it to return the host structure, the colon-position
939    ;;; in the namestring for further search, and whether the namestring specifies
940    ;;; a logical namestring.
941    ;;;
942    (defun extract-path-prefix (namestr start end host defaults)
943      (declare (type simple-base-string namestr)
944               (type index start end)
945               (type (or null host) host)
946               (type pathname defaults)
947               (values host index (or t null)))
948      (let* ((colon-pos (position #\: namestr :start start :end end))
949             (host (if host host (%pathname-host defaults)))
950             (host-temp nil)
951             (lpathp nil)
952             (prefix-str nil))
953        (cond ((logical-host-p host)
954               (setf lpathp t)
955               (logical-host-name host))
956              (t
957               (funcall (host-unparse-host host) host)))
958        (unless colon-pos ; No logical host or search-list prefix to namestr.
959          (return-from extract-path-prefix (values host 0 lpathp)))
960        (setf prefix-str (subseq namestr start colon-pos)
961              lpathp (logical-word-p prefix-str))
962        (cond (lpathp ; If a legitimate logical host name prefix exists, use it.
963               (setf host-temp (gethash prefix-str *logical-hosts*))
964               (unless (and prefix-str host-temp)
965                 (error "The logical-host ~S is not defined." prefix-str))
966               (setf host host-temp))
967              (t
968               (unless (gethash prefix-str *search-lists*)
969                 (error "The prefix ~S to the pathname string ~S is not a ~
970                         registered search-list." prefix-str namestr))))
971        (values host colon-pos lpathp)))
972    
973  ;;; PARSE-NAMESTRING -- Interface  ;;; PARSE-NAMESTRING -- Interface
974  ;;;  ;;;
975  (defun parse-namestring (thing  (defun parse-namestring (thing
976                           &optional host (defaults *default-pathname-defaults*)                           &optional host (defaults *default-pathname-defaults*)
977                           &key (start 0) end junk-allowed)                           &key (start 0) end junk-allowed)
978    "Converts thing, a pathname designator, into a pathname structure, returns    "Converts pathname, a pathname designator, into a pathname structure,
979     the printed representation."     for a physical pathname, returns the printed representation. Host may be
980    (declare (type (or simple-base-string stream pathname) thing)     a physical host structure or host namestring."
981      (declare (type path-designator thing)
982             (type (or null host) host)             (type (or null host) host)
983             (type pathnamelike defaults)             (type pathname defaults)
984             (type index start)             (type index start)
985             (type (or index null) end)             (type (or index null) end)
986             (type (or null (not null)) junk-allowed)             (type (or t null) junk-allowed)
987             (values (or null pathname) index))             (values (or null pathname) (or null index)))
988    (cond ((stringp thing)    (let* ((end1 (or end (length thing)))
989           (let* ((end1 (or end (length thing)))           (things-host nil)
990                  (things-host nil)           (colon-pos nil)
991                  (hosts-name (when host           (lpathp nil))
992                                (funcall (host-parse host) thing start end1))))      (typecase thing
993             (setf things-host        (simple-base-string
994                   (maybe-extract-logical-host thing start end1))         (multiple-value-setq
995             (when (and host things-host) ; A logical host and host are defined.             (things-host colon-pos lpathp)
996               (unless (string= things-host hosts-name)           (extract-path-prefix thing start end1 host defaults))
997                 (error "Hosts do not match: ~S in ~S and ~S."         (if lpathp
998                        things-host thing host)))             (%parse-logical-namestring thing
999             (if things-host                                        things-host
1000                 (unless (gethash (string-downcase things-host) *search-lists*)                                        colon-pos
1001                   ;; Not a search-list name, make it a logical-host name.                                        end1
1002                   (setf host (intern-logical-host things-host))))                                        junk-allowed)
1003             (%parse-namestring thing start end1             (%parse-physical-namestring thing
1004                                (or host                                         things-host
1005                                    (with-pathname (defaults defaults)                                         start
1006                                                   (%pathname-host defaults)))                                         end1
1007                                junk-allowed)))                                         junk-allowed)))
1008          ((pathnamep thing)        (pathname ; structure type
1009           (when host         (let* ((host (if host host (%pathname-host defaults)))
1010             (unless (eq host (%pathname-host thing))                (hosts-name (funcall (host-unparse-host host) host)))
1011               (error "Hosts do not match: ~S and ~S."           (unless (eq hosts-name (%pathname-host thing))
1012                      host             (error "Hosts do not match: ~S and ~S."
1013                      (%pathname-host thing))))                    hosts-name (%pathname-host thing))))
1014           (values thing start))         (values thing start))
1015          ((streamp thing)        (stream
1016           (let ((host-name (funcall (host-unparse-host host) host))         (let* ((stream-type (type-of thing))
1017                 (stream-type (type-of thing))                (things-host-name (host-namestring thing))
1018                 (stream-host-name (host-namestring thing)))                (host (if host host (%pathname-host defaults)))
1019             (unless (or (eq stream-type 'fd-stream)                (hosts-name (funcall (host-unparse-host host) host)))
1020                         ;;********Change fd-stream to file-stream in sources too.           (unless (or (eq stream-type 'fd-stream)
1021                         (eq stream-type 'synonym-stream))                       ;;######Change fd-stream to file-stream in sources too.
1022               (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~                       (eq stream-type 'synonym-stream))
1023                       or MAKE-SYNONYM-FILE." thing))             (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
1024             (unless (string-equal stream-host-name host-name)                     or MAKE-SYNONYM-FILE." thing))
1025               (error "Hosts do not match: ~S and ~S."           (unless (string-equal hosts-name things-host-name)
1026                      host             (error "Hosts do not match: ~S and ~S."
1027                      host-name)))                    hosts-name things-host-name)))
1028           (values thing start))))         (values (file-name thing) start)))))
1029    
1030  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
1031  ;;;  ;;;
1032  (defun namestring (pathname)  (defun namestring (pathname)
1033    "Construct the full (name)string form of the pathname."    "Construct the full (name)string form of the pathname."
1034    (declare (type pathnamelike pathname))    (declare (type path-designator pathname)
1035               (values (or null simple-base-string)))
1036    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1037      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1038        (cond ((logical-host-p host)        (cond ((logical-host-p host)
# Line 756  Line 1048 
1048  ;;;  ;;;
1049  (defun host-namestring (pathname)  (defun host-namestring (pathname)
1050    "Returns a string representation of the name of the host in the pathname."    "Returns a string representation of the name of the host in the pathname."
1051    (declare (type pathnamelike pathname))    (declare (type path-designator pathname)
1052               (values (or null simple-base-string)))
1053    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1054      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1055        (if host        (if host
# Line 769  Line 1062 
1062  ;;;  ;;;
1063  (defun directory-namestring (pathname)  (defun directory-namestring (pathname)
1064    "Returns a string representation of the directories used in the pathname."    "Returns a string representation of the directories used in the pathname."
1065    (declare (type pathnamelike pathname))    (declare (type path-designator pathname)
1066               (values (or null simple-base-string)))
1067    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1068      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1069        (if host        (if host
# Line 782  Line 1076 
1076  ;;;  ;;;
1077  (defun file-namestring (pathname)  (defun file-namestring (pathname)
1078    "Returns a string representation of the name used in the pathname."    "Returns a string representation of the name used in the pathname."
1079    (declare (type pathnamelike pathname))    (declare (type path-designator pathname)
1080               (values (or null simple-base-string)))
1081    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1082      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1083        (if host        (if host
# Line 797  Line 1092 
1092                            &optional (defaults *default-pathname-defaults*))                            &optional (defaults *default-pathname-defaults*))
1093    "Returns an abbreviated pathname sufficent to identify the pathname relative    "Returns an abbreviated pathname sufficent to identify the pathname relative
1094     to the defaults."     to the defaults."
1095    (declare (type pathnamelike pathname))    (declare (type path-designator pathname))
1096    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1097      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1098        (if host        (if host
# Line 814  Line 1109 
1109  ;;;  ;;;
1110  (defun wild-pathname-p (pathname &optional field-key)  (defun wild-pathname-p (pathname &optional field-key)
1111    "Predicate for determining whether pathname contains any wildcards."    "Predicate for determining whether pathname contains any wildcards."
1112    (declare (type pathnamelike pathname)    (declare (type path-designator pathname)
1113             (type (member nil :host :device :directory :name :type :version)             (type (member nil :host :device :directory :name :type :version)
1114                   field-key))                   field-key))
1115    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 826  Line 1121 
1121             (wild-pathname-p pathname :name)             (wild-pathname-p pathname :name)
1122             (wild-pathname-p pathname :type)             (wild-pathname-p pathname :type)
1123             (wild-pathname-p pathname :version)))             (wild-pathname-p pathname :version)))
1124        (:host        (:host (pattern-p (%pathname-host pathname)))
1125         (pattern-p (%pathname-host pathname)))        (:device (pattern-p (%pathname-host pathname)))
1126        (:device        (:directory (some #'pattern-p (%pathname-directory pathname)))
1127         (pattern-p (%pathname-host pathname)))        (:name (pattern-p (%pathname-name pathname)))
1128        (:directory        (:type (pattern-p (%pathname-type pathname)))
1129         (some #'pattern-p (%pathname-directory pathname)))        (:version (eq (%pathname-version pathname) :wild)))))
       (:name  
        (pattern-p (%pathname-name pathname)))  
       (:type  
        (pattern-p (%pathname-type pathname)))  
       (:version  
        (eq (%pathname-version pathname) :wild)))))  
1130    
1131  ;;; PATHNAME-MATCH -- Interface  ;;; PATHNAME-MATCH -- Interface
1132  ;;;  ;;;
1133  (defun pathname-match-p (pathname wildname)  (defun pathname-match-p (in-pathname in-wildname)
1134    "Pathname matches the wildname template?"    "Pathname matches the wildname template?"
1135    (with-pathname (pathname pathname)    (declare (type path-designator in-pathname))
1136      (with-pathname (wildname wildname)    (with-pathname (pathname in-pathname)
1137        (with-pathname (wildname in-wildname)
1138        (macrolet ((frob (field)        (macrolet ((frob (field)
1139                     `(or (null (,field wildname))                     `(or (null (,field wildname))
1140                          (components-match (,field wildname)                          (components-match (,field wildname)
1141                                            (,field pathname)))))                                            (,field pathname)))))
1142          (and (frob %pathname-host)          (and (or (null (%pathname-host wildname))
1143                     (components-match (logical-host-name
1144                                        (%pathname-host wildname))
1145                                       (logical-host-name
1146                                        (%pathname-host pathname))))
1147               (frob %pathname-device)               (frob %pathname-device)
1148               (frob %pathname-directory)               (frob %pathname-directory)
1149               (frob %pathname-name)               (frob %pathname-name)
# Line 861  Line 1155 
1155    
1156  ;;; SUBSTITUTE-INTO -- Internal  ;;; SUBSTITUTE-INTO -- Internal
1157  ;;;  ;;;
1158  (defun substitute-into (pattern subs)  ;;;   Place the substitutions into the pattern and return the string or
1159    ;;; pattern that results. The case argument allows for the use of a :lower
1160    ;;; case to enable a UNIX and implementation specific translation of uppercase
1161    ;;; characters in logical-namestrings into lower case physical namestrings.
1162    ;;;
1163    (defun substitute-into (pattern subs &key (case :common))
1164    (declare (type pattern pattern)    (declare (type pattern pattern)
1165             (type list subs))             (type list subs)
1166               (values (or simple-base-string pattern)))
1167    (let ((in-wildcard nil)    (let ((in-wildcard nil)
1168          (pieces nil)          (pieces nil)
1169          (strings nil))          (strings nil))
1170      (dolist (piece (pattern-pieces pattern))      (dolist (piece (pattern-pieces pattern))
1171        (cond ((simple-string-p piece)        (cond ((simple-string-p piece)
1172               (push piece strings)               (if (eq case 'lower)
1173                     (push (string-downcase piece) strings)
1174                     (push piece strings))
1175               (setf in-wildcard nil))               (setf in-wildcard nil))
1176              (in-wildcard)              (in-wildcard)
1177              ((null subs))              ((null subs))
# Line 882  Line 1184 
1184                                   (nreverse strings))                                   (nreverse strings))
1185                            pieces))                            pieces))
1186                    (dolist (piece (pattern-pieces sub))                    (dolist (piece (pattern-pieces sub))
1187                      (push piece pieces)))                      (if (and (stringp piece) (eq case 'lower))
1188                            (push (string-downcase piece) pieces)
1189                            (push piece pieces))))
1190                   (simple-string                   (simple-string
1191                    (push sub strings))))                    (if (eq case 'lower)
1192                          (push (string-downcase sub) strings)
1193                          (push sub strings)))))
1194               (setf in-wildcard t))))               (setf in-wildcard t))))
1195      (when strings      (when strings
1196        (push (apply #'concatenate 'simple-string        (push (apply #'concatenate 'simple-string (nreverse strings))
                    (nreverse strings))  
1197              pieces))              pieces))
1198      (if (and pieces      (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
              (simple-string-p (car pieces))  
              (null (cdr pieces)))  
1199          (car pieces)          (car pieces)
1200          (make-pattern (nreverse pieces)))))          (make-pattern (nreverse pieces)))))
1201    
# Line 977  Line 1280 
1280  (defun translate-pathname (source from-wildname to-wildname &key)  (defun translate-pathname (source from-wildname to-wildname &key)
1281    "Use the source pathname to translate the from-wildname's wild and    "Use the source pathname to translate the from-wildname's wild and
1282     unspecified elements into a completed to-pathname based on the to-wildname."     unspecified elements into a completed to-pathname based on the to-wildname."
1283    (declare (type pathnamelike source from-wildname to-wildname))    (declare (type path-designator source from-wildname to-wildname))
1284    (with-pathname (source source)    (with-pathname (source source)
1285      (with-pathname (from from-wildname)      (with-pathname (from from-wildname)
1286        (with-pathname (to to-wildname)        (with-pathname (to to-wildname)
# Line 1111  Line 1414 
1414    "Return the expansions for the search-list starting PATHNAME.  If PATHNAME    "Return the expansions for the search-list starting PATHNAME.  If PATHNAME
1415     does not start with a search-list, then an error is signaled.  If     does not start with a search-list, then an error is signaled.  If
1416     the search-list has not been defined yet, then an error is signaled.     the search-list has not been defined yet, then an error is signaled.
1417     The expansion for a search-list can be set with SETF."     The expansion for a search-list can be set with SETF."
1418    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1419      (let ((search-list (extract-search-list pathname t))      (let ((search-list (extract-search-list pathname t))
1420            (host (pathname-host pathname)))            (host (pathname-host pathname)))
1421        (if (search-list-defined search-list)        (if (search-list-defined search-list)
1422            (mapcar #'(lambda (directory)            (mapcar #'(lambda (directory)
1423                        (make-pathname :host host                        (make-pathname :host host
# Line 1212  Line 1515 
1515    
1516    
1517  ;;;;  Logical pathname support. ANSI 92-102 specification.  ;;;;  Logical pathname support. ANSI 92-102 specification.
1518    ;;;;  As logical-pathname translations are loaded they are canonicalized as
1519  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;  patterns to enable rapid efficent translation into physical pathnames.
 ;;;  
 ;;; Logical pathnames have the following format:  
 ;;;  
 ;;; logical-namestring ::=  
 ;;;         [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]  
 ;;;  
 ;;; host ::= word  
 ;;; directory ::= word | wildcard-word | **  
 ;;; name ::= word | wildcard-word  
 ;;; type ::= word | wildcard-word  
 ;;; version ::= pos-int | newest | NEWEST | *  
 ;;; word ::= {uppercase-letter | digit | -}+  
 ;;; wildcard-word ::= [word] '* {word '*}* [word]  
 ;;; pos-int ::= integer > 0  
 ;;;  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
   
 ;; Logical pathnames are a subclass of pathnames and can use the same  
 ;; data structures with the device slot necessarily nil.  The current lack of  
 ;; an integrated efficient CLOS means that the classes are mimiced using  
 ;; structures.  They follow the pattern set by search-lists, a CMUCL specific  
 ;; extension.  
   
 (defstruct (logical-host  
             (:include host  
                       (:parse #'parse-logical-namestring)  
                       (:unparse #'unparse-logical-namestring)  
                       (:unparse-host #'unparse-logical-host)  
                       (:unparse-directory #'unparse-logical-directory)  
                       (:unparse-file #'unparse-logical-file)  
                       (:unparse-enough #'identity)  
                       (:customary-case :upper)))  
   (name "" :type simple-string)  
   (translations nil :type list)  
   (canon-transls nil :type list))  
   
 (deftype logical-pathname ()  
   '(satisfies logical-pathname-p))  
   
 ;;; LOGICAL-PATHNAME-P -- Public  
 ;;;  
 (defun logical-pathname-p (thing)  
   "Return T if THING is a LOGICAL-PATHNAME object."  
   (and (pathnamep thing)  
        (logical-host-p (%pathname-host thing))))  
   
 ;;; *LOGICAL-PATHNAMES* --internal.  
 ;;;  
 ;;; Hash table searching maps a logical-pathname's host to their physical  
 ;;; pathname translation.  
   
 (defvar *logical-pathnames* (make-hash-table :test #'equal))  
1520    
1521  (define-condition logical-namestring-parse-error (error)  (define-condition logical-namestring-parse-error (error)
1522    ((complaint :init-form (required-argument))    ((complaint :init-form (required-argument))
# Line 1276  Line 1527 
1527    
1528  ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal  ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal
1529  ;;;  ;;;
1530    ;;;  Take the ; reduced strings and break them into words and wildcard-words.
1531    ;;;
1532  (defun maybe-make-logical-pattern (namestr start end)  (defun maybe-make-logical-pattern (namestr start end)
1533    "Take the ; reduced strings and break them into words and wildcard-words."    (declare (type (or symbol simple-base-string) namestr)
1534    (declare (type simple-base-string namestr)             (type index start end)
1535             (type index start end))             (values (or null symbol pattern simple-base-string)))
1536    (collect ((pattern))    (collect ((pattern))
1537      (let ((last-regular-char nil)      (let ((last-regular-char nil)
1538            (look-ahead+1 nil)            (look-ahead+1 nil)
# Line 1295  Line 1548 
1548            (setf char (schar namestr index))            (setf char (schar namestr index))
1549            (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.            (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.
1550                   (flush-pending-regulars))                   (flush-pending-regulars))
1551                  ((or (char= #\- char) ; Hyphen is a legal word character.                  ((verify-word-char-p char) ; Building a word.
                      (alphanumericp char))    ; Building a word.  
1552                   (unless last-regular-char                   (unless last-regular-char
1553                     (setf last-regular-char index)))                     (setf last-regular-char index)))
1554                  ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.                  ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.
# Line 1335  Line 1587 
1587            (t            (t
1588             (make-pattern (pattern)))))))             (make-pattern (pattern)))))))
1589    
1590  ;;; INTERN-LOGICAL-HOST  ;;; INTERN-LOGICAL-HOST -- Internal
1591    ;;;
1592    ;;;   The name is a string. Put it in the hash table, return the logical-host.
1593  ;;;  ;;;
1594  (defun intern-logical-host (name)  (defun intern-logical-host (name)
1595    (declare (simple-string name)    (declare (simple-string name)
1596             (values logical-host))             (values logical-host))
1597    (let ((name (string-upcase name)))    (unless (logical-word-p name)
1598      (or (gethash name *logical-pathnames*)      (error "Hostname ~S is not a legitimate logical word ~%
1599          (let ((new (make-logical-host :name name)))                 (consisting of uppercase letters, digits and hyphens)." name))
1600            (setf (gethash name *logical-pathnames*) new)    (or (gethash name *logical-hosts*)
1601            new))))        (let ((new (make-logical-host :name name)))
1602            (setf (gethash name *logical-hosts*) new)
1603            new)))
1604    
1605  ;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION  ;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION -- Internal
1606    ;;;
1607    ;;;   Return a set of three elements that can be any of patterns, strings,
1608    ;;; keywords, and integers.
1609  ;;;  ;;;
1610  (defun extract-logical-name-type-and-version (namestr start end)  (defun extract-logical-name-type-and-version (namestr start end)
1611    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
# Line 1394  Line 1653 
1653  ;;;  ;;;
1654  (defun logical-word-p (word)  (defun logical-word-p (word)
1655    (declare (type simple-base-string word)    (declare (type simple-base-string word)
1656             (values boolean))             (values (or t null)))
1657    (let ((ch nil))    (let ((ch nil))
1658      (dotimes (i (length word))      (dotimes (i (length word))
1659        (setf ch (schar word i))        (setf ch (schar word i))
1660        (unless (or (alphanumericp ch) (eq ch #\-))        (unless (or (upper-case-p ch) (digit-char-p ch) (eq ch #\-))
1661          (return-from logical-word-p nil))))          (return-from logical-word-p nil))))
1662    t)    t)
1663    
1664  ;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal  ;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal
1665  ;;;    Verify whether there is a logical host prefix in the namestr. If one is  ;;;    Verify whether there is a logical host or search-list prefix in the
1666  ;;; found return its name and the index of the remainder of the namestring.  ;;; namestr. If one is found return its name and the index of the remainder of
1667  ;;; If not return nil.  ;;; the namestring.  If not return nil.
1668  ;;;  ;;;
1669  (defun maybe-extract-logical-host (namestr start end)  (defun maybe-extract-logical-host (namestr start end)
1670    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
# Line 1417  Line 1676 
1676          (let ((host (subseq namestr start colon-pos)))          (let ((host (subseq namestr start colon-pos)))
1677            (cond ((logical-word-p host)            (cond ((logical-word-p host)
1678                   (return-from maybe-extract-logical-host                   (return-from maybe-extract-logical-host
1679                                (values (string-upcase host) (1+ colon-pos))))                                (values host (1+ colon-pos))))
1680                  ((string= host "*")                  ((string= host "*")
1681                   (return-from maybe-extract-logical-host                   (return-from maybe-extract-logical-host
1682                                (values :wild (1+ colon-pos))))))                                (values :wild (1+ colon-pos))))
1683                    (t (error "Host component ~S in namestring ~S is neither a ~
1684                               wildcard (*),~%or a word formed from capital ~
1685                               letters, digits and hyphens." host namestr))))
1686          ;; Implied host          ;; Implied host
1687          (values nil 0))))          (values nil 0))))
1688    
1689    ;;; DECIDE-LOGICAL-HOST -- Internal
1690    ;;;
1691    (defun decide-logical-host (host path-host defaults-host)
1692      (declare (type (or null host simple-base-string stream)
1693                     host path-host defaults-host)
1694               (values (or null logical-host)))
1695      (with-host (host-struc host)
1696         (with-host (path-host-struc path-host)
1697            (with-host (defaults-host-struc defaults-host)
1698              (if host-struc
1699                  host-struc
1700                  (if path-host-struc
1701                      path-host-struc
1702                      (if defaults-host-struc
1703                          defaults-host-struc
1704                          (error "None of ~S, ~S, or ~S is a logical-host"
1705                                 host path-host defaults-host))))))))
1706    
1707  ;;; PARSE-LOGICAL-NAMESTRING  -- Internal  ;;; PARSE-LOGICAL-NAMESTRING  -- Internal
1708  ;;;  ;;;
1709  ;;;   Break up a logical-namestring into its constituent parts.  ;;;   Break up a logical-namestring, always a string, into its constituent
1710    ;;; parts.
1711  ;;;  ;;;
1712  (defun parse-logical-namestring (namestr start end)  (defun parse-logical-namestring (namestr
1713                                     &key
1714                                     host
1715                                     (defaults *default-pathname-defaults*)
1716                                     (start 0)
1717                                     (end (length namestr)))
1718    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
1719             (type index start end)             (type index start end)
1720             (values (or logical-host null)             (type (or null simple-base-string logical-host stream) host)
1721                     (or (member nil :unspecific) simple-base-string)             (type pathname defaults)
1722                     list             (values (or null logical-pathname) (or null index)))
1723                     (or simple-base-string list pattern (member :wild))    (let ((namestring (string-upcase namestr))
1724                     (or simple-string pattern null (member :unspecific :wild))          (default-host (pathname-host defaults)))
1725                     (or integer null (member :newest :wild))))      ;; Parse for : prefixed hostname if present in namestr.
1726    (multiple-value-bind ; Parse for :      (multiple-value-bind (namestr-host place)
1727        (host place)                           (maybe-extract-logical-host namestring start end)
1728        (maybe-extract-logical-host namestr start end)        ;; The explicit host argument is a logical host, or the host's name
1729      (typecase host        ;; or the defaults provide the host, in that order.
1730        (keyword t) ; :wild for example.        (setf host (decide-logical-host host namestr-host default-host))
1731        (simple-string ; Already a search-list element?        (multiple-value-bind (absolute pieces)
1732         (unless (gethash (string-downcase host) *search-lists*)                             (split-at-slashes namestring place end #\;)
1733            (setf host (intern-logical-host host))))          ;; Logical paths follow opposite convention of physical pathnames.
1734        (null nil))          (setf absolute (not absolute))
1735      (multiple-value-bind          (multiple-value-bind (name type version)
1736          (absolute pieces)                               (let* ((tail (car (last pieces)))
1737          (split-at-slashes namestr place end #\;)                                      (tail-start (car tail))
1738        ;; Logical paths follow opposite convention of physical pathnames.                                      (tail-end (cdr tail)))
1739        (setf absolute (not absolute))                                 (unless (= tail-start tail-end)
1740        (multiple-value-bind (name type version)                                   (setf pieces (butlast pieces))
1741                             (let* ((tail (car (last pieces)))                                   (extract-logical-name-type-and-version
1742                                    (tail-start (car tail))                                    namestring tail-start tail-end)))
1743                                    (tail-end (cdr tail)))            ;; Now we have everything we want.  Construct a logical pathname.
1744                               (unless (= tail-start tail-end)            (%make-logical-pathname
1745                                 (setf pieces (butlast pieces))             host
1746                                 (extract-logical-name-type-and-version             nil
1747                                  namestr tail-start tail-end)))             (collect ((dirs))
1748          ;; Now we have everything we want.  So return it.                      (dolist (piece pieces)
1749          (values host                        (let ((piece-start (car piece))
1750                  :unspecific                              (piece-end (cdr piece)))
1751                  (collect ((dirs))                          (unless (= piece-start piece-end)
1752                    (dolist (piece pieces)                            (let ((dir
1753                      (let ((piece-start (car piece))                                   (maybe-make-logical-pattern namestring
1754                            (piece-end (cdr piece)))                                                               piece-start
1755                        (unless (= piece-start piece-end)                                                               piece-end)))
1756                          (let ((dir (maybe-make-logical-pattern namestr                              (if (and (simple-string-p dir)
1757                                                                 piece-start                                       (string= dir ".."))
1758                                                                 piece-end)))                                  (dirs :up)
1759                            (if (and (simple-string-p dir)                                  (dirs dir))))))
1760                                     (string= dir ".."))                      (cond (absolute
1761                                (dirs :up)                             (cons :absolute (dirs)))
1762                                (dirs dir))))))                            ((dirs)
1763                    (cond (absolute                             (cons :relative (dirs)))
1764                           (cons :absolute (dirs)))                            (t
1765                          ((dirs)                             nil)))
1766                           (cons :relative (dirs)))             name
1767                          (t             type
1768                           nil)))             version))))))
                 name  
                 type  
                 version)))))  
1769    
1770  ;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal  ;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal
1771  ;;;  ;;;
# Line 1513  Line 1795 
1795  ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal  ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal
1796  ;;;  ;;;
1797  (defun unparse-logical-directory (pathname)  (defun unparse-logical-directory (pathname)
1798    (declare (type pathname pathname))    (declare (type logical-pathname pathname))
1799    (unparse-logical-directory-list (%pathname-directory pathname)))    (unparse-logical-directory-list (%logical-pathname-directory pathname)))
1800    
1801  ;;; UNPARSE-LOGICAL-PIECE -- Internal  ;;; UNPARSE-LOGICAL-PIECE -- Internal
1802  ;;;  ;;;
# Line 1560  Line 1842 
1842  ;;;  ;;;
1843  (defun unparse-logical-file (pathname)  (defun unparse-logical-file (pathname)
1844    (declare (type pathname pathname))    (declare (type pathname pathname))
   (declare (type pathname pathname))  
1845    (unparse-unix-file pathname))    (unparse-unix-file pathname))
1846    
1847  ;;; UNPARSE-LOGICAL-HOST -- Internal  ;;; UNPARSE-LOGICAL-HOST -- Internal
1848  ;;;  ;;;
1849  (defun unparse-logical-host (pathname)  (defun unparse-logical-host (pathname)
1850    (declare (type logical-pathname pathname))    (declare (type logical-pathname pathname))
1851    (logical-host-name (%pathname-host pathname)))    (logical-host-name (%logical-pathname-host pathname)))
1852    
1853  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1854  ;;;  ;;;
# Line 1580  Line 1861 
1861    
1862  ;;; LOGICAL-PATHNAME -- Public  ;;; LOGICAL-PATHNAME -- Public
1863  ;;;  ;;;
1864  ;;; Logical-pathname must signal a type error of type type-error.  ;;; Logical-pathname must signal an error of type type-error.
1865  ;;;  ;;;
1866  (defun logical-pathname (pathspec)  (defun logical-pathname (pathspec)
1867    "Converts the pathspec argument to a logical-pathname and returns it."    "Converts the pathspec argument to a logical-pathname and returns it."
1868    (declare (type (or logical-pathname string stream) pathspec)    (declare (type (or logical-pathname simple-base-string stream) pathspec)
1869             (values logical-pathname))             (values logical-pathname))
1870    ;; Decide whether to typedef logical-pathname, logical-pathname-string,    ;; Decide whether to typedef logical-pathname, logical-pathname-string,
1871    ;; or streams for which the pathname function returns a logical-pathname.    ;; or streams for which the pathname function returns a logical-pathname.
1872    (cond ((logical-pathname-p pathspec) pathspec)    (etypecase pathspec
1873          ((stringp pathspec)      (logical-pathname pathspec)
1874           (if (maybe-extract-logical-host pathspec 0 (length pathspec))      (simple-base-string
1875               (pathname pathspec)       (let* ((l-pathspec (length pathspec))
1876               (error "Pathspec is not a logical pathname prefaced by <host>:.")))              (pathspec-host
1877          ((streamp pathspec)               (maybe-extract-logical-host pathspec 0 l-pathspec)))
1878           (if (logical-pathname-p pathspec)         (if pathspec-host
1879               (pathname pathspec)             (parse-logical-namestring pathspec :host pathspec-host
1880               (error "Stream ~S is not a logical-pathname." pathspec)))                                       :start 0 :end l-pathspec)
1881          (t             (error "Path specification ~S is not a logical pathname ~
1882           (error "~S is not either ~%                     prefaced by <host>:." pathspec))))
1883                   a logical-pathname object, or~%      (stream
1884                   a logical pathname namestring, or~%       (let ((stream-type (type-of pathspec))
1885                   a stream named by a logical pathname." pathspec))))             (path-file (file-name pathspec)))
1886           (unless (or (eq stream-type 'fd-stream)
1887                       (eq stream-type 'synonym-stream))
1888             (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
1889                     or MAKE-SYNONYM-FILE." pathspec))
1890           (parse-logical-namestring path-file
1891                                     :start 0 :end (length path-file))))))
1892    
1893  ;;; TRANSLATIONS-TEST-P  ;;; TRANSLATIONS-TEST-P -- Internal
1894  ;;;  ;;;
1895  ;;;   Verify that the list of translations consists of lists and prepare  ;;;   Verify that the list of translations consists of lists and prepare
1896  ;;; canonical translations from the pathnames.  ;;; canonical translations (parse pathnames and expand out wildcards into
1897    ;;; patterns).
1898  ;;;  ;;;
1899  (defun translations-test-p (transl-list host)  (defun translations-test-p (transl-list host)
1900    (declare (type logical-host host)    (declare (type logical-host host)
1901             (type list transl-list)             (type list transl-list)
1902             (values boolean))             (values (or t null)))
1903    (let ((can-transls nil))    (let ((can-transls (make-list (length transl-list))); Canonical translations.
1904      (setf can-transls (make-list (length transl-list))          (c-tr nil))
1905            (logical-host-canon-transls host) can-transls)      (setf (logical-host-canon-transls host) can-transls)
1906      (do* ((i 0 (1+ i))      (do* ((i 0 (1+ i))
1907            (tr (nth i transl-list) (nth i transl-list))            (tr (nth i transl-list) (nth i transl-list))
1908            (from-path (first tr) (first tr))            (from-path (first tr) (first tr))
1909            (to-path (second tr) (second tr))            (to-path (second tr) (second tr)))
           (c-tr (nth i can-transls) (nth i can-transls)))  
1910           ((<= (length transl-list) i))           ((<= (length transl-list) i))
1911        (setf c-tr (make-list 2))        (setf c-tr (make-list 2))
1912        (if (logical-pathname-p from-path)        (if (logical-pathname-p from-path)
# Line 1629  Line 1916 
1916            (setf (second c-tr) to-path)            (setf (second c-tr) to-path)
1917            (setf (second c-tr) (parse-namestring to-path)))            (setf (second c-tr) (parse-namestring to-path)))
1918        ;; Verify form of translations.        ;; Verify form of translations.
1919        (unless (and (or (logical-pathname-p from-path)        (unless (and (or (logical-pathname-p from-path) (first c-tr))
                        (first c-tr))  
1920                     (second c-tr))                     (second c-tr))
1921          (return-from translations-test-p nil))          (return-from translations-test-p nil))
1922        (setf (nth i can-transls) c-tr)))        (setf (nth i can-transls) c-tr)))
# Line 1645  Line 1931 
1931             (values list))             (values list))
1932    (etypecase host    (etypecase host
1933      (simple-string      (simple-string
1934       (setf host (string-upcase host))       (let ((host-struc (gethash (string-upcase host) *logical-hosts*)))
      (let ((host-struc (gethash host *logical-pathnames*)))  
1935         (if host-struc         (if host-struc
1936             (logical-host-translations host-struc)             (logical-host-translations host-struc)
1937             (error "HOST ~S is not defined." host))))             (error "HOST ~S is not defined." host))))
# Line 1661  Line 1946 
1946    (declare (type (or simple-base-string logical-host) host)    (declare (type (or simple-base-string logical-host) host)
1947             (type list translations)             (type list translations)
1948             (values list))             (values list))
1949      (setf host (string-upcase host))
1950    (typecase host    (typecase host
1951      (simple-base-string      (simple-base-string
1952       (setf host (string-upcase host))       (unless (logical-word-p host)
1953           (error "Hostname ~S is not a legitimate logical word ~%
1954                   (consisting of uppercase letters, digits and hyphens)." host))
1955       (multiple-value-bind       (multiple-value-bind
1956           (hash-host xst?)           (hash-host xst?)
1957           (gethash host *logical-pathnames*)           (gethash host *logical-hosts*)
1958         (unless xst?         (unless xst?
1959           (intern-logical-host host)           (setf hash-host (intern-logical-host host)))
          (setf hash-host (gethash host *logical-pathnames*)))  
1960         (unless (translations-test-p translations hash-host)         (unless (translations-test-p translations hash-host)
1961           (error "Translations ~S is not a list of pairs of from-, ~           (error "Translations ~S is not a list of pairs of from-, ~
1962                   to-pathnames." translations)))                   to-pathnames." translations)))
1963       translations)       translations)
1964      (t      (t
1965         (format t "TRANSLATIONS-TEST-P args = ~S, ~S~%" translations host)
1966       (unless (translations-test-p translations host)       (unless (translations-test-p translations host)
1967         (error "Translations ~S is not a list of pairs of from-, ~         (error "Translations ~S is not a list of pairs of from- and ~
1968                 to-pathnames." translations))                 to-pathnames." translations))
1969       translations)))       translations)))
1970    
# Line 1698  Line 1986 
1986                                  :name host                                  :name host
1987                                  :type "translations"                                  :type "translations"
1988                                  :version :newest))                                  :version :newest))
1989           (new-stuff (gethash host *logical-pathnames*))           (new-stuff (gethash host *logical-hosts*))
1990           (new-transl (logical-host-translations new-stuff)))           (new-transl (logical-host-translations new-stuff)))
1991          (with-open-file (out-str p-name          (with-open-file (out-str p-name
1992                                   :direction :output                                   :direction :output
# Line 1711  Line 1999 
1999                       ~S~% ~                       ~S~% ~
2000                       for the host:~%   ~                       for the host:~%   ~
2001                       ~S.~%" p-name new-transl host))))                       ~S.~%" p-name new-transl host))))
2002    #|
2003  ;;; Define a SYS area for system dependent logical translations, should we  ;;; Define a SYS area for system dependent logical translations, should we
2004  ;;; ever want to use them. ########### Decision still need to made whether  ;;; ever want to use them. Not currently used in CMUCL.
 ;;; to take advantage of this area.  
2005    
 #|  
2006  (progn  (progn
2007    (intern-logical-host "SYS")    (intern-logical-host "SYS")
2008    (save-logical-pathname-translations "SYS" "library:"))    (save-logical-pathname-translations "SYS" "library:"))
2009    
2010  |#  |#
2011    
2012  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
2013  ;;;  ;;;
2014  (defun load-logical-pathname-translations (host)  (defun load-logical-pathname-translations (host)
# Line 1729  Line 2017 
2017     returned. If host is not already defined, but definition is found and loaded     returned. If host is not already defined, but definition is found and loaded
2018     successfully, T is returned, else error."     successfully, T is returned, else error."
2019    (declare (type simple-base-string host)    (declare (type simple-base-string host)
2020             (values boolean))             (values (or t null)))
2021    (setf host (string-upcase host))    (setf host (string-upcase host))
2022    (let ((p-name nil)    (let ((p-name nil)
2023          (p-trans nil))          (p-trans nil))
2024      (multiple-value-bind      (multiple-value-bind
2025          (log-host xst?)          (log-host xst?)
2026          (gethash host *logical-pathnames*)          (gethash host *logical-hosts*)
2027        (if xst?        (if xst?
2028            ;; host already has a set of defined translations.            ;; host already has a set of defined translations.
2029            (return-from load-logical-pathname-translations nil)            (return-from load-logical-pathname-translations nil)
# Line 1762  Line 2050 
2050  ;;; COMPILE-FILE-PATHNAME -- Public  ;;; COMPILE-FILE-PATHNAME -- Public
2051  ;;;  ;;;
2052  (defun compile-file-pathname (file-path &key output-file)  (defun compile-file-pathname (file-path &key output-file)
2053    (declare (type (or string stream pathname logical-pathname) file-path)    (declare (type path-designator file-path)
2054             (type (or string stream pathname logical-pathname) output-file)             (type (or null pathname) output-file)
2055             (values pathname))             (values (or null pathname)))
2056    (with-pathname (path file-path)    (if (logical-pathname-p file-path)
2057       (cond ((and (logical-pathname-p path) (not output-file))        (if output-file
2058              (make-pathname :host (%pathname-host path)            (translate-logical-pathname file-path)
2059                             :directory (%pathname-directory path)            (%make-logical-pathname
2060                             :device (%pathname-device path)             (or (%logical-pathname-host file-path)
2061                             :name (%pathname-name path)                 (%pathname-host *default-pathname-defaults*))
2062                             :type (c:backend-fasl-file-type c:*backend*)))             nil
2063             ((logical-pathname-p path)             (or (%logical-pathname-directory file-path)
2064              (translate-logical-pathname path))                 (%pathname-directory *default-pathname-defaults*))
2065             (t file-path))))             (or (%logical-pathname-name file-path)
2066                   (%pathname-name *default-pathname-defaults*))
2067  ;;; TRANSLATE-WILD-P -- Internal             (c:backend-fasl-file-type c:*backend*)
2068  ;;;             (%pathname-version *default-pathname-defaults*)))
2069  (defmacro translate-wild-p (to-obj)        (with-pathname (path file-path)
2070    "Translate :wild?"                       path)))
2071    (declare (type keyword to-obj))  
2072    `(etypecase ,to-obj  ;;; TRANSLATE-LOGICAL-HOST -- Internal
2073       ((or (member :wild :unspecific nil :up :back)  ;;;
2074            string  (defun translate-logical-host (path-host from-host to-host)
2075            pattern)    "Pathname must contain a logical host or wild cards."
2076        t)))    (declare (type (or logical-host host) path-host from-host to-host))
2077      (cond ((or (eq path-host from-host) (eq from-host :wild)) to-host)
2078            (t (throw 'next-translation nil))))
2079    
2080    (defmacro translate-absolute-relative (src from to)
2081      "Translate :ABSOLUTE and RELATIVE keywords."
2082      `(if (eq ,src ,from)
2083              ,to
2084              (throw 'next-translation nil)))
2085    
2086    (defmacro cleanup-to (from-context to-context result)
2087      `(unless ,from-context
2088         (setf ,result (append (reverse ,to-context) ,result))))
2089    
2090    ;;; TRANSLATE-DIR-ELEMENTS -- Internal
2091    ;;;
2092    ;;;   The translation of pathnames occurs in two stages, the first produces an
2093    ;;; intermediate result upon which the second is repeated.
2094    ;;; The pathname result is a copy of the to element with each missing or
2095    ;;; wildcard field filled in by a portion of from and placed in result.
2096    ;;; If the to field is a :wild or :wild-inferiors, it is copied without any
2097    ;;; further action. Wildcard-inferiors in the from field set the wild-inf-flag
2098    ;;; and push the to field element onto the result, continuing until a match is
2099    ;;; found.
2100    ;;;
2101    (defun translate-dir-elements (from from-context to to-context result
2102                                        &optional wild-inf-flag)
2103      "Translations are based on the element types of from and to, which can
2104       recursively effect their repective contexts when they are :wild-inferiors."
2105      (declare (type
2106                (or null (member :wild :wild-inferiors) pattern
2107                    simple-base-string)
2108                from to)
2109               (type list from-context to-context)
2110               (type (or null t) wild-inf-flag)
2111               (values list list list))
2112      (let ((match-p nil)
2113            (matches nil))
2114        (typecase from
2115          (simple-base-string
2116           (typecase to
2117             (simple-base-string
2118              (cond (wild-inf-flag
2119                     (push (string-downcase to) result)
2120                     (multiple-value-setq (from-context to-context result)
2121                       (translate-dir-elements from from-context
2122                                               (pop to-context) to-context t)))
2123                    (t ; Clean up, include any untranslated to leftovers.
2124                     (push (string-downcase to) result)
2125                     (cleanup-to from-context to-context result))))
2126             (pattern
2127              (multiple-value-setq (match-p matches)
2128                (pattern-matches to from))
2129              (cond (match-p
2130                     (push (string-downcase from) result))
2131                    (wild-inf-flag
2132                     (push (string-downcase from) result)
2133                     (multiple-value-setq (from-context to-context result)
2134                       (translate-dir-elements from from-context
2135                                               (pop to-context) to-context t)))
2136                    (t
2137                     (throw 'next-translation nil))))
2138             ((member :wild :wild-inferiors)
2139              ;; Clean up, include any untranslated to leftovers.
2140              (push (string-downcase from) result)
2141              (cleanup-to from-context to-context result))))
2142          (pattern
2143           (typecase to
2144             (simple-base-string
2145              (multiple-value-setq (match-p matches)
2146                (pattern-matches from to))
2147              (cond (match-p
2148                     (push (string-downcase to) result)
2149                     (cleanup-to from-context to-context result))
2150                    (wild-inf-flag
2151                     (push (string-downcase to) result)
2152                     (multiple-value-setq (from-context to-context result)
2153                       (translate-dir-elements (pop from-context) from-context
2154                                               to to-context t)))
2155                    (t
2156                     (throw 'next-translation nil))))
2157             (pattern
2158              (cond ((and (pattern= from to) wild-inf-flag)
2159                     (push to result)
2160                     (multiple-value-setq (from-context to-context result)
2161                       (translate-dir-elements (pop from-context) from-context
2162                                               to to-context t)))
2163                    ((pattern= from to)
2164                     ;; Clean up, include any untranslated to leftovers.
2165                     (push to result)
2166                     (cleanup-to from-context to-context result))
2167                    (t
2168                     (throw 'next-translation nil))))
2169             ((member :wild :wild-inferiors)
2170              (push to result)
2171              ;; Clean up, include any untranslated to leftovers.
2172              (cleanup-to from-context to-context result))))
2173          ((member :wild)
2174           ;; Clean up, include any untranslated to leftovers.
2175           (push to result)
2176           (cleanup-to from-context to-context result))
2177          ((member :wild-inferiors)
2178           (push to result)
2179           (multiple-value-setq (from-context to-context result)
2180             (translate-dir-elements (pop from-context) from-context
2181                                     to to-context t))))
2182        (values from-context to-context result)))
2183    
2184    ;;; TRANSLATE-DIRECTORY-LISTS -- Internal
2185    ;;;
2186    ;;;   Translate through the lists of strings of subdirectories.
2187    ;;;
2188    (defun translate-directory-lists (from to result)
2189      (declare (type list from to result))
2190      (let ((from-el (pop from))
2191            (to-el (pop to)))
2192        (cond (from-el
2193               ;; There remains an untranslated element, translate it and the rest.
2194               (multiple-value-setq (from to result)
2195                 (translate-dir-elements from-el from to-el to result))
2196               (translate-directory-lists from to result))
2197              (t ; Done.
2198               (setf result (reverse result))))))
2199    
2200  ;;; INTERMEDIATE-REP -- Internal  ;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal
2201  ;;;  ;;;
2202  (defun intermediate-rep (from to)  ;;;   Translate logical directories within the UNIX hierarchical file system,
2203    "A logical component transition function that translates from one argument  ;;; which does not directly support :wildcard-inferiors.  Here :wild-inferiors
2204     to the other. This function is specific to the CMUCL implementation."  ;;; are allowed in a restricted form. The translation table is based on matching
2205    (declare (type (or logical-host host simple-base-string pattern symbol list)  ;;; first the source (src) directory component with the from directory
2206                   from)  ;;; components, and if successful constructing result directory components.
2207             (type (or logical-host host simple-base-string pattern symbol list)  ;;; If this is successful, then the result is matched relative to the the to-dir
2208                   to)  ;;; and a possible translated result is generated.
            (values  
             (or logical-host host simple-base-string pattern list symbol)))  
   (etypecase from  
     (logical-host  
      (if (or (host-p to) (logical-host-p to))  
          to))  
     (host  
      (if (host-p to)  
          to))  
     (simple-base-string  
      (etypecase to  
        (pattern  
         (multiple-value-bind  
             (won subs)  
             (pattern-matches to from)  
           (if won  
               (values (substitute-into to subs))  
               (error "String ~S failed to match pattern ~S" from to))))  
        (simple-base-string to)  
        ((member nil :wild :wild-inferiors) from)))  
     (pattern  
      (etypecase to  
        (pattern  
         (if (pattern= to from)  
             to  
             (error "Patterns ~S and ~S do not match.")))))  
     ((member :absolute :relative)  
      (if (eq to from)  
          to  
          (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~  
                  pathname translation are not consistently relative or absolute." from to)))  
     ((member :wild)  
      (etypecase to  
        ((or string  
             pattern  
             (member nil :unspecific :newest :wild :wild-inferiors))  
         to)))  
     ((member :wild-inferiors) ; Only when single directory component.  
      (etypecase to  
        ((or string pattern cons (member nil :unspecific :wild :wild-inferiors))  
         to)))  
     ((member :unspecific nil)  
      from)  
     ((member :newest)  
      (case to  
        (:wild from)  
        (:unspecific :unspecific)  
        (:newest to)  
        ((member nil) from)))))  
   
 (proclaim '(inline translate-logical-component))  
   
 ;;; TRANSLATE-LOGICAL-COMPONENT -- Internal  
2209  ;;;  ;;;
2210  (defun translate-logical-component (source from to)  (defun translate-logical-directory (src-dirs from-dirs to-dirs)
2211    (intermediate-rep (intermediate-rep source from) to))    (declare (type list src-dirs from-dirs to-dirs)
2212               (values list))
2213      (let ((result-dirs nil)
2214            (transl-dirs nil))
2215        ;; Cope with possible null directory lists.
2216        (cond ((and (null src-dirs) (null from-dirs))
2217               (return-from translate-logical-directory to-dirs))
2218              ((or (null src-dirs) (null from-dirs))
2219               (throw 'next-translation nil)))
2220        ;; Compute the intermediate result by matching the source-dirs
2221        ;; components with the from-dirs and placing the result in the result-dirs
2222        ;; if the match is successful, otherwise throw to the next translation.
2223        (setf result-dirs
2224              (translate-directory-lists (rest src-dirs) (rest from-dirs)
2225                                         result-dirs)
2226              transl-dirs
2227              (translate-directory-lists result-dirs (rest to-dirs)
2228                                         transl-dirs))
2229        (setf result-dirs (translate-absolute-relative
2230                           (first src-dirs) (first from-dirs) transl-dirs))
2231        (if result-dirs
2232            (push (translate-absolute-relative
2233                   (first src-dirs) (first from-dirs) (first to-dirs))
2234                  transl-dirs))
2235        transl-dirs))
2236    
2237    ;;; TRANSLATE-LOGICAL-COMP-ELEMENT -- Internal
2238    ;;;
2239    (defun translate-logical-comp-element (from to)
2240      (declare (type (or pattern simple-base-string fixnum symbol null) from to))
2241      (let ((match-p nil)
2242            (matches nil))
2243        (typecase from
2244          (simple-base-string
2245           (typecase to
2246             (simple-base-string
2247              (string-downcase to))
2248             (fixnum
2249              (throw 'next-translation nil))
2250             ((member :newest :wild nil)
2251              (string-downcase from))
2252             (pattern
2253              (multiple-value-setq (match-p matches)
2254                (pattern-matches to from))
2255              (if match-p
2256                  (substitute-into to matches :case :lower)
2257                  (throw 'next-translation nil)))))
2258          (fixnum
2259           (typecase to
2260             (fixnum
2261              (if (<= from to)
2262                  to
2263                  from))
2264             ((member :newest :wild nil)
2265              to)
2266             (pattern
2267              (case (first (pattern-pieces to))
2268                ((or :wild :newest) to)
2269                (t (throw 'next-translation nil))))))
2270          ((member :wild :newest nil)
2271           to)
2272          (pattern
2273           (typecase to
2274             (simple-base-string
2275              (multiple-value-setq (match-p matches)
2276                (pattern-matches from to))
2277              (if match-p
2278                  (substitute-into from matches :case :lower)
2279                  (throw 'next-translation nil)))
2280             (fixnum
2281              (case (first (pattern-pieces from))
2282                ((or :wild :newest) to)
2283                (t (throw 'next-translation nil))))
2284             ((member :newest :wild nil)
2285              to)
2286             (pattern
2287              (if (pattern= from to)
2288                  to
2289                  (throw 'next-translation nil))))))))
2290    
2291  ;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal  ;;; TRANSLATE-LOGICAL-COMPONENT -- Internal
 ;;;  
 ;;;   Translate logical directories within the UNIX heirarchical file system.  
2292  ;;;  ;;;
2293  (defun translate-logical-directory (source from to)  (defun translate-logical-component (src from to)
2294    ;; Handle unfilled components.    (declare (type (or pattern simple-base-string fixnum symbol null) from to))
2295    (if (or (eql source :UNSPECIFIC)    (translate-logical-comp-element (translate-logical-comp-element src from) to))
           (eql from :UNSPECIFIC)  
           (eql to :UNSPECIFIC))  
       (return-from translate-logical-directory :UNSPECIFIC))  
   (if (or (not source) (not from) (not to))  
       (return-from translate-logical-directory nil))  
   ;; Handle directory component abbreviated as a wildcard.  
   (if (member source '(:WILD :WILD-INFERIORS))  
       (setf source '(:ABSOLUTE :WILD-INFERIORS)))  
   (if (member source '(:WILD :WILD-INFERIORS))  
       (setf source '(:ABSOLUTE :WILD-INFERIORS)))  
   (if (member source '(:WILD :WILD-INFERIORS))  
       (setf to '(:ABSOLUTE :WILD-INFERIORS)))  
   ;; Make two stage translation, storing the intermediate results in ires  
   ;; and finally returned in the list rres.  
   (let ((ires nil)  
         (rres nil)  
         (dummy nil)  
         (slen (length source))  
         (flen (length from))  
         (tlen (length to)))  
     (do* ((i 0 (1+ i))  
           (j 0 (1+ j))  
           (k 0)  
           (s-el (nth i source) (nth i source))  
           (s-next-el nil)  
           (f-el (nth j from) (nth j from)))  
          ((<= slen i))  
       (cond ((eq s-el :wild-inferiors)  
              (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end.  
              (cond ((setf k (position s-next-el from :start (1+ j)))  
                     ;; Found it, splice this portion into ires.  
                     (setf ires  
                           (append ires  
                                   (subseq from j (1- k)))  
                           j (1- k)))  
                    (t  
                     ;; Either did not find next source element in from,  
                     ;; or was nil.  
                     (setf ires  
                           (append ires  
                                   (subseq from j flen)))  
                     (unless (= i (1- slen))  
                       (error "Source ~S inconsistent with from translation ~  
                               ~S~%." source from)))))  
             (t  
              (setf ires (append ires (list (intermediate-rep s-el f-el)))))))  
     ;; Remember to add leftover elements of from.  
     (if (< slen flen)  
         (setf ires (append ires (last from (- flen slen)))))  
     (do* ((i 0 (1+ i))  
           (j 0 (1+ j))  
           (k 0)  
           (irlen (length ires))  
           (ir-el (nth i ires) (nth i ires))  
           (ir-next-el nil)  
           (t-el (nth j to) (nth j to)))  
          ((<= tlen i))  
       ;; Remember to add leftover elements of to.  
       (cond ((eq ir-el :wild-inferiors)  
              (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end.  
              (cond ((setf k (position ir-next-el from :start (1+ j)))  
                     ;; Found it, splice this portion into rres.  
                     (setf rres  
                           (append rres  
                                   (subseq from j (1- k)))  
                        j (1- k)))  
                    (t  
                     ;; Either did not find next source element in from,  
                     ;; or was nil.  
                     (setf rres  
                           (append rres  
                                   (subseq from j tlen)))  
                     (unless (= i (1- irlen))  
                       (error "Intermediate path ~S inconsistent with to~  
                               translation ~S~%." ires to)))))  
             (t (if (setf dummy (intermediate-rep ir-el t-el))  
                    (setf rres (append rres (list dummy)))))))  
     (if (< flen tlen)  
         (setf rres (append rres (last to (- tlen flen)))))  
     rres))  
   
 ;;; A physical-pathname is a pathname that does not contain any wildcards,  
 ;;; but is not a logical-pathname.  
   
 (deftype physical-pathname ()  
   '(and (satisfies pathnamep)  
         (not (or (satisfies wild-pathname-p)  
                  (satisfies logical-pathname-p)))))  
2296    
2297  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
2298  ;;;  ;;;
2299  (defun translate-logical-pathname (pathname &key)  (defun translate-logical-pathname (pathname &key)
2300    "Translates pathname to a physical pathname, which is returned."    "Translates pathname to a physical pathname, which is returned."
2301    (declare (type logical-pathname pathname))    (declare (type path-designator pathname)
2302    (with-pathname (source pathname)             (values (or null pathname)))
2303      (etypecase source    (with-pathname (source pathname)
2304        (physical-pathname source)       (when (logical-pathname-p source)
2305        (logical-pathname         (let ((p-host (%pathname-host source))
2306         (let ((source-host (%pathname-host source))               (from nil)
2307               (result-path nil))               (to nil)
2308           (unless (gethash               (tr-host nil)
2309                    (funcall (logical-host-unparse-host source-host) source)               (tr-dir nil)
2310                    *logical-pathnames*)               (tr-name nil)
2311                 (tr-type nil)
2312                 (tr-version nil)
2313                 (result-path nil)
2314                 (src-transl nil)
2315                 (i 0))
2316             (declare (type fixnum i)
2317                      (type (or pathname null) result-path))
2318             ;; Verify that the logical-host is defined.
2319             (unless (gethash (funcall (logical-host-unparse-host p-host) source)
2320                              *logical-hosts*)
2321             (error "The logical host ~S is not defined.~%"             (error "The logical host ~S is not defined.~%"
2322                                      (logical-host-name source-host)))                    (logical-host-name p-host)))
2323           (dolist (src-transl (logical-host-canon-transls source-host)           ;; Scan the pathname translations, and if none is found signal error.
2324                               (error "~S has no matching translation for ~           (loop
2325                                       logical host ~S.~%"             (catch 'next-translation
2326                                      pathname (logical-host-name source-host)))               (setf src-transl (nth i (logical-host-canon-transls p-host)))
2327             (when (pathname-match-p source (first src-transl))               (incf i)
2328               (macrolet ((frob (field)               (unless src-transl
2329                            `(let* ((from (first src-transl))                 (error "~S has no matching translation for logical host ~S.~%"
2330                                    (to (second src-transl))                        pathname (logical-host-name p-host)))
2331                                    (result (translate-logical-component               (setf from (first src-transl)
2332                                             (,field source)                     to (second src-transl))
2333                                             (,field from)               (when (pathname-match-p pathname from)
2334                                             (,field to))))                 (setf tr-host (translate-logical-host
2335                                   result)))                                p-host
2336                 (setf result-path                                (%pathname-host from)
2337                       (%make-pathname (frob %pathname-host)                                (%pathname-host to))
2338                                       :unspecific                       tr-dir (translate-logical-directory
2339                                       (let* ((from (first src-transl))                               (%pathname-directory source)
2340                                              (to (second src-transl))                               (%pathname-directory from)
2341                                              (result                               (%pathname-directory to))
2342                                               (translate-logical-directory                       tr-name (translate-logical-component
2343                                                (%pathname-directory source)                                (%pathname-name source)
2344                                                (%pathname-directory from)                                (%pathname-name from)
2345                                                (%pathname-directory to))))                                (%pathname-name to))
2346                                         (if (eq result :error)                       tr-type (translate-logical-component
2347                                             (error "~S doesn't match ~S"                                (%pathname-type source)
2348                                                    source from)                                (%pathname-type from)
2349                                             result))                                (%pathname-type to))
2350                                       (frob %pathname-name)                       tr-version (translate-logical-component
2351                                       (frob %pathname-type)                                   (%pathname-version source)
2352                                       (frob %pathname-version))))                                   (%pathname-version from)
2353               (etypecase result-path                                   (%pathname-version to))
2354                 (logical-pathname                       result-path (%make-pathname tr-host
2355                  (translate-logical-pathname result-path))                                                   :unspecific
2356                 (physical-pathname                                                   tr-dir
2357                  (return-from translate-logical-pathname result-path))))))))))                                                   tr-name
2358                                                     tr-type
2359                                                     tr-version))
2360                   (etypecase result-path
2361                     (logical-pathname
2362                      (translate-logical-pathname result-path))
2363                     (pathname
2364                      (return-from translate-logical-pathname result-path))
2365                     (null
2366                      (error "The logical path ~S could not be translated."
2367                             pathname))))))))))
2368    
2369    
2370    

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5