/[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.16 by phg, Thu Jul 15 18:02:46 1993 UTC revision 1.17 by ram, Sat Jul 31 01:40:26 1993 UTC
# Line 12  Line 12 
12  ;;;  ;;;
13  ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.  ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
14  ;;;  ;;;
15  ;;; Written by William Lott, enhancements for logical-pathnames  ;;; Written by William Lott, Paul Gleichauf and Rob MacLachlan.
 ;;; written by Paul Gleichauf.  
16  ;;; Earlier version written by Jim Large and Rob MacLachlan  ;;; Earlier version written by Jim Large and Rob MacLachlan
17  ;;;  ;;;
18  ;;; **********************************************************************  ;;; **********************************************************************
# Line 62  Line 61 
61              (:include host              (:include host
62                        (:parse #'parse-logical-namestring)                        (:parse #'parse-logical-namestring)
63                        (:unparse #'unparse-logical-namestring)                        (:unparse #'unparse-logical-namestring)
64                        (:unparse-host #'unparse-logical-host)                        (:unparse-host
65                           #'(lambda (x) (logical-host-name (%pathname-host x))))
66                        (:unparse-directory #'unparse-logical-directory)                        (:unparse-directory #'unparse-logical-directory)
67                        (:unparse-file #'unparse-logical-file)                        (:unparse-file #'unparse-unix-file)
68                        (:unparse-enough #'identity)                        (:unparse-enough #'identity)
69                        (:customary-case :upper)))                        (:customary-case :upper)))
70    (name "" :type simple-base-string)    (name "" :type simple-base-string)
71    (translations nil :type list)    (translations nil :type list)
72    (canon-transls nil :type list))    (canon-transls nil :type list))
73    
74    ;;; The various magic tokens that are allowed to appear in pretty much all
75    ;;; pathname components.
76    ;;;
77    (deftype component-tokens ()
78      '(member nil :unspecific :wild))
79    
80  ;;;; Pathname structures  ;;;; Pathname structures
81    
82  (defstruct (pathname  (defstruct (pathname
# Line 84  Line 89 
89    ;; Slot holds the host, at present either a UNIX or logical host.    ;; Slot holds the host, at present either a UNIX or logical host.
90    (host nil :type (or host null))    (host nil :type (or host null))
91    ;; Device is the name of a logical or physical device holding files.    ;; Device is the name of a logical or physical device holding files.
92    (device nil :type (or null (member :unspecific)))    (device nil :type component-tokens)
93    ;; A list of strings that are the component subdirectory components.    ;; A list of strings that are the component subdirectory components.
94    (directory nil :type list)    (directory nil :type list)
95    ;; The filename.    ;; The filename.
96    (name nil :type (or simple-string pattern null (member :wild)))    (name nil :type (or simple-string pattern component-tokens))
97    ;; The type extension of the file.    ;; The type extension of the file.
98    (type nil :type (or simple-string pattern null (member :wild :unspecific)))    (type nil :type (or simple-string pattern component-tokens))
99    ;; The version number of the file, a positive integer, but not supported    ;; The version number of the file, a positive integer, but not supported
100    ;; on standard UNIX filesystems.    ;; on standard UNIX filesystems.
101    (version nil :type (or integer null (member :newest :wild))))    (version nil :type (or integer component-tokens (member :newest))))
102    
103  ;;; %PRINT-PATHNAME -- Internal  ;;; %PRINT-PATHNAME -- Internal
104  ;;;  ;;;
# Line 107  Line 112 
112             (format stream "#p~S" namestring))             (format stream "#p~S" namestring))
113            (*print-readably*            (*print-readably*
114             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
           (*print-pretty*  
            (pprint-logical-block (stream nil :prefix "#<" :suffix ">")  
              (funcall (formatter  
                        "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~  
                         Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~  
                         Type=~S, ~_Version=~S")  
                       stream  
                       (%pathname-host pathname)  
                       (%pathname-device pathname)  
                       (%pathname-directory pathname)  
                       (%pathname-name pathname)  
                       (%pathname-type pathname)  
                       (%pathname-version pathname))))  
115            (t            (t
116             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
117                                  Directory=~S, File=~S, Name=~S, Version=~S>")                                  Directory=~S, File=~S, Name=~S, Version=~S>")
# Line 158  Line 150 
150              (:conc-name %logical-pathname-)              (:conc-name %logical-pathname-)
151              (:print-function %print-logical-pathname)              (:print-function %print-logical-pathname)
152              (:include pathname)              (:include pathname)
153              (:constructor              (:constructor %make-logical-pathname
154               %make-logical-pathname (host device directory name type version))                            (host device directory name type version))
             (:predicate logical-pathname-p)  
155              (:make-load-form-fun :just-dump-it-normally)))              (:make-load-form-fun :just-dump-it-normally)))
156    
157  ;;; %PRINT-LOGICAL-PATHNAME -- Internal  ;;; %PRINT-LOGICAL-PATHNAME -- Internal
# Line 177  Line 168 
168             (format stream "#.(logical-pathname ~S)" namestring))             (format stream "#.(logical-pathname ~S)" namestring))
169            (*print-readably*            (*print-readably*
170             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
           (*print-pretty*  
            (pprint-logical-block (stream nil :prefix "#<" :suffix ">")  
              (funcall (formatter  
                        "~2IUnprintable pathname: ~_Host=~S, ~_~  
                         Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~  
                         Type=~S, ~_Version=~S")  
                       stream  
                       (%pathname-host pathname)  
                       (%pathname-directory pathname)  
                       (%pathname-name pathname)  
                       (%pathname-type pathname)  
                       (%pathname-version pathname))))  
171            (t            (t
172             (funcall (formatter "#<Unprintable pathname, Host=~S,  ~             (funcall (formatter "#<Unprintable pathname, Host=~S,  ~
173                                  Directory=~S, File=~S, Name=~S, Version=~S>")                                  Directory=~S, File=~S, Name=~S, Version=~S>")
# Line 206  Line 185 
185    
186  (defvar *logical-hosts* (make-hash-table :test #'equal))  (defvar *logical-hosts* (make-hash-table :test #'equal))
187    
188  ;;; PATHSPEC -- internal type  ;;; PATH-DESIGNATOR -- internal type
189  ;;;  ;;;
190  (deftype path-designator ()  (deftype path-designator ()
191    "A path specification, either a string, stream or pathname."    "A path specification, either a string, stream or pathname."
192    '(or simple-base-string stream pathname))    '(or string stream pathname))
193    
194    
195  ;;;; Patterns  ;;;; Patterns
# Line 300  Line 279 
279                          (and (< start len)                          (and (< start len)
280                               (matches (cdr pieces) (1+ start) subs t                               (matches (cdr pieces) (1+ start) subs t
281                                        (cons (schar string start) chars))))                                        (cons (schar string start) chars))))
282                         ((member :wild :multi-char-wild)                         ((member :multi-char-wild)
283                          (multiple-value-bind                          (multiple-value-bind
284                              (won new-subs)                              (won new-subs)
285                              (matches (cdr pieces) start subs t chars)                              (matches (cdr pieces) start subs t chars)
# Line 315  Line 294 
294            (matches (pattern-pieces pattern) 0 nil nil nil)            (matches (pattern-pieces pattern) 0 nil nil nil)
295          (values won (reverse subs))))))          (values won (reverse subs))))))
296    
 ;;; VERIFY-WORD-CHAR-P -- Internal  
 ;;;  
 (defun verify-word-char-p (ch)  
   (if (or (eq ch #\-)  
           (and (char<= #\A ch) (char<= ch #\Z))  
           (and (char<= #\0 ch) (char<= ch #\9)))  
       t  
       nil))  
   
 (defun verify-wild-word-char-p (ch)  
   (if (or (and (char<= #\A ch) (char<= ch #\Z))  
           (and (char<= #\0 ch) (char<= ch #\9)))  
       t  
       nil))  
   
 ;;; VERIFY-WORD-P -- Internal  
 ;;;  
 (defun verify-word-p (wd)  
   (declare (type simple-base-string wd))  
   (let ((ch nil))  
     (dotimes (j (length wd))  
       (setf ch (schar wd j))  
       (unless (verify-word-char-p ch)  
         (error "~S is not a wildcard word, it contains an illegal character ~  
                 ~S" wd ch))))  
   t)  
   
 ;;; HOSTS-MATCH-P -- Internal  
 ;;;  
 ;;;   Predicate for host matching.  No :wild hosts permitted.  
 ;;;  
 (defun hosts-match-p (from-host to-host)  
   (declare (type (or host simple-base-string) from-host to-host))  
   (typecase from-host  
     (logical-host ; Subclass on logical-host first.  
      (typecase to-host  
        (logical-host  
         (eq from-host to-host))  
        (host  
         nil)  
        (simple-base-string  
         (eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))  
     (host  
      (typecase to-host  
        (logical-host  
         nil)  
        (host  
         (eq from-host to-host))  
        (simple-base-string  
         (eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))  
     (simple-base-string  
      (verify-word-p from-host)  
      (typecase to-host  
        (logical-host  
         (eq to-host (gethash (string-upcase from-host) *logical-hosts*)))  
        (simple-base-string  
         (verify-word-p to-host)  
         (string-equal from-host to-host))))))  
297    
298  ;;; WILDCARD-WORD-PARSE -- Internal  ;;; DIRECTORY-COMPONENTS-MATCH  --  Internal
299  ;;;  ;;;
300  ;;;   Parse a potential wildcard-word for its subcomponents as a pattern,  ;;;    Pathname-match-p for directory components.
 ;;; and return an error if the syntax is inconsistent.  
301  ;;;  ;;;
302  (defun wildcard-word-parse (wd)  (defun directory-components-match (thing wild)
303    (declare (type simple-base-string wd)    (or (eq thing wild)
304             (values (or simple-base-string pattern)))        (eq wild :wild)
305    (let* ((c nil)        (and (consp wild)
306           (*-p (position #\* wd))             (let ((wild1 (first wild)))
307           (start 0)               (if (eq wild1 :wild-inferiors)
308           (end (length wd))                   (let ((wild-subdirs (rest wild)))
309           (end-1 (1- end))                     (or (null wild-subdirs)
310           (piece nil)                         (loop
311           (pat nil))                           (when (directory-components-match thing wild-subdirs)
312      (when (and (not *-p) (verify-word-p wd))                             (return t))
313        (return-from wildcard-word-parse wd))                           (pop thing)
314      (dotimes (j end)                           (unless thing (return nil)))))
315        (setf c (schar wd j))                   (and (consp thing)
316       (when (eq c #\*)                        (components-match (first thing) wild1)
317          ;; Finish the preceeding word, place in pattern.                        (directory-components-match (rest thing)
318          (setf piece (subseq wd start j))                                                    (rest wild))))))))
319          (when (< 0 (length piece))  
           (push piece pat))  
         (push :wild pat)  
         (setf *-p t  
               start (1+ j))  
         (when (and (< j end-1) (eq (schar wd (1+ j)) #\*))  
               (error "~S is not a wildcard word, it contains a **." wd)))  
       ;; Verify c is a legitimate wildcard character.  
       (unless (verify-wild-word-char-p c)  
         (error "~S is not a wildcard word, it contains an illegal character: ~  
                 ~S" wd c))  
       (when (= j end-1)  
         (setf piece (subseq wd start (1+ j)))  
         (when (< 0 (length piece))  
           (push piece pat))))  
     (values (make-pattern (nreverse pat)))))  
320    
321  ;;; COMPONENTS-MATCH -- Internal  ;;; COMPONENTS-MATCH -- Internal
322  ;;;  ;;;
323  ;;;   Wilds in "to" are matched against "from" where both are strings,  ;;;   Return true if pathname component Thing is matched by Wild.  Not
324  ;;; patterns or lists containing :wild and :wild-inferiors.  ;;; commutative.
325  ;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory  ;;;
326  ;;; component. Not communative. Result is a Boolean or a member result.  (defun components-match (thing wild)
327  ;;;    (declare (type (or pattern symbol simple-string integer) thing wild))
328  (defun components-match (from to)    (or (eq thing wild)
329    (declare (type (or simple-base-string symbol pattern cons fixnum) from)        (eq wild :wild)
330             (type (or simple-base-string symbol pattern cons fixnum) to))        (typecase thing
   (or (eq from to)  
       (typecase from  
331          (simple-base-string          (simple-base-string
332           ;; Match can either be a identical pattern modulo wildcards or the           ;; String is matched by itself, a matching pattern or :WILD.
333           ;; same string.           (typecase wild
          (typecase to  
334             (pattern             (pattern
335              (values (pattern-matches to from)))              (values (pattern-matches wild thing)))
336             (simple-base-string             (simple-base-string
337              (string-equal from to))))              (string= thing wild))))
338          (pattern          (pattern
339           ;; Match is a identical pattern.           ;; A pattern is only matched by an identical pattern.
340           (and (pattern-p to) (pattern= from to)))           (and (pattern-p wild) (pattern= thing wild)))
341          ((member :wild)          (integer
342           ;; :WILD component matches any string, or pattern or NIL.           ;; an integer (version number) is matched by :WILD or the same
343           (or (stringp to)           ;; integer.  This branch will actually always be NIL as long is the
344               (logical-host-p to)           ;; version is a fixnum.
345               (pattern-p to)           (eql thing wild)))))
346               (member to '(nil :unspecific :newest :wild :wild-inferiors))))  
         ((member :newest)  
          ;; :newest matches itself, a wildcard or a positive integer version  
          ;; number.  
          (or (member to '(:wild :newest)) (and (integerp to) (plusp to))))  
         (cons ;; A list that may include wildcards.  
          (and (consp from)  
               (let ((from1 (first from))  
                     (from2 nil)  
                     (to1 (first to)))  
                 (typecase from1  
                   ((member :wild)  
                    (or (stringp to1)  
                        (pattern-p to1)  
                        (not to1)  
                        (eq to1 :unspecific)))  
                   ((member :wild-inferiors)  
                    (setf from2 (second from))  
                    (cond ((not from2)  
                           ;; Nothing left of from, hence anything else in to  
                           ;; matches :wild-inferiors.  
                           t)  
                          ((components-match  
                            (rest (rest from))  
                            (rest (member from2 to :test #'equal))))))  
                   (keyword ; :unspecific, :up, :back  
                    (and (keywordp to1)  
                         (eq from1 to1)  
                         (components-match (rest from) (rest to))))  
                   (string  
                    (and (stringp to1)  
                         (string-equal from1 to1)  
                         (components-match (rest from) (rest to))))))))  
         ((member :back :up :unspecific nil)  
          (and (pattern-p from)  
               (equal (pattern-pieces from) '(:multi-char-wild)))))))  
347    
348  ;;; COMPARE-COMPONENT  -- Internal  ;;; COMPARE-COMPONENT  -- Internal
349  ;;;  ;;;
# Line 542  Line 409 
409    `(let ((,var (let ((,var ,expr))    `(let ((,var (let ((,var ,expr))
410                   (typecase ,var                   (typecase ,var
411                     (logical-host ,var)                     (logical-host ,var)
412                     (string (gethash ,var *logical-hosts*))                     (string (find-host ,var))
413                     (t nil)))))                     (t nil)))))
414       ,@body))       ,@body))
415    
# Line 559  Line 426 
426  ;;;   Change the case of thing if diddle-p T.  ;;;   Change the case of thing if diddle-p T.
427  ;;;  ;;;
428  (defun maybe-diddle-case (thing diddle-p)  (defun maybe-diddle-case (thing diddle-p)
429    (declare (type (or list pattern simple-base-string (member :unspecific))    (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
                  thing)  
            (values (or list pattern simple-base-string (member :unspecific))))  
   (if diddle-p  
430        (labels ((check-for (pred in)        (labels ((check-for (pred in)
431                   (etypecase in                   (typecase in
432                     (pattern                     (pattern
433                      (dolist (piece (pattern-pieces in))                      (dolist (piece (pattern-pieces in))
434                        (when (typecase piece                        (when (typecase piece
# Line 583  Line 447 
447                      (dotimes (i (length in))                      (dotimes (i (length in))
448                        (when (funcall pred (schar in i))                        (when (funcall pred (schar in i))
449                          (return t))))                          (return t))))
450                     ((member :unspecific :up :absolute :relative)                     (t nil)))
                     nil)))  
451                 (diddle-with (fun thing)                 (diddle-with (fun thing)
452                   (etypecase thing                   (typecase thing
453                     (pattern                     (pattern
454                      (make-pattern                      (make-pattern
455                       (mapcar #'(lambda (piece)                       (mapcar #'(lambda (piece)
# Line 607  Line 470 
470                      (mapcar fun thing))                      (mapcar fun thing))
471                     (simple-base-string                     (simple-base-string
472                      (funcall fun thing))                      (funcall fun thing))
473                     ((member :unspecific :up :absolute :relative)                     (t
474                      thing))))                      thing))))
475          (let ((any-uppers (check-for #'upper-case-p thing))          (let ((any-uppers (check-for #'upper-case-p thing))
476                (any-lowers (check-for #'lower-case-p thing)))                (any-lowers (check-for #'lower-case-p thing)))
# Line 629  Line 492 
492                   thing))))                   thing))))
493        thing))        thing))
494    
495    
496  ;;; MERGE-DIRECTORIES -- Internal  ;;; MERGE-DIRECTORIES -- Internal
497  ;;;  ;;;
498  (defun merge-directories (dir1 dir2 diddle-case)  (defun merge-directories (dir1 dir2 diddle-case)
# Line 689  Line 553 
553  (defun import-directory (directory diddle-case)  (defun import-directory (directory diddle-case)
554    (etypecase directory    (etypecase directory
555      (null nil)      (null nil)
556        ((member :wild) '(:absolute :wild-inferiors))
557        ((member :unspecific) '(:relative))
558      (list      (list
559       (collect ((results))       (collect ((results))
560         (ecase (pop directory)         (ecase (pop directory)
# Line 699  Line 565 
565           (:relative           (:relative
566            (results :relative)))            (results :relative)))
567         (dolist (piece directory)         (dolist (piece directory)
568           (cond ((eq piece :wild)           (cond ((member piece '(:wild :wild-inferiors :up :back))
                 (results (make-pattern (list :multi-char-wild))))  
                ((eq piece :wild-inferiors)  
                 (results piece))  
                ((member piece '(:up :back))  
569                  (results piece))                  (results piece))
570                 ((or (simple-string-p piece) (pattern-p piece))                 ((or (simple-string-p piece) (pattern-p piece))
571                  (results (maybe-diddle-case piece diddle-case)))                  (results (maybe-diddle-case piece diddle-case)))
# Line 733  Line 595 
595                             (case :local))                             (case :local))
596    "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-
597     structure."     structure."
598    (declare (type (or host null) host)    (declare (type (or host component-tokens) host)
599             (type (member nil :unspecific) device)             (type component-tokens device)
600             (type (or list string pattern (member :wild)) directory)             (type (or list string pattern component-tokens) directory)
601             (type (or null string pattern (member :wild)) name)             (type (or string pattern component-tokens) name type)
602             (type (or null string pattern (member :unspecific :wild)) type)             (type (or integer component-tokens (member :newest)) version)
            (type (or null integer (member :unspecific :wild :newest)) version)  
603             (type (or path-designator null) defaults)             (type (or path-designator null) defaults)
604             (type (member :common :local) case))             (type (member :common :local) case))
605    (let* ((defaults (when defaults    (let* ((defaults (when defaults
# Line 747  Line 608 
608                             (%pathname-host defaults)                             (%pathname-host defaults)
609                             (pathname-host *default-pathname-defaults*)))                             (pathname-host *default-pathname-defaults*)))
610           (host (or host default-host))           (host (or host default-host))
611           (diddle-args (and (eq case :common)           (diddle-args (ecase (host-customary-case host)
612                             (eq (host-customary-case host) :lower)))                          (:lower (eq case :common))
613                            (:upper (eq case :local))))
614           (diddle-defaults           (diddle-defaults
615            (not (eq (host-customary-case host)            (not (eq (host-customary-case host)
616                     (host-customary-case default-host))))                     (host-customary-case default-host))))
# Line 765  Line 627 
627                                 diddle-defaults)))                                 diddle-defaults)))
628    
629      (macrolet ((pick (var varp field)      (macrolet ((pick (var varp field)
630                   `(cond ((eq ,var :wild)                   `(cond ((or (simple-string-p ,var)
                          (make-pattern (list :multi-char-wild)))  
                         ((or (simple-string-p ,var)  
631                               (pattern-p ,var))                               (pattern-p ,var))
632                           (maybe-diddle-case ,var diddle-args))                           (maybe-diddle-case ,var diddle-args))
633                          ((stringp ,var)                          ((stringp ,var)
# Line 783  Line 643 
643        (if (logical-host-p host)        (if (logical-host-p host)
644            (%make-logical-pathname            (%make-logical-pathname
645             host             host
646             nil             :unspecific
647             dir             dir
648             (pick name namep %pathname-name)             (pick name namep %pathname-name)
649             (pick type typep %pathname-type)             (pick type typep %pathname-type)
# Line 878  Line 738 
738            (namestring-parse-error-namestring condition)            (namestring-parse-error-namestring condition)
739            (namestring-parse-error-offset condition)))            (namestring-parse-error-offset condition)))
740    
741  (define-condition namestring-parse-error (error)  (define-condition namestring-parse-error (parse-error)
742    ((complaint :init-form (required-argument))    ((complaint :init-form (required-argument))
743     (arguments :init-form nil)     (arguments :init-form nil)
744     (namestring :init-form (required-argument))     (namestring :init-form (required-argument))
745     (offset :init-form (required-argument)))     (offset :init-form (required-argument)))
746    (:report %print-namestring-parse-error))    (:report %print-namestring-parse-error))
747    
748  ;;; %PARSE-PHYSICAL-NAMESTRING -- Internal  
749    ;;; %PARSE-NAMESTRING -- Internal
750  ;;;  ;;;
751  (defun %parse-physical-namestring (namestr things-host start end junk-allowed)  ;;;    Handle the case where parse-namestring is actually parsing a namestring.
752    (declare (type host things-host)  ;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing,
753             (type string namestr)  ;;; call the parser, then check if the host matches.
754             (type index start end))  ;;;
755    (cond (junk-allowed  (defun %parse-namestring (namestr host defaults start end junk-allowed)
756           (handler-case    (declare (type (or host null) host) (type string namestr)
757               (%parse-physical-namestring namestr things-host start end nil)             (type index start) (type (or index null) end))
758             (namestring-parse-error (condition)    (if junk-allowed
759               (values nil (namestring-parse-error-offset condition)))))        (handler-case
760          ((simple-string-p namestr)            (%parse-namestring namestr host defaults start end nil)
761           (multiple-value-bind          (namestring-parse-error (condition)
762               (new-host device directory file type version)            (values nil (namestring-parse-error-offset condition))))
763               (funcall (host-parse things-host) namestr start end)        (let* ((end (or end (length namestr)))
764             (declare (ignore new-host))               (parse-host (or host
765             (values                               (extract-logical-host-prefix namestr start end)
766              (%make-pathname things-host device directory file type version)                               (pathname-host defaults))))
767              end)))          (unless parse-host
768          (t            (error "When Host arg is not supplied, Defaults arg must ~
769           (%parse-physical-namestring (coerce namestr 'simple-base-string)                    have a non-null PATHNAME-HOST."))
770                                       things-host  
771                                       start end nil))))          (multiple-value-bind
772                (new-host device directory file type version)
773  ;;; %PARSE-LOGICAL-NAMESTRING -- Internal              (funcall (host-parse parse-host) namestr start end)
774  ;;;            (when (and host new-host (not (eq new-host host)))
775  (defun %parse-logical-namestring (namestr things-host start end junk-allowed)              (error "Host in namestring: ~S~@
776    (declare (type logical-host things-host)                      does not match explicit host argument: ~S"
777             (type string namestr)                     host))
778             (type index start end))            (let ((pn-host (or new-host parse-host)))
779    (cond (junk-allowed              (values (funcall (if (typep pn-host 'logical-host)
780           (handler-case                                   #'%make-logical-pathname
781               (%parse-logical-namestring namestr things-host start end nil)                                   #'%make-pathname)
782             (namestring-parse-error                               pn-host device directory file type version)
783              (condition)                      end))))))
784              (values nil (namestring-parse-error-offset condition)))))  
785          ((simple-string-p namestr)  
786           (multiple-value-bind  ;;; EXTRACT-LOGICAL-HOST-PREFIX -- Internal
              (lpath end)  
              (parse-logical-namestring namestr :host things-host  
                                        :start start :end end)  
            (values lpath end)))  
         (t  
          (%parse-logical-namestring (coerce namestr 'simple-base-string)  
                                     things-host  
                                     start end nil))))  
   
 ;;; EXTRACT-PATH-PREFIX -- Internal  
 ;;;  
 ;;;   Extract the host or search-list prefix from the beginning of the  
 ;;; namestring, use it to return the host structure, the colon-position  
 ;;; in the namestring for further search, and whether the namestring specifies  
 ;;; a logical namestring.  
787  ;;;  ;;;
788  (defun extract-path-prefix (namestr start end host defaults)  ;;;   If namestr begins with a colon-terminated, defined, logical host, then
789    ;;; return that host, otherwise return NIL.
790    ;;;
791    (defun extract-logical-host-prefix (namestr start end)
792    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
793             (type index start end)             (type index start end)
794             (type (or null host) host)             (values (or logical-host null)))
795             (type pathname defaults)    (let ((colon-pos (position #\: namestr :start start :end end)))
796             (values host index (or t null)))      (if colon-pos
797    (let* ((colon-pos (position #\: namestr :start start :end end))          (values (gethash (nstring-upcase (subseq namestr start colon-pos))
798           (host (if host host (%pathname-host defaults)))                           *logical-hosts*))
799           (host-temp nil)          nil)))
800           (lpathp nil)  
          (prefix-str nil))  
     (cond ((logical-host-p host)  
            (setf lpathp t)  
            (logical-host-name host))  
           (t  
            (funcall (host-unparse-host host) host)))  
     (unless colon-pos ; No logical host or search-list prefix to namestr.  
       (return-from extract-path-prefix (values host 0 lpathp)))  
     (setf prefix-str (subseq namestr start colon-pos)  
           lpathp (logical-word-p prefix-str))  
     (cond (lpathp ; If a legitimate logical host name prefix exists, use it.  
            (setf host-temp (gethash prefix-str *logical-hosts*))  
            (unless (and prefix-str host-temp)  
              (error "The logical-host ~S is not defined." prefix-str))  
            (setf host host-temp))  
           (t  
            (unless (gethash prefix-str *search-lists*)  
              (error "The prefix ~S to the pathname string ~S is not a ~  
                      registered search-list." prefix-str namestr))))  
     (values host colon-pos lpathp)))  
801    
802  ;;; PARSE-NAMESTRING -- Interface  ;;; PARSE-NAMESTRING -- Interface
803  ;;;  ;;;
# Line 985  Line 814 
814             (type (or index null) end)             (type (or index null) end)
815             (type (or t null) junk-allowed)             (type (or t null) junk-allowed)
816             (values (or null pathname) (or null index)))             (values (or null pathname) (or null index)))
   (let* ((end1 (or end (length thing)))  
          (things-host nil)  
          (colon-pos nil)  
          (lpathp nil))  
817      (typecase thing      (typecase thing
818        (simple-base-string        (simple-string
819         (multiple-value-setq         (%parse-namestring thing host defaults start end junk-allowed))
820             (things-host colon-pos lpathp)        (string
821           (extract-path-prefix thing start end1 host defaults))         (%parse-namestring (coerce thing 'simple-string)
822         (if lpathp                            host defaults start end junk-allowed))
823             (%parse-logical-namestring thing        (pathname
                                       things-host  
                                       colon-pos  
                                       end1  
                                       junk-allowed)  
            (%parse-physical-namestring thing  
                                        things-host  
                                        start  
                                        end1  
                                        junk-allowed)))  
       (pathname ; structure type  
824         (let* ((host (if host host (%pathname-host defaults)))         (let* ((host (if host host (%pathname-host defaults)))
825                (hosts-name (funcall (host-unparse-host host) host)))                (hosts-name (funcall (host-unparse-host host) host)))
826           (unless (eq hosts-name (%pathname-host thing))           (unless (eq hosts-name (%pathname-host thing))
# Line 1013  Line 828 
828                    hosts-name (%pathname-host thing))))                    hosts-name (%pathname-host thing))))
829         (values thing start))         (values thing start))
830        (stream        (stream
831         (let* ((stream-type (type-of thing))         ;; ### file-name really ought to retain the original pathname so that we
832                (things-host-name (host-namestring thing))         ;; know if it was logical.
833                (host (if host host (%pathname-host defaults)))         (let ((namestr (file-name thing)))
834                (hosts-name (funcall (host-unparse-host host) host)))           (unless namestr
835           (unless (or (eq stream-type 'fd-stream)             (error "Can't figure out the file associated with stream:~%  ~S"
836                       ;;######Change fd-stream to file-stream in sources too.                    thing))
837                       (eq stream-type 'synonym-stream))           (%parse-namestring namestr host defaults 0 nil nil)))))
838             (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~  
                    or MAKE-SYNONYM-FILE." thing))  
          (unless (string-equal hosts-name things-host-name)  
            (error "Hosts do not match: ~S and ~S."  
                   hosts-name things-host-name)))  
        (values (file-name thing) start)))))  
839    
840  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
841  ;;;  ;;;
# Line 1035  Line 845 
845             (values (or null simple-base-string)))             (values (or null simple-base-string)))
846    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
847      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
848        (cond ((logical-host-p host)        (unless host
849               (funcall (logical-host-unparse host) pathname))          (error "Cannot determine the namestring for pathnames with no ~
850              ((host-p host)                  host:~%  ~S" pathname))
851               (funcall (host-unparse host) pathname))        (funcall (host-unparse host) pathname))))
852              (t  
              (error  
               "Cannot determine the namestring for pathnames with no ~  
                host:~%  ~S" pathname))))))  
853    
854  ;;; HOST-NAMESTRING -- Interface  ;;; HOST-NAMESTRING -- Interface
855  ;;;  ;;;
# Line 1113  Line 920 
920             (type (member nil :host :device :directory :name :type :version)             (type (member nil :host :device :directory :name :type :version)
921                   field-key))                   field-key))
922    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
923      (ecase field-key      (flet ((frob (x)
924        ((nil)               (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
925         (or (wild-pathname-p pathname :host)        (ecase field-key
926             (wild-pathname-p pathname :device)          ((nil)
927             (wild-pathname-p pathname :directory)           (or (wild-pathname-p pathname :host)
928             (wild-pathname-p pathname :name)               (wild-pathname-p pathname :device)
929             (wild-pathname-p pathname :type)               (wild-pathname-p pathname :directory)
930             (wild-pathname-p pathname :version)))               (wild-pathname-p pathname :name)
931        (:host (pattern-p (%pathname-host pathname)))               (wild-pathname-p pathname :type)
932        (:device (pattern-p (%pathname-host pathname)))               (wild-pathname-p pathname :version)))
933        (:directory (some #'pattern-p (%pathname-directory pathname)))          (:host (frob (%pathname-host pathname)))
934        (:name (pattern-p (%pathname-name pathname)))          (:device (frob (%pathname-host pathname)))
935        (:type (pattern-p (%pathname-type pathname)))          (:directory (some #'frob (%pathname-directory pathname)))
936        (:version (eq (%pathname-version pathname) :wild)))))          (:name (frob (%pathname-name pathname)))
937            (:type (frob (%pathname-type pathname)))
938            (:version (frob (%pathname-version pathname)))))))
939    
940  ;;; PATHNAME-MATCH -- Interface  
941    ;;; PATHNAME-MATCH-P -- Interface
942  ;;;  ;;;
943  (defun pathname-match-p (in-pathname in-wildname)  (defun pathname-match-p (in-pathname in-wildname)
944    "Pathname matches the wildname template?"    "Pathname matches the wildname template?"
945    (declare (type path-designator in-pathname))    (declare (type path-designator in-pathname))
946    (with-pathname (pathname in-pathname)    (with-pathname (pathname in-pathname)
947      (with-pathname (wildname in-wildname)      (with-pathname (wildname in-wildname)
948        (macrolet ((frob (field)        (macrolet ((frob (field &optional (op 'components-match ))
949                     `(or (null (,field wildname))                     `(or (null (,field wildname))
950                          (components-match (,field wildname)                          (,op (,field pathname) (,field wildname)))))
                                           (,field pathname)))))  
951          (and (or (null (%pathname-host wildname))          (and (or (null (%pathname-host wildname))
952                   (components-match (logical-host-name                   (eq (%pathname-host wildname) (%pathname-host pathname)))
                                     (%pathname-host wildname))  
                                    (logical-host-name  
                                     (%pathname-host pathname))))  
953               (frob %pathname-device)               (frob %pathname-device)
954               (frob %pathname-directory)               (frob %pathname-directory directory-components-match)
955               (frob %pathname-name)               (frob %pathname-name)
956               (frob %pathname-type)               (frob %pathname-type)
957               (or (null (%pathname-version wildname))               (frob %pathname-version))))))
958                   (eq (%pathname-version wildname) :wild)  
                  (eql (%pathname-version pathname)  
                       (%pathname-version wildname))))))))  
959    
960  ;;; SUBSTITUTE-INTO -- Internal  ;;; SUBSTITUTE-INTO -- Internal
961  ;;;  ;;;
962  ;;;   Place the substitutions into the pattern and return the string or  ;;;   Place the substitutions into the pattern and return the string or pattern
963  ;;; pattern that results. The case argument allows for the use of a :lower  ;;; that results.  If DIDDLE-CASE is true, we diddle the result case as well,
964  ;;; case to enable a UNIX and implementation specific translation of uppercase  ;;; in case we are translating between hosts with difference conventional case.
965  ;;; characters in logical-namestrings into lower case physical namestrings.  ;;; The second value is the tail of subs with all of the values that we used up
966    ;;; stripped off.  Note that PATTERN-MATCHES matches all consecutive wildcards
967    ;;; as a single string, so we ignore subsequent contiguous wildcards.
968  ;;;  ;;;
969  (defun substitute-into (pattern subs &key (case :common))  (defun substitute-into (pattern subs diddle-case)
970    (declare (type pattern pattern)    (declare (type pattern pattern)
971             (type list subs)             (type list subs)
972             (values (or simple-base-string pattern)))             (values (or simple-base-string pattern)))
# Line 1169  Line 975 
975          (strings nil))          (strings nil))
976      (dolist (piece (pattern-pieces pattern))      (dolist (piece (pattern-pieces pattern))
977        (cond ((simple-string-p piece)        (cond ((simple-string-p piece)
978               (if (eq case 'lower)               (push piece strings)
                  (push (string-downcase piece) strings)  
                  (push piece strings))  
979               (setf in-wildcard nil))               (setf in-wildcard nil))
980              (in-wildcard)              (in-wildcard)
             ((null subs))  
981              (t              (t
982                 (setf in-wildcard t)
983                 (unless subs
984                   (error "Not enough wildcards in FROM pattern to match ~
985                           TO pattern:~%  ~S"
986                          pattern))
987               (let ((sub (pop subs)))               (let ((sub (pop subs)))
988                 (etypecase sub                 (typecase sub
989                   (pattern                   (pattern
990                    (when strings                    (when strings
991                      (push (apply #'concatenate 'simple-string                      (push (apply #'concatenate 'simple-string
992                                   (nreverse strings))                                   (nreverse strings))
993                            pieces))                            pieces))
994                    (dolist (piece (pattern-pieces sub))                    (dolist (piece (pattern-pieces sub))
995                      (if (and (stringp piece) (eq case 'lower))                      (push piece pieces)))
                         (push (string-downcase piece) pieces)  
                         (push piece pieces))))  
996                   (simple-string                   (simple-string
997                    (if (eq case 'lower)                    (push sub strings))
998                        (push (string-downcase sub) strings)                   (t
999                        (push sub strings)))))                    (error "Can't substitute this into the middle of a word:~
1000               (setf in-wildcard t))))                            ~%  ~S"
1001                             sub)))))))
1002    
1003      (when strings      (when strings
1004        (push (apply #'concatenate 'simple-string (nreverse strings))        (push (apply #'concatenate 'simple-string (nreverse strings))
1005              pieces))              pieces))
1006      (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))      (values
1007          (car pieces)       (maybe-diddle-case
1008          (make-pattern (nreverse pieces)))))        (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
1009              (car pieces)
1010              (make-pattern (nreverse pieces)))
1011          diddle-case)
1012         subs)))
1013    
1014    
1015    ;;; DIDNT-MATCH-ERROR  --  Internal
1016    ;;;
1017    ;;;    Called when we can't see how source and from matched.
1018    ;;;
1019    (defun didnt-match-error (source from)
1020      (error "Pathname components from Source and From args to TRANSLATE-PATHNAME~@
1021              did not match:~%  ~S ~S"
1022             source from))
1023    
1024    
1025  ;;; TRANSLATE-COMPONENT -- Internal  ;;; TRANSLATE-COMPONENT -- Internal
1026  ;;;  ;;;
1027  ;;;   Use the source as a pattern to fill the from path and form the to path.  ;;;   Do TRANSLATE-COMPONENT for all components except host and directory.
1028  ;;;  ;;;
1029  (defun translate-component (source from to)  (defun translate-component (source from to diddle-case)
1030    (typecase to    (typecase to
1031      (pattern      (pattern
1032       (if (pattern-p from)       (typecase from
1033           (typecase source         (pattern
1034             (pattern          (typecase source
1035              (if (pattern= from source)            (pattern
1036                  source             (if (pattern= from source)
1037                  :error))                 source
1038             (simple-string                 (didnt-match-error source from)))
1039              (multiple-value-bind            (simple-string
1040                  (won subs)             (multiple-value-bind
1041                  (pattern-matches from source)                 (won subs)
1042                (if won                 (pattern-matches from source)
1043                    (values (substitute-into to subs))               (if won
1044                    :error)))                   (values (substitute-into to subs diddle-case))
1045             (t                   (didnt-match-error source from))))
1046              :error))            (t
1047           source))             (maybe-diddle-case source diddle-case))))
1048           ((member :wild)
1049            (values (substitute-into to (list source) diddle-case)))
1050           (t
1051            (if (components-match source from)
1052                (maybe-diddle-case source diddle-case)
1053                (didnt-match-error source from)))))
1054      ((member nil :wild)      ((member nil :wild)
1055       source)       (maybe-diddle-case source diddle-case))
1056      (t      (t
1057       (if (components-match source from)       (if (components-match source from)
1058           to           to
1059           :error))))           (didnt-match-error source from)))))
1060    
1061    
1062    ;;; COMPUTE-DIRECTORY-SUBSTITUTIONS  --  Internal
1063    ;;;
1064    ;;;    Return a list of all the things that we want to substitute into the TO
1065    ;;; pattern (the things matched by from on source.)  When From contains
1066    ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1067    ;;; subdirectories.
1068    ;;;
1069    (defun compute-directory-substitutions (orig-source orig-from)
1070      (let ((source orig-source)
1071            (from orig-from))
1072        (collect ((subs))
1073          (loop
1074            (unless source
1075              (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
1076                (didnt-match-error orig-source orig-from))
1077              (subs ())
1078              (return))
1079            (unless from (didnt-match-error orig-source orig-from))
1080            (let ((from-part (pop from))
1081                  (source-part (pop source)))
1082              (typecase from-part
1083                (pattern
1084                 (typecase source-part
1085                   (pattern
1086                    (if (pattern= from-part source-part)
1087                        (subs source-part)
1088                        (didnt-match-error orig-source orig-from)))
1089                   (simple-string
1090                    (multiple-value-bind
1091                        (won new-subs)
1092                        (pattern-matches from-part source-part)
1093                      (if won
1094                          (dolist (sub new-subs)
1095                            (subs sub))
1096                          (didnt-match-error orig-source orig-from))))
1097                   (t
1098                    (didnt-match-error orig-source orig-from))))
1099                ((member :wild)
1100                 (subs source-part))
1101                ((member :wild-inferiors)
1102                 (let ((remaining-source (cons source-part source)))
1103                   (collect ((res))
1104                     (loop
1105                       (when (directory-components-match remaining-source from)
1106                         (return))
1107                       (unless remaining-source
1108                         (didnt-match-error orig-source orig-from))
1109                       (res (pop remaining-source)))
1110                     (subs (res))
1111                     (setq source remaining-source))))
1112                (simple-string
1113                 (unless (and (simple-string-p source-part)
1114                              (string= from-part source-part))
1115                   (didnt-match-error orig-source orig-from)))
1116                (t
1117                 (didnt-match-error orig-source orig-from)))))
1118          (subs))))
1119    
1120    
1121  ;;; TRANSLATE-DIRECTORIES -- Internal  ;;; TRANSLATE-DIRECTORIES -- Internal
1122  ;;;  ;;;
1123  (defun translate-directories (source from to)  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
1124    (if (null to)  ;;; pathanames to produce the result directory component.  If any leaves the
1125        source  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
1126        (let ((subs nil))  ;;; is always taken from the source directory.
1127          (loop  ;;;
1128            for from-part in from  (defun translate-directories (source from to diddle-case)
1129            for source-part in source    (if (not (and source to from))
1130            do (when (pattern-p from-part)        (or to
1131                 (typecase source-part            (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))
1132                   (pattern        (collect ((res))
1133                    (if (pattern= from-part source-part)          (res (first source))
1134                        (setf subs (append subs (list source-part)))          (let ((subs-left (compute-directory-substitutions (rest source)
1135                        (return-from translate-directories :error)))                                                            (rest from))))
1136                   (simple-string            (dolist (to-part (rest to))
1137                    (multiple-value-bind              (typecase to-part
1138                        (won new-subs)                ((member :wild)
1139                        (pattern-matches from-part source-part)                 (assert subs-left)
1140                      (if won                 (let ((match (pop subs-left)))
1141                          (setf subs (append subs new-subs))                   (when (listp match)
1142                          (return-from translate-directories :error))))                     (error ":WILD-INFERIORS not paired in from and to ~
1143                   ((member :back :up)                             patterns:~%  ~S ~S" from to))
1144                    (if (equal (pattern-pieces from-part)                   (maybe-diddle-case match diddle-case)))
1145                               '(:multi-char-wild))                ((member :wild-inferiors)
1146                        (setf subs (append subs (list source-part)))                 (assert subs-left)
1147                        (return-from translate-directories :error)))                 (let ((match (pop subs-left)))
1148                   (t                   (unless (listp match)
1149                    (return-from translate-directories :error)))))                     (error ":WILD-INFERIORS not paired in from and to ~
1150          (mapcar #'(lambda (to-part)                             patterns:~%  ~S ~S" from to))
1151                      (if (pattern-p to-part)                   (dolist (x match)
1152                          (if (or (eq (car subs) :up) (eq (car subs) :back))                     (res (maybe-diddle-case x diddle-case)))))
1153                              (if (equal (pattern-pieces to-part)                (pattern
1154                                         '(:multi-char-wild))                 (multiple-value-bind
1155                                  (pop subs)                     (new new-subs-left)
1156                                  (error "Can't splice ~S into the middle of a ~                     (substitute-into to-part subs-left diddle-case)
1157                                          wildcard pattern."                   (setf subs-left new-subs-left)
1158                                         (car subs)))                   new))
1159                              (multiple-value-bind                (t (res to-part)))))
1160                                  (new new-subs)          (res))))
1161                                  (substitute-into to-part subs)  
                               (setf subs new-subs)  
                               new))  
                         to-part))  
                 to))))  
1162    
1163  ;;; TRANSLATE-PATHNAME -- Interface  ;;; TRANSLATE-PATHNAME -- Interface
1164  ;;;  ;;;
# Line 1284  Line 1169 
1169    (with-pathname (source source)    (with-pathname (source source)
1170      (with-pathname (from from-wildname)      (with-pathname (from from-wildname)
1171        (with-pathname (to to-wildname)        (with-pathname (to to-wildname)
1172          (macrolet ((frob (field)            (let* ((source-host (%pathname-host source))
1173                       `(let ((result (translate-component (,field source)                   (to-host (%pathname-host to))
1174                                                           (,field from)                   (diddle-case
1175                                                           (,field to))))                    (and source-host to-host
1176                          (if (eq result :error)                         (not (eq (host-customary-case source-host)
1177                              (error "~S doesn't match ~S" source from)                                  (host-customary-case to-host))))))
1178                              result))))              (macrolet ((frob (field &optional (op 'translate-component))
1179            (%make-pathname (frob %pathname-host)                           `(let ((result (,op (,field source)
1180                            (frob %pathname-device)                                               (,field from)
1181                            (let ((result (translate-directories                                               (,field to)
1182                                           (%pathname-directory source)                                               diddle-case)))
                                          (%pathname-directory from)  
                                          (%pathname-directory to))))  
1183                              (if (eq result :error)                              (if (eq result :error)
1184                                  (error "~S doesn't match ~S" source from)                                  (error "~S doesn't match ~S" source from)
1185                                  result))                                  result))))
1186                            (frob %pathname-name)                (%make-pathname (or to-host source-host)
1187                            (frob %pathname-type)                                (frob %pathname-device)
1188                            (frob %pathname-version)))))))                                (frob %pathname-directory translate-directories)
1189                                  (frob %pathname-name)
1190                                  (frob %pathname-type)
1191                                  (frob %pathname-version))))))))
1192    
1193    
1194  ;;;; Search lists.  ;;;; Search lists.
# Line 1518  Line 1404 
1404  ;;;;  As logical-pathname translations are loaded they are canonicalized as  ;;;;  As logical-pathname translations are loaded they are canonicalized as
1405  ;;;;  patterns to enable rapid efficent translation into physical pathnames.  ;;;;  patterns to enable rapid efficent translation into physical pathnames.
1406    
1407  (define-condition logical-namestring-parse-error (error)  ;;;; Utilities:
   ((complaint :init-form (required-argument))  
    (arguments :init-form nil)  
    (namestring :init-form (required-argument))  
    (offset :init-form (required-argument)))  
   (:report %print-namestring-parse-error))  
1408    
1409  ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal  ;;; LOGICAL-WORD-OR-LOSE  --  Internal
1410  ;;;  ;;;
1411  ;;;  Take the ; reduced strings and break them into words and wildcard-words.  ;;;    Canonicalize a logical pathanme word by uppercasing it checking that it
1412    ;;; contains only legal characters.
1413  ;;;  ;;;
1414  (defun maybe-make-logical-pattern (namestr start end)  (defun logical-word-or-lose (word)
1415    (declare (type (or symbol simple-base-string) namestr)    (declare (string word))
1416             (type index start end)    (let ((word (string-upcase word)))
1417             (values (or null symbol pattern simple-base-string)))      (dotimes (i (length word))
1418    (collect ((pattern))        (let ((ch (schar word i)))
1419      (let ((last-regular-char nil)          (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1420            (look-ahead+1 nil)            (error 'namestring-parse-error
1421            (index start)                   :complaint "Logical namestring character ~
1422            (char nil))                               is not alphanumeric or hyphen:~%  ~S"
1423        (flet ((flush-pending-regulars ()                   :arguments (list ch)
1424                 (when last-regular-char                   :namestring word :offset i))))
1425                   (pattern (subseq namestr last-regular-char index))      word))
1426                   (setf last-regular-char nil))))  
1427          (loop  
1428            (when (>= index end)  ;;; FIND-LOGICAL-HOST  --  Internal
1429                  (return))  ;;;
1430            (setf char (schar namestr index))  ;;;    Given a logical host or string, return a logical host.  If Error-p is
1431            (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.  ;;; NIL, then return NIL when no such host exists.
1432                   (flush-pending-regulars))  ;;;
1433                  ((verify-word-char-p char) ; Building a word.  (defun find-logical-host (thing &optional (errorp t))
1434                   (unless last-regular-char    (etypecase thing
1435                     (setf last-regular-char index)))      (string
1436                  ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.       (let ((found (gethash (logical-word-or-lose thing)
1437                   (if (<= end index)                             *logical-hosts*)))
1438                       (setf look-ahead+1 nil)         (if (or found (not errorp))
1439                       (setf look-ahead+1 (schar namestr (1+ index))))             found
1440                   (cond ((or (char= #\. look-ahead+1)             (error "Logical host not yet defined: ~S" thing))))
1441                              (char= #\; look-ahead+1))      (logical-host thing)))
1442                          (flush-pending-regulars)  
                         (pattern :wild)  
                         (incf index)) ; skip * and ;  
                        ((and (char= #\* look-ahead+1)  
                              (char= #\; (schar namestr (+ 2 index))))  
                         (pattern :wild-inferiors)  
                         (setq last-regular-char nil)  
                         (incf index 2)) ; skip ** and ;  
                        (t ; wildcard-word, keep going  
                         (flush-pending-regulars)  
                         (pattern :wild)  
                         (incf index)  
                         (unless last-regular-char  
                           (setf last-regular-char index))  
                         )))  
                 (t (error "Incorrect logical pathname syntax.")))  
           (incf index))  
         (flush-pending-regulars))  
     (cond ((null (pattern))  
            "")  
           ((and (null (cdr (pattern)))  
                 (simple-string-p (car (pattern))))  
            (car (pattern)))  
           ((= 1 (length (pattern)))  
            (let ((elmt (first (pattern))))  
              (if (or (eq elmt :wild) (eq elmt :wild-inferiors))  
                  elmt)))  
           (t  
            (make-pattern (pattern)))))))  
1443    
1444  ;;; INTERN-LOGICAL-HOST -- Internal  ;;; INTERN-LOGICAL-HOST -- Internal
1445  ;;;  ;;;
1446  ;;;   The name is a string. Put it in the hash table, return the logical-host.  ;;;   Given a logical host name or host, return a logical host, creating a new
1447    ;;; one if necessary.
1448  ;;;  ;;;
1449  (defun intern-logical-host (name)  (defun intern-logical-host (thing)
1450    (declare (simple-string name)    (declare (values logical-host))
1451             (values logical-host))    (or (find-logical-host thing nil)
1452    (unless (logical-word-p name)        (let* ((name (logical-word-or-lose thing))
1453      (error "Hostname ~S is not a legitimate logical word ~%               (new (make-logical-host :name name)))
                (consisting of uppercase letters, digits and hyphens)." name))  
   (or (gethash name *logical-hosts*)  
       (let ((new (make-logical-host :name name)))  
1454          (setf (gethash name *logical-hosts*) new)          (setf (gethash name *logical-hosts*) new)
1455          new)))          new)))
1456    
1457  ;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION -- Internal  
1458  ;;;  ;;;; Logical pathname parsing:
1459  ;;;   Return a set of three elements that can be any of patterns, strings,  
1460  ;;; keywords, and integers.  ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal
1461  ;;;  ;;;
1462  (defun extract-logical-name-type-and-version (namestr start end)  ;;;    Deal with multi-char wildcards in a logical pathname token.
   (declare (type simple-base-string namestr)  
            (type index start end))  
   (let* ((last-dot (position #\. namestr :start (1+ start) :end end  
                              :from-end t))  
          (second-to-last-dot (and last-dot  
                                   (position #\. namestr :start (1+ start)  
                                             :end last-dot :from-end t)))  
          (version :newest))  
     ;; If there is a second-to-last dot, check to see if there is a valid  
     ;; version after the last dot.  
     (when second-to-last-dot  
       (cond ((and (= (+ last-dot 2) end)  
                   (char= (schar namestr (1+ last-dot)) #\*))  
              (setf version :wild))  
             ((and (< (1+ last-dot) end)  
                   (do ((index (1+ last-dot) (1+ index)))  
                       ((= index end) t)  
                     (unless (char<= #\0 (schar namestr index) #\9)  
                       (return nil))))  
              (setf version  
                    (parse-integer namestr :start (1+ last-dot) :end end)))  
             (t  
              (setf second-to-last-dot nil))))  
     (cond (second-to-last-dot  
            (values (maybe-make-logical-pattern  
                     namestr start second-to-last-dot)  
                    (maybe-make-logical-pattern  
                     namestr (1+ second-to-last-dot) last-dot)  
                    version))  
           (last-dot  
            (values (maybe-make-logical-pattern namestr start last-dot)  
                    (maybe-make-logical-pattern namestr (1+ last-dot) end)  
                    version))  
           (t  
            (values (maybe-make-logical-pattern namestr start end)  
                    nil  
                    version)))))  
   
 ;;; LOGICAL-WORD-P -- Internal  
 ;;;  
 ;;;    Predicate for testing whether the syntax of the word is consistent  
 ;;; with the form of a logical host.  
 ;;;  
 (defun logical-word-p (word)  
   (declare (type simple-base-string word)  
            (values (or t null)))  
   (let ((ch nil))  
     (dotimes (i (length word))  
       (setf ch (schar word i))  
       (unless (or (upper-case-p ch) (digit-char-p ch) (eq ch #\-))  
         (return-from logical-word-p nil))))  
   t)  
   
 ;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal  
 ;;;    Verify whether there is a logical host or search-list prefix in the  
 ;;; namestr. If one is found return its name and the index of the remainder of  
 ;;; the namestring.  If not return nil.  
1463  ;;;  ;;;
1464  (defun maybe-extract-logical-host (namestr start end)  (defun maybe-make-logical-pattern (namestring chunks)
1465    (declare (type simple-base-string namestr)    (let ((chunk (caar chunks)))
1466             (type index start)      (collect ((pattern))
1467             (type index start end)        (let ((last-pos 0)
1468             (values (or (member :wild) simple-base-string null) (or null index)))              (len (length chunk)))
1469    (let ((colon-pos (position #\: namestr :start start :end end)))          (declare (fixnum last-pos))
1470      (if colon-pos          (loop
1471          (let ((host (subseq namestr start colon-pos)))            (when (= last-pos len) (return))
1472            (cond ((logical-word-p host)            (let ((pos (or (position #\* chunk :start last-pos) len)))
1473                   (return-from maybe-extract-logical-host              (if (= pos last-pos)
1474                                (values host (1+ colon-pos))))                  (when (pattern)
1475                  ((string= host "*")                    (error 'namestring-parse-error
1476                   (return-from maybe-extract-logical-host                           :complaint "Double asterisk inside of logical ~
1477                                (values :wild (1+ colon-pos))))                                       word: ~S"
1478                  (t (error "Host component ~S in namestring ~S is neither a ~                           :arguments (list chunk)
1479                             wildcard (*),~%or a word formed from capital ~                           :namestring namestring
1480                             letters, digits and hyphens." host namestr))))                           :offset (+ (cdar chunks) pos)))
1481          ;; Implied host                  (pattern (subseq chunk last-pos pos)))
1482          (values nil 0))))              (if (= pos len)
1483                    (return)
1484  ;;; DECIDE-LOGICAL-HOST -- Internal                  (pattern :multi-char-wild))
1485  ;;;              (setq last-pos (1+ pos)))))
1486  (defun decide-logical-host (host path-host defaults-host)          (assert (pattern))
1487    (declare (type (or null host simple-base-string stream)          (if (cdr (pattern))
1488                   host path-host defaults-host)              (make-pattern (pattern))
1489             (values (or null logical-host)))              (let ((x (car (pattern))))
1490    (with-host (host-struc host)                (if (eq x :multi-char-wild)
1491       (with-host (path-host-struc path-host)                    :wild
1492          (with-host (defaults-host-struc defaults-host)                    x))))))
1493            (if host-struc  
1494                host-struc  
1495                (if path-host-struc  ;;; LOGICAL-CHUNKIFY  --  Internal
1496                    path-host-struc  ;;;
1497                    (if defaults-host-struc  ;;;    Return a list of conses where the cdr is the start position and the car
1498                        defaults-host-struc  ;;; is a string (token) or character (punctuation.)
1499                        (error "None of ~S, ~S, or ~S is a logical-host"  ;;;
1500                               host path-host defaults-host))))))))  (defun logical-chunkify (namestr start end)
1501      (collect ((chunks))
1502        (do ((i start (1+ i))
1503             (prev 0))
1504            ((= i end)
1505             (when (> end prev)
1506                (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1507          (let ((ch (schar namestr i)))
1508            (unless (or (alpha-char-p ch) (digit-char-p ch)
1509                        (member ch '(#\- #\*)))
1510              (when (> i prev)
1511                (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1512              (setq prev (1+ i))
1513              (unless (member ch '(#\; #\: #\.))
1514                (error 'namestring-parse-error
1515                       :complaint "Illegal character for logical pathname:~%  ~S"
1516                       :arguments (list ch)
1517                       :namestring namestr
1518                       :offset i))
1519              (chunks (cons ch i)))))
1520        (chunks)))
1521    
1522    
1523  ;;; PARSE-LOGICAL-NAMESTRING  -- Internal  ;;; PARSE-LOGICAL-NAMESTRING  -- Internal
1524  ;;;  ;;;
1525  ;;;   Break up a logical-namestring, always a string, into its constituent  ;;;   Break up a logical-namestring, always a string, into its constituent
1526  ;;; parts.  ;;; parts.
1527  ;;;  ;;;
1528  (defun parse-logical-namestring (namestr  (defun parse-logical-namestring (namestr start end)
                                  &key  
                                  host  
                                  (defaults *default-pathname-defaults*)  
                                  (start 0)  
                                  (end (length namestr)))  
1529    (declare (type simple-base-string namestr)    (declare (type simple-base-string namestr)
1530             (type index start end)             (type index start end))
1531             (type (or null simple-base-string logical-host stream) host)    (collect ((directory))
1532             (type pathname defaults)      (let ((host nil)
1533             (values (or null logical-pathname) (or null index)))            (name nil)
1534    (let ((namestring (string-upcase namestr))            (type nil)
1535          (default-host (pathname-host defaults)))            (version nil))
1536      ;; Parse for : prefixed hostname if present in namestr.        (labels ((expecting (what chunks)
1537      (multiple-value-bind (namestr-host place)                   (unless (and chunks (simple-string-p (caar chunks)))
1538                           (maybe-extract-logical-host namestring start end)                     (error 'namestring-parse-error
1539        ;; The explicit host argument is a logical host, or the host's name                            :complaint "Expecting ~A, got ~:[nothing~;~S~]."
1540        ;; or the defaults provide the host, in that order.                            :arguments (list what (caar chunks))
1541        (setf host (decide-logical-host host namestr-host default-host))                            :namestring namestr
1542        (multiple-value-bind (absolute pieces)                            :offset (if chunks (cdar chunks) end)))
1543                             (split-at-slashes namestring place end #\;)                   (caar chunks))
1544          ;; Logical paths follow opposite convention of physical pathnames.                 (parse-host (chunks)
1545          (setf absolute (not absolute))                   (case (caadr chunks)
1546          (multiple-value-bind (name type version)                     (#\:
1547                               (let* ((tail (car (last pieces)))                      (setq host
1548                                      (tail-start (car tail))                            (find-logical-host (expecting "a host name" chunks)))
1549                                      (tail-end (cdr tail)))                      (parse-relative (cddr chunks)))
1550                                 (unless (= tail-start tail-end)                     (t
1551                                   (setf pieces (butlast pieces))                      (parse-relative chunks))))
1552                                   (extract-logical-name-type-and-version                 (parse-relative (chunks)
1553                                    namestring tail-start tail-end)))                   (case (caar chunks)
1554            ;; Now we have everything we want.  Construct a logical pathname.                     (#\;
1555            (%make-logical-pathname                      (directory :relative)
1556             host                      (parse-directory (cdr chunks)))
1557             nil                     (t
1558             (collect ((dirs))                      (directory :absolute)
1559                      (dolist (piece pieces)                      (parse-directory chunks))))
1560                        (let ((piece-start (car piece))                 (parse-directory (chunks)
1561                              (piece-end (cdr piece)))                   (case (caadr chunks)
1562                          (unless (= piece-start piece-end)                     (#\;
1563                            (let ((dir                      (directory
1564                                   (maybe-make-logical-pattern namestring                       (let ((res (expecting "a directory name" chunks)))
1565                                                               piece-start                         (cond ((string= res "..") :up)
1566                                                               piece-end)))                               ((string= res "**") :wild-inferiors)
1567                              (if (and (simple-string-p dir)                               (t
1568                                       (string= dir ".."))                                (maybe-make-logical-pattern namestr chunks)))))
1569                                  (dirs :up)                      (parse-directory (cddr chunks)))
1570                                  (dirs dir))))))                     (t
1571                      (cond (absolute                      (parse-name chunks))))
1572                             (cons :absolute (dirs)))                 (parse-name (chunks)
1573                            ((dirs)                   (when chunks
1574                             (cons :relative (dirs)))                     (expecting "a file name" chunks)
1575                            (t                     (setq name (maybe-make-logical-pattern namestr chunks))
1576                             nil)))                     (expecting-dot (cdr chunks))))
1577             name                 (expecting-dot (chunks)
1578             type                   (when chunks
1579             version))))))                     (unless (eql (caar chunks) #\.)
1580                         (error 'namestring-parse-error
1581                                :complaint "Expecting a dot, got ~S."
1582                                :arguments (list (caar chunks))
1583                                :namestring namestr
1584                                :offset (cdar chunks)))
1585                       (if type
1586                           (parse-version (cdr chunks))
1587                           (parse-type (cdr chunks)))))
1588                   (parse-type (chunks)
1589                     (expecting "a file type" chunks)
1590                     (setq type (maybe-make-logical-pattern namestr chunks))
1591                     (expecting-dot (cdr chunks)))
1592                   (parse-version (chunks)
1593                     (let ((str (expecting "a positive integer, * or NEWEST"
1594                                           chunks)))
1595                       (cond
1596                        ((string= str "*") (setq version :wild))
1597                        ((string= str "NEWEST") (setq version :newest))
1598                        (t
1599                         (multiple-value-bind
1600                             (res pos)
1601                             (parse-integer str :junk-allowed t)
1602                           (unless (and res (plusp res))
1603                             (error 'namestring-parse-error
1604                                    :complaint "Expected a positive integer, ~
1605                                                got ~S"
1606                                    :arguments (list str)
1607                                    :namestring namestr
1608                                    :offset (+ pos (cdar chunks))))
1609                           (setq version res)))))
1610                     (when (cdr chunks)
1611                       (error 'namestring-parse-error
1612                              :complaint "Extra stuff after end of file name."
1613                              :namestring namestr
1614                              :offset (cdadr chunks)))))
1615            (parse-host (logical-chunkify namestr start end)))
1616          (values host :unspecific (directory) name type version))))
1617    
1618    
1619  ;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal  ;;; Can't defvar here because not all host methods are loaded yet.
1620    (declaim (special *logical-pathname-defaults*))
1621    
1622    ;;; LOGICAL-PATHNAME -- Public
1623  ;;;  ;;;
1624  (defun unparse-logical-directory-list (directory)  (defun logical-pathname (pathspec)
1625    (declare (type list directory))    "Converts the pathspec argument to a logical-pathname and returns it."
1626    (collect ((pieces))    (declare (type (or logical-pathname string stream) pathspec)
1627             (when directory             (values logical-pathname))
1628               (ecase (pop directory)    (if (typep pathspec 'logical-pathname)
1629                 (:absolute        pathspec
1630                  ;; Nothing special.        (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1631                  )          (when (eq (%pathname-host res)
1632                 (:relative                    (%pathname-host *logical-pathname-defaults*))
1633                  (pieces ";")            (error "Logical namestring does not specify a host:~%  ~S"
1634                  ))                   pathspec))
1635               (dolist (dir directory)          res)))
1636                 (cond ((or (stringp dir) (pattern-p dir))  
1637                        (pieces (unparse-logical-piece dir))  
1638                        (pieces ";"))  ;;;; Logical pathname unparsing:
                      ((eq dir :wild)  
                       (pieces "*;"))  
                      ((eq dir :wild-inferiors)  
                       (pieces "**;"))  
                      (t  
                       (error "Invalid directory component: ~S" dir)))))  
            (apply #'concatenate 'simple-string (pieces))))  
1639    
1640  ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal  ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal
1641  ;;;  ;;;
1642  (defun unparse-logical-directory (pathname)  (defun unparse-logical-directory (pathname)
1643    (declare (type logical-pathname pathname))    (declare (type pathname pathname))
1644    (unparse-logical-directory-list (%logical-pathname-directory pathname)))    (collect ((pieces))
1645        (let ((directory (%pathname-directory pathname)))
1646          (when directory
1647            (ecase (pop directory)
1648              (:absolute)    ;; Nothing special.
1649              (:relative (pieces ";")))
1650            (dolist (dir directory)
1651              (cond ((or (stringp dir) (pattern-p dir))
1652                     (pieces (unparse-logical-piece dir))
1653                     (pieces ";"))
1654                    ((eq dir :wild)
1655                     (pieces "*;"))
1656                    ((eq dir :wild-inferiors)
1657                     (pieces "**;"))
1658                    (t
1659                     (error "Invalid directory component: ~S" dir))))))
1660        (apply #'concatenate 'simple-string (pieces))))
1661    
1662    
1663  ;;; UNPARSE-LOGICAL-PIECE -- Internal  ;;; UNPARSE-LOGICAL-PIECE -- Internal
1664  ;;;  ;;;
1665  (defun unparse-logical-piece (thing)  (defun unparse-logical-piece (thing)
1666    (etypecase thing    (etypecase thing
1667      (simple-string      (simple-string thing)
      (let* ((srclen (length thing))  
             (dstlen srclen))  
        (dotimes (i srclen)  
          (case (schar thing i)  
            (#\*  
             (incf dstlen))))  
        (let ((result (make-string dstlen))  
              (dst 0))  
          (dotimes (src srclen)  
            (let ((char (schar thing src)))  
              (case char  
                (#\*  
                 (setf (schar result dst) #\\)  
                 (incf dst)))  
              (setf (schar result dst) char)  
              (incf dst)))  
          result)))  
1668      (pattern      (pattern
1669       (collect ((strings))       (collect ((strings))
1670                (dolist (piece (pattern-pieces thing))         (dolist (piece (pattern-pieces thing))
1671                  (typecase piece           (etypecase piece
1672                    (simple-string             (simple-string (strings piece))
1673                     (strings piece))             (keyword
1674                    (keyword              (cond ((eq piece :wild-inferiors)
1675                     (cond ((eq piece :wild-inferiors)                     (strings "**"))
1676                            (strings "**"))                    ((eq piece :multi-char-wild)
1677                           ((eq piece :wild)                     (strings "*"))
1678                            (strings "*"))                    (t (error "Invalid keyword: ~S" piece))))))
1679                           (t (error "Invalid keyword: ~S" piece))))         (apply #'concatenate 'simple-string (strings))))))
                   (t  
                    (error "Invalid pattern piece: ~S" piece))))  
               (apply #'concatenate  
                      'simple-string  
                      (strings))))))  
1680    
 ;;; UNPARSE-LOGICAL-FILE -- Internal  
 ;;;  
 (defun unparse-logical-file (pathname)  
   (declare (type pathname pathname))  
   (unparse-unix-file pathname))  
   
 ;;; UNPARSE-LOGICAL-HOST -- Internal  
 ;;;  
 (defun unparse-logical-host (pathname)  
   (declare (type logical-pathname pathname))  
   (logical-host-name (%logical-pathname-host pathname)))  
1681    
1682  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1683  ;;;  ;;;
1684  (defun unparse-logical-namestring (pathname)  (defun unparse-logical-namestring (pathname)
1685    (declare (type logical-pathname pathname))    (declare (type logical-pathname pathname))
1686    (concatenate 'simple-string    (concatenate 'simple-string
1687                 (unparse-logical-host pathname) ":"                 (logical-host-name (%pathname-host pathname)) ":"
1688                 (unparse-logical-directory pathname)                 (unparse-logical-directory pathname)
1689                 (unparse-logical-file pathname)))                 (unparse-unix-file pathname)))
1690    
1691  ;;; LOGICAL-PATHNAME -- Public  
1692  ;;;  ;;;; Logical pathname translations:
 ;;; Logical-pathname must signal an error of type type-error.  
 ;;;  
 (defun logical-pathname (pathspec)  
   "Converts the pathspec argument to a logical-pathname and returns it."  
   (declare (type (or logical-pathname simple-base-string stream) pathspec)  
            (values logical-pathname))  
   ;; Decide whether to typedef logical-pathname, logical-pathname-string,  
   ;; or streams for which the pathname function returns a logical-pathname.  
   (etypecase pathspec  
     (logical-pathname pathspec)  
     (simple-base-string  
      (let* ((l-pathspec (length pathspec))  
             (pathspec-host  
              (maybe-extract-logical-host pathspec 0 l-pathspec)))  
        (if pathspec-host  
            (parse-logical-namestring pathspec :host pathspec-host  
                                      :start 0 :end l-pathspec)  
            (error "Path specification ~S is not a logical pathname ~  
                    prefaced by <host>:." pathspec))))  
     (stream  
      (let ((stream-type (type-of pathspec))  
            (path-file (file-name pathspec)))  
        (unless (or (eq stream-type 'fd-stream)  
                    (eq stream-type 'synonym-stream))  
          (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~  
                  or MAKE-SYNONYM-FILE." pathspec))  
        (parse-logical-namestring path-file  
                                  :start 0 :end (length path-file))))))  
1693    
1694  ;;; TRANSLATIONS-TEST-P -- Internal  ;;; CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS -- Internal
1695  ;;;  ;;;
1696  ;;;   Verify that the list of translations consists of lists and prepare  ;;;   Verify that the list of translations consists of lists and prepare
1697  ;;; canonical translations (parse pathnames and expand out wildcards into  ;;; canonical translations (parse pathnames and expand out wildcards into
1698  ;;; patterns).  ;;; patterns).
1699  ;;;  ;;;
1700  (defun translations-test-p (transl-list host)  (defun canonicalize-logical-pathname-translations (transl-list host)
1701    (declare (type logical-host host)    (declare (type list transl-list) (type host host)
1702             (type list transl-list)             (values list))
1703             (values (or t null)))    (collect ((res))
1704    (let ((can-transls (make-list (length transl-list))); Canonical translations.      (dolist (tr transl-list)
1705          (c-tr nil))        (unless (and (consp tr) (= (length tr) 2))
1706      (setf (logical-host-canon-transls host) can-transls)          (error "Logical pathname translation is not a two-list:~%  ~S"
1707      (do* ((i 0 (1+ i))                 tr))
1708            (tr (nth i transl-list) (nth i transl-list))        (let ((from (first tr)))
1709            (from-path (first tr) (first tr))          (res (list (if (typep from 'logical-pathname)
1710            (to-path (second tr) (second tr)))                         from
1711           ((<= (length transl-list) i))                         (parse-namestring from host))
1712        (setf c-tr (make-list 2))                     (pathname (second tr))))))
1713        (if (logical-pathname-p from-path)      (res)))
1714          (setf (first c-tr) from-path)  
         (setf (first c-tr) (parse-namestring from-path host)))  
       (if (pathnamep to-path)  
           (setf (second c-tr) to-path)  
           (setf (second c-tr) (parse-namestring to-path)))  
       ;; Verify form of translations.  
       (unless (and (or (logical-pathname-p from-path) (first c-tr))  
                    (second c-tr))  
         (return-from translations-test-p nil))  
       (setf (nth i can-transls) c-tr)))  
   (setf (logical-host-translations host) transl-list)  
   t)  
1715    
1716  ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public  ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public
1717  ;;;  ;;;
1718  (defun logical-pathname-translations (host)  (defun logical-pathname-translations (host)
1719    "Return the (logical) host object argument's list of translations."    "Return the (logical) host object argument's list of translations."
1720    (declare (type (or simple-base-string logical-host) host)    (declare (type (or string logical-host) host)
1721             (values list))             (values list))
1722    (etypecase host    (logical-host-translations (find-logical-host host)))
1723      (simple-string  
      (let ((host-struc (gethash (string-upcase host) *logical-hosts*)))  
        (if host-struc  
            (logical-host-translations host-struc)  
            (error "HOST ~S is not defined." host))))  
     (logical-host  
      (logical-host-translations host))))  
1724    
1725  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public
1726  ;;;  ;;;
1727  (defun (setf logical-pathname-translations) (translations host)  (defun (setf logical-pathname-translations) (translations host)
1728    "Set the translations list for the logical host argument.    "Set the translations list for the logical host argument.
1729     Return translations."     Return translations."
1730    (declare (type (or simple-base-string logical-host) host)    (declare (type (or string logical-host) host)
1731             (type list translations)             (type list translations)
1732             (values list))             (values list))
1733    (setf host (string-upcase host))  
1734    (typecase host    (let ((host (intern-logical-host host)))
1735      (simple-base-string      (setf (logical-host-canon-transls host)
1736       (unless (logical-word-p host)            (canonicalize-logical-pathname-translations translations host))
1737         (error "Hostname ~S is not a legitimate logical word ~%      (setf (logical-host-translations host) translations)))
1738                 (consisting of uppercase letters, digits and hyphens)." host))  
      (multiple-value-bind  
          (hash-host xst?)  
          (gethash host *logical-hosts*)  
        (unless xst?  
          (setf hash-host (intern-logical-host host)))  
        (unless (translations-test-p translations hash-host)  
          (error "Translations ~S is not a list of pairs of from-, ~  
                  to-pathnames." translations)))  
      translations)  
     (t  
      (format t "TRANSLATIONS-TEST-P args = ~S, ~S~%" translations host)  
      (unless (translations-test-p translations host)  
        (error "Translations ~S is not a list of pairs of from- and ~  
                to-pathnames." translations))  
      translations)))  
1739    
1740  ;;; The search mechanism for loading pathname translations uses the CMUCL  ;;; The search mechanism for loading pathname translations uses the CMUCL
1741  ;;; extension of search-lists.  The user can add to the library: search-list  ;;; extension of search-lists.  The user can add to the library: search-list
1742  ;;; using setf.  The file for translations should have the name defined by  ;;; using setf.  The file for translations should have the name defined by
1743  ;;; the hostname (a string) and with type component "translations".  ;;; the hostname (a string) and with type component "translations".
1744    
 ;;; SAVE-LOGICAL-PATHNAME-TRANSLATIONS -- Public  
 ;;;  
 (defun save-logical-pathname-translations (host directory)  
   "Save the translations for host in the file named host in  
    the directory argument. This is an internal convenience function and  
    not part of the ANSI standard."  
   (declare (type simple-base-string host directory))  
   (setf host (string-upcase host))  
   (let* ((p-name (make-pathname :directory (%pathname-directory  
                                             (pathname directory))  
                                 :name host  
                                 :type "translations"  
                                 :version :newest))  
          (new-stuff (gethash host *logical-hosts*))  
          (new-transl (logical-host-translations new-stuff)))  
         (with-open-file (out-str p-name  
                                  :direction :output  
                                  :if-exists :new-version  
                                  :if-does-not-exist :create)  
           (write new-transl :stream out-str)  
           (format t "Created a new version of the file:~%   ~  
                      ~S~% ~  
                      containing logical-pathname translations:~%   ~  
                      ~S~% ~  
                      for the host:~%   ~  
                      ~S.~%" p-name new-transl host))))  
 #|  
 ;;; Define a SYS area for system dependent logical translations, should we  
 ;;; ever want to use them. Not currently used in CMUCL.  
   
 (progn  
   (intern-logical-host "SYS")  
   (save-logical-pathname-translations "SYS" "library:"))  
   
 |#  
   
1745  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
1746  ;;;  ;;;
1747  (defun load-logical-pathname-translations (host)  (defun load-logical-pathname-translations (host)
# Line 2016  Line 1749 
1749     defined no attempt to find or load a definition is attempted and NIL is     defined no attempt to find or load a definition is attempted and NIL is
1750     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
1751     successfully, T is returned, else error."     successfully, T is returned, else error."
1752    (declare (type simple-base-string host)    (declare (type string host)
1753             (values (or t null)))             (values (member t nil)))
1754    (setf host (string-upcase host))    (unless (find-logical-host host nil)
1755    (let ((p-name nil)      (with-open-file (in-str (make-pathname :defaults "library:"
1756          (p-trans nil))                                             :name host
1757      (multiple-value-bind                                             :type "translations"))
1758          (log-host xst?)        (format *error-output*
1759          (gethash host *logical-hosts*)                ";; Loading pathname translations from ~A~%"
1760        (if xst?                (namestring (truename in-str)))
1761            ;; host already has a set of defined translations.        (setf (logical-pathname-translations host) (read in-str)))
1762            (return-from load-logical-pathname-translations nil)      t))
1763            (enumerate-search-list (p "library:")  
              (setf p-name (make-pathname :host (%pathname-host p)  
                                          :directory (%pathname-directory p)  
                                          :device (%pathname-device p)  
                                          :name host  
                                          :type "translations"  
                                          :version :newest))  
              (if (member p-name (directory p) :test #'pathname=)  
                  (with-open-file (in-str p-name  
                                          :direction :input  
                                          :if-does-not-exist :error)  
                    (setf p-trans (read in-str))  
                    (setf log-host (intern-logical-host host))  
                    (format t ";; Loading ~S~%" p-name)  
                    (unless (translations-test-p p-trans log-host)  
                      (error "Translations ~S is not a list of pairs of from-, ~  
                              to-pathnames." p-trans))  
                    (format t ";; Loading done.~%")  
                    (return-from load-logical-pathname-translations t))))))))  
   
 ;;; COMPILE-FILE-PATHNAME -- Public  
 ;;;  
 (defun compile-file-pathname (file-path &key output-file)  
   (declare (type path-designator file-path)  
            (type (or null pathname) output-file)  
            (values (or null pathname)))  
   (if (logical-pathname-p file-path)  
       (if output-file  
           (translate-logical-pathname file-path)  
           (%make-logical-pathname  
            (or (%logical-pathname-host file-path)  
                (%pathname-host *default-pathname-defaults*))  
            nil  
            (or (%logical-pathname-directory file-path)  
                (%pathname-directory *default-pathname-defaults*))  
            (or (%logical-pathname-name file-path)  
                (%pathname-name *default-pathname-defaults*))  
            (c:backend-fasl-file-type c:*backend*)  
            (%pathname-version *default-pathname-defaults*)))  
       (with-pathname (path file-path)  
                      path)))  
   
 ;;; TRANSLATE-LOGICAL-HOST -- Internal  
 ;;;  
 (defun translate-logical-host (path-host from-host to-host)  
   "Pathname must contain a logical host or wild cards."  
   (declare (type (or logical-host host) path-host from-host to-host))  
   (cond ((or (eq path-host from-host) (eq from-host :wild)) to-host)  
         (t (throw 'next-translation nil))))  
   
 (defmacro translate-absolute-relative (src from to)  
   "Translate :ABSOLUTE and RELATIVE keywords."  
   `(if (eq ,src ,from)  
           ,to  
           (throw 'next-translation nil)))  
   
 (defmacro cleanup-to (from-context to-context result)  
   `(unless ,from-context  
      (setf ,result (append (reverse ,to-context) ,result))))  
   
 ;;; TRANSLATE-DIR-ELEMENTS -- Internal  
 ;;;  
 ;;;   The translation of pathnames occurs in two stages, the first produces an  
 ;;; intermediate result upon which the second is repeated.  
 ;;; The pathname result is a copy of the to element with each missing or  
 ;;; wildcard field filled in by a portion of from and placed in result.  
 ;;; If the to field is a :wild or :wild-inferiors, it is copied without any  
 ;;; further action. Wildcard-inferiors in the from field set the wild-inf-flag  
 ;;; and push the to field element onto the result, continuing until a match is  
 ;;; found.  
 ;;;  
 (defun translate-dir-elements (from from-context to to-context result  
                                     &optional wild-inf-flag)  
   "Translations are based on the element types of from and to, which can  
    recursively effect their repective contexts when they are :wild-inferiors."  
   (declare (type  
             (or null (member :wild :wild-inferiors) pattern  
                 simple-base-string)  
             from to)  
            (type list from-context to-context)  
            (type (or null t) wild-inf-flag)  
            (values list list list))  
   (let ((match-p nil)  
         (matches nil))  
     (typecase from  
       (simple-base-string  
        (typecase to  
          (simple-base-string  
           (cond (wild-inf-flag  
                  (push (string-downcase to) result)  
                  (multiple-value-setq (from-context to-context result)  
                    (translate-dir-elements from from-context  
                                            (pop to-context) to-context t)))  
                 (t ; Clean up, include any untranslated to leftovers.  
                  (push (string-downcase to) result)  
                  (cleanup-to from-context to-context result))))  
          (pattern  
           (multiple-value-setq (match-p matches)  
             (pattern-matches to from))  
           (cond (match-p  
                  (push (string-downcase from) result))  
                 (wild-inf-flag  
                  (push (string-downcase from) result)  
                  (multiple-value-setq (from-context to-context result)  
                    (translate-dir-elements from from-context  
                                            (pop to-context) to-context t)))  
                 (t  
                  (throw 'next-translation nil))))  
          ((member :wild :wild-inferiors)  
           ;; Clean up, include any untranslated to leftovers.  
           (push (string-downcase from) result)  
           (cleanup-to from-context to-context result))))  
       (pattern  
        (typecase to  
          (simple-base-string  
           (multiple-value-setq (match-p matches)  
             (pattern-matches from to))  
           (cond (match-p  
                  (push (string-downcase to) result)  
                  (cleanup-to from-context to-context result))  
                 (wild-inf-flag  
                  (push (string-downcase to) result)  
                  (multiple-value-setq (from-context to-context result)  
                    (translate-dir-elements (pop from-context) from-context  
                                            to to-context t)))  
                 (t  
                  (throw 'next-translation nil))))  
          (pattern  
           (cond ((and (pattern= from to) wild-inf-flag)  
                  (push to result)  
                  (multiple-value-setq (from-context to-context result)  
                    (translate-dir-elements (pop from-context) from-context  
                                            to to-context t)))  
                 ((pattern= from to)  
                  ;; Clean up, include any untranslated to leftovers.  
                  (push to result)  
                  (cleanup-to from-context to-context result))  
                 (t  
                  (throw 'next-translation nil))))  
          ((member :wild :wild-inferiors)  
           (push to result)  
           ;; Clean up, include any untranslated to leftovers.  
           (cleanup-to from-context to-context result))))  
       ((member :wild)  
        ;; Clean up, include any untranslated to leftovers.  
        (push to result)  
        (cleanup-to from-context to-context result))  
       ((member :wild-inferiors)  
        (push to result)  
        (multiple-value-setq (from-context to-context result)  
          (translate-dir-elements (pop from-context) from-context  
                                  to to-context t))))  
     (values from-context to-context result)))  
   
 ;;; TRANSLATE-DIRECTORY-LISTS -- Internal  
 ;;;  
 ;;;   Translate through the lists of strings of subdirectories.  
 ;;;  
 (defun translate-directory-lists (from to result)  
   (declare (type list from to result))  
   (let ((from-el (pop from))  
         (to-el (pop to)))  
     (cond (from-el  
            ;; There remains an untranslated element, translate it and the rest.  
            (multiple-value-setq (from to result)  
              (translate-dir-elements from-el from to-el to result))  
            (translate-directory-lists from to result))  
           (t ; Done.  
            (setf result (reverse result))))))  
   
 ;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal  
 ;;;  
 ;;;   Translate logical directories within the UNIX hierarchical file system,  
 ;;; which does not directly support :wildcard-inferiors.  Here :wild-inferiors  
 ;;; are allowed in a restricted form. The translation table is based on matching  
 ;;; first the source (src) directory component with the from directory  
 ;;; components, and if successful constructing result directory components.  
 ;;; If this is successful, then the result is matched relative to the the to-dir  
 ;;; and a possible translated result is generated.  
 ;;;  
 (defun translate-logical-directory (src-dirs from-dirs to-dirs)  
   (declare (type list src-dirs from-dirs to-dirs)  
            (values list))  
   (let ((result-dirs nil)  
         (transl-dirs nil))  
     ;; Cope with possible null directory lists.  
     (cond ((and (null src-dirs) (null from-dirs))  
            (return-from translate-logical-directory to-dirs))  
           ((or (null src-dirs) (null from-dirs))  
            (throw 'next-translation nil)))  
     ;; Compute the intermediate result by matching the source-dirs  
     ;; components with the from-dirs and placing the result in the result-dirs  
     ;; if the match is successful, otherwise throw to the next translation.  
     (setf result-dirs  
           (translate-directory-lists (rest src-dirs) (rest from-dirs)  
                                      result-dirs)  
           transl-dirs  
           (translate-directory-lists result-dirs (rest to-dirs)  
                                      transl-dirs))  
     (setf result-dirs (translate-absolute-relative  
                        (first src-dirs) (first from-dirs) transl-dirs))  
     (if result-dirs  
         (push (translate-absolute-relative  
                (first src-dirs) (first from-dirs) (first to-dirs))  
               transl-dirs))  
     transl-dirs))  
   
 ;;; TRANSLATE-LOGICAL-COMP-ELEMENT -- Internal  
 ;;;  
 (defun translate-logical-comp-element (from to)  
   (declare (type (or pattern simple-base-string fixnum symbol null) from to))  
   (let ((match-p nil)  
         (matches nil))  
     (typecase from  
       (simple-base-string  
        (typecase to  
          (simple-base-string  
           (string-downcase to))  
          (fixnum  
           (throw 'next-translation nil))  
          ((member :newest :wild nil)  
           (string-downcase from))  
          (pattern  
           (multiple-value-setq (match-p matches)  
             (pattern-matches to from))  
           (if match-p  
               (substitute-into to matches :case :lower)  
               (throw 'next-translation nil)))))  
       (fixnum  
        (typecase to  
          (fixnum  
           (if (<= from to)  
               to  
               from))  
          ((member :newest :wild nil)  
           to)  
          (pattern  
           (case (first (pattern-pieces to))  
             ((or :wild :newest) to)  
             (t (throw 'next-translation nil))))))  
       ((member :wild :newest nil)  
        to)  
       (pattern  
        (typecase to  
          (simple-base-string  
           (multiple-value-setq (match-p matches)  
             (pattern-matches from to))  
           (if match-p  
               (substitute-into from matches :case :lower)  
               (throw 'next-translation nil)))  
          (fixnum  
           (case (first (pattern-pieces from))  
             ((or :wild :newest) to)  
             (t (throw 'next-translation nil))))  
          ((member :newest :wild nil)  
           to)  
          (pattern  
           (if (pattern= from to)  
               to  
               (throw 'next-translation nil))))))))  
   
 ;;; TRANSLATE-LOGICAL-COMPONENT -- Internal  
 ;;;  
 (defun translate-logical-component (src from to)  
   (declare (type (or pattern simple-base-string fixnum symbol null) from to))  
   (translate-logical-comp-element (translate-logical-comp-element src from) to))  
1764    
1765  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
1766  ;;;  ;;;
# Line 2300  Line 1768 
1768    "Translates pathname to a physical pathname, which is returned."    "Translates pathname to a physical pathname, which is returned."
1769    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1770             (values (or null pathname)))             (values (or null pathname)))
1771    (with-pathname (source pathname)    (typecase pathname
1772       (when (logical-pathname-p source)      (logical-pathname
1773         (let ((p-host (%pathname-host source))       (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1774               (from nil)                  (error "No translation for ~S" pathname))
1775               (to nil)         (destructuring-bind (from to) x
1776               (tr-host nil)           (when (pathname-match-p pathname from)
1777               (tr-dir nil)             (return (translate-logical-pathname
1778               (tr-name nil)                      (translate-pathname pathname from to)))))))
1779               (tr-type nil)      (pathname pathname)
1780               (tr-version nil)      (t (translate-logical-pathname (logical-pathname pathname)))))
1781               (result-path nil)  
1782               (src-transl nil)  (defvar *logical-pathname-defaults*
1783               (i 0))    (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific
1784           (declare (type fixnum i)                            nil nil nil nil))
                   (type (or pathname null) result-path))  
          ;; Verify that the logical-host is defined.  
          (unless (gethash (funcall (logical-host-unparse-host p-host) source)  
                           *logical-hosts*)  
            (error "The logical host ~S is not defined.~%"  
                   (logical-host-name p-host)))  
          ;; Scan the pathname translations, and if none is found signal error.  
          (loop  
            (catch 'next-translation  
              (setf src-transl (nth i (logical-host-canon-transls p-host)))  
              (incf i)  
              (unless src-transl  
                (error "~S has no matching translation for logical host ~S.~%"  
                       pathname (logical-host-name p-host)))  
              (setf from (first src-transl)  
                    to (second src-transl))  
              (when (pathname-match-p pathname from)  
                (setf tr-host (translate-logical-host  
                               p-host  
                               (%pathname-host from)  
                               (%pathname-host to))  
                      tr-dir (translate-logical-directory  
                              (%pathname-directory source)  
                              (%pathname-directory from)  
                              (%pathname-directory to))  
                      tr-name (translate-logical-component  
                               (%pathname-name source)  
                               (%pathname-name from)  
                               (%pathname-name to))  
                      tr-type (translate-logical-component  
                               (%pathname-type source)  
                               (%pathname-type from)  
                               (%pathname-type to))  
                      tr-version (translate-logical-component  
                                  (%pathname-version source)  
                                  (%pathname-version from)  
                                  (%pathname-version to))  
                      result-path (%make-pathname tr-host  
                                                  :unspecific  
                                                  tr-dir  
                                                  tr-name  
                                                  tr-type  
                                                  tr-version))  
                (etypecase result-path  
                  (logical-pathname  
                   (translate-logical-pathname result-path))  
                  (pathname  
                   (return-from translate-logical-pathname result-path))  
                  (null  
                   (error "The logical path ~S could not be translated."  
                          pathname))))))))))  
   
   
   

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

  ViewVC Help
Powered by ViewVC 1.1.5