/[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.31 by dtc, Fri Jun 6 06:48:14 1997 UTC revision 1.31.2.4 by dtc, Mon Jul 10 06:31:59 2000 UTC
# Line 63  Line 63 
63                         #'(lambda (x) (logical-host-name (%pathname-host x))))                         #'(lambda (x) (logical-host-name (%pathname-host x))))
64                        (:unparse-directory #'unparse-logical-directory)                        (:unparse-directory #'unparse-logical-directory)
65                        (:unparse-file #'unparse-unix-file)                        (:unparse-file #'unparse-unix-file)
66                        (:unparse-enough #'identity)                        (:unparse-enough #'unparse-enough-namestring)
67                        (:customary-case :upper)))                        (:customary-case :upper)))
68    (name "" :type simple-base-string)    (name "" :type simple-base-string)
69    (translations nil :type list)    (translations nil :type list)
# Line 87  Line 87 
87    ;; Slot holds the host, at present either a UNIX or logical host.    ;; Slot holds the host, at present either a UNIX or logical host.
88    (host nil :type (or host null))    (host nil :type (or host null))
89    ;; Device is the name of a logical or physical device holding files.    ;; Device is the name of a logical or physical device holding files.
90    (device nil :type component-tokens)    (device nil :type (or simple-string component-tokens))
91    ;; A list of strings that are the component subdirectory components.    ;; A list of strings that are the component subdirectory components.
92    (directory nil :type list)    (directory nil :type list)
93    ;; The filename.    ;; The filename.
# Line 107  Line 107 
107    (let ((namestring (handler-case (namestring pathname)    (let ((namestring (handler-case (namestring pathname)
108                        (error nil))))                        (error nil))))
109      (cond (namestring      (cond (namestring
110             (format stream "#p~S" namestring))             (if (or *print-escape* *print-readably*)
111                   (format stream "#p~S" namestring)
112                   (format stream "~A" namestring)))
113            (*print-readably*            (*print-readably*
114             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
115            (t            (t
# Line 165  Line 167 
167    (let ((namestring (handler-case (namestring pathname)    (let ((namestring (handler-case (namestring pathname)
168                        (error nil))))                        (error nil))))
169      (cond (namestring      (cond (namestring
170             (format stream "#.(logical-pathname ~S)" namestring))             (if (or *print-escape* *print-readably*)
171                   (format stream "#.(logical-pathname ~S)" namestring)
172                   (format stream "~A" namestring)))
173            (*print-readably*            (*print-readably*
174             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
175            (t            (t
# Line 308  Line 312 
312    
313  ;;; DIRECTORY-COMPONENTS-MATCH  --  Internal  ;;; DIRECTORY-COMPONENTS-MATCH  --  Internal
314  ;;;  ;;;
315  ;;;    Pathname-match-p for directory components.  ;;;    Pathname-match-p for directory components. If thing is empty
316    ;;; then it matches :wild, (:absolute :wild-inferiors), or (:relative
317    ;;; :wild-inferiors).
318  ;;;  ;;;
319  (defun directory-components-match (thing wild)  (defun directory-components-match (thing wild)
320    (or (eq thing wild)    (or (eq thing wild)
321        (eq wild :wild)        (eq wild :wild)
322        (and (consp wild)        (and (consp wild)
323             (let ((wild1 (first wild)))             (let ((wild1 (first wild)))
324               (if (eq wild1 :wild-inferiors)               (cond ((and (null thing) (member wild1 '(:absolute :relative)))
325                   (let ((wild-subdirs (rest wild)))                      (equal (rest wild) '(:wild-inferiors)))
326                     (or (null wild-subdirs)                     ((eq wild1 :wild-inferiors)
327                         (loop                      (let ((wild-subdirs (rest wild)))
328                           (when (directory-components-match thing wild-subdirs)                        (or (null wild-subdirs)
329                             (return t))                            (loop
330                           (pop thing)                             (when (directory-components-match thing
331                           (unless thing (return nil)))))                                                               wild-subdirs)
332                   (and (consp thing)                               (return t))
333                        (components-match (first thing) wild1)                             (pop thing)
334                        (directory-components-match (rest thing)                             (unless thing (return nil))))))
335                                                    (rest wild))))))))                     ((consp thing)
336                        (and (components-match (first thing) wild1)
337                             (directory-components-match (rest thing)
338                                                         (rest wild)))))))))
339    
340    
341  ;;; COMPONENTS-MATCH -- Internal  ;;; COMPONENTS-MATCH -- Internal
# Line 611  Line 620 
620    "Makes a new pathname from the component arguments.  Note that host is    "Makes a new pathname from the component arguments.  Note that host is
621  a host-structure or string."  a host-structure or string."
622    (declare (type (or string host component-tokens) host)    (declare (type (or string host component-tokens) host)
623             (type component-tokens device)             (type (or string component-tokens) device)
624             (type (or list string pattern component-tokens) directory)             (type (or list string pattern component-tokens) directory)
625             (type (or string pattern component-tokens) name type)             (type (or string pattern component-tokens) name type)
626             (type (or integer component-tokens (member :newest)) version)             (type (or integer component-tokens (member :newest)) version)
# Line 780  a host-structure or string." Line 789  a host-structure or string."
789  ;;; call the parser, then check if the host matches.  ;;; call the parser, then check if the host matches.
790  ;;;  ;;;
791  (defun %parse-namestring (namestr host defaults start end junk-allowed)  (defun %parse-namestring (namestr host defaults start end junk-allowed)
792    (declare (type (or host null) host) (type string namestr)    (declare (type string namestr)
793             (type index start) (type (or index null) end))             (type (or host null) host)
794               (type index start)
795               (type (or index null) end))
796    (if junk-allowed    (if junk-allowed
797        (handler-case        (handler-case
798            (%parse-namestring namestr host defaults start end nil)            (%parse-namestring namestr host defaults start end nil)
# Line 836  a host-structure or string." Line 847  a host-structure or string."
847             (type (or null host) host)             (type (or null host) host)
848             (type pathname defaults)             (type pathname defaults)
849             (type index start)             (type index start)
850             (type (or index null) end)             (type (or index null) end))
851             (type (or t null) junk-allowed)      (etypecase thing
            (values (or null pathname) (or null index)))  
     (typecase thing  
852        (simple-string        (simple-string
853         (%parse-namestring thing host defaults start end junk-allowed))         (%parse-namestring thing host defaults start end junk-allowed))
854        (string        (string
# Line 856  a host-structure or string." Line 865  a host-structure or string."
865           (unless name           (unless name
866             (error "Can't figure out the file associated with stream:~%  ~S"             (error "Can't figure out the file associated with stream:~%  ~S"
867                    thing))                    thing))
868           name))))           (values name nil)))))
869    
870    
871  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
# Line 954  a host-structure or string." Line 963  a host-structure or string."
963               (wild-pathname-p pathname :type)               (wild-pathname-p pathname :type)
964               (wild-pathname-p pathname :version)))               (wild-pathname-p pathname :version)))
965          (:host (frob (%pathname-host pathname)))          (:host (frob (%pathname-host pathname)))
966          (:device (frob (%pathname-host pathname)))          (:device (frob (%pathname-device pathname)))
967          (:directory (some #'frob (%pathname-directory pathname)))          (:directory (some #'frob (%pathname-directory pathname)))
968          (:name (frob (%pathname-name pathname)))          (:name (frob (%pathname-name pathname)))
969          (:type (frob (%pathname-type pathname)))          (:type (frob (%pathname-type pathname)))
# Line 992  a host-structure or string." Line 1001  a host-structure or string."
1001  (defun substitute-into (pattern subs diddle-case)  (defun substitute-into (pattern subs diddle-case)
1002    (declare (type pattern pattern)    (declare (type pattern pattern)
1003             (type list subs)             (type list subs)
1004             (values (or simple-base-string pattern)))             (values (or simple-base-string pattern) list))
1005    (let ((in-wildcard nil)    (let ((in-wildcard nil)
1006          (pieces nil)          (pieces nil)
1007          (strings nil))          (strings nil))
# Line 1146  a host-structure or string." Line 1155  a host-structure or string."
1155  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
1156  ;;; pathanames to produce the result directory component.  If any leaves the  ;;; pathanames to produce the result directory component.  If any leaves the
1157  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
1158  ;;; is always taken from the source directory.  ;;; is taken from the source directory, except if TO is :ABSOLUTE, in which
1159    ;;; case the result will be :ABSOLUTE.
1160  ;;;  ;;;
1161  (defun translate-directories (source from to diddle-case)  (defun translate-directories (source from to diddle-case)
1162    (if (not (and source to from))    (if (not (and source to from))
1163        (or to        (let ((source (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case))
1164            (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))                              source)))
1165            (if (null to)
1166                source
1167                (collect ((res))
1168                  (res (cond ((null source) (first to))
1169                             ((eq (first to) :absolute) :absolute)
1170                             (t (first source))))
1171                  (let ((match (rest source)))
1172                    (dolist (to-part (rest to))
1173                      (cond ((eq to-part :wild)
1174                             (when match
1175                               (res (first match))
1176                               (setf match nil)))
1177                            ((eq to-part :wild-inferiors)
1178                             (when match
1179                               (dolist (src-part match)
1180                                 (res src-part))
1181                               (setf match nil)))
1182                            (t
1183                             (res to-part)))))
1184                  (res))))
1185        (collect ((res))        (collect ((res))
1186          (res (first source))          (res (if (eq (first to) :absolute)
1187                     :absolute
1188                     (first source)))
1189          (let ((subs-left (compute-directory-substitutions (rest source)          (let ((subs-left (compute-directory-substitutions (rest source)
1190                                                            (rest from))))                                                            (rest from))))
1191            (dolist (to-part (rest to))            (dolist (to-part (rest to))
# Line 1164  a host-structure or string." Line 1196  a host-structure or string."
1196                   (when (listp match)                   (when (listp match)
1197                     (error ":WILD-INFERIORS not paired in from and to ~                     (error ":WILD-INFERIORS not paired in from and to ~
1198                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S" from to))
1199                   (maybe-diddle-case match diddle-case)))                   (res (maybe-diddle-case match diddle-case))))
1200                ((member :wild-inferiors)                ((member :wild-inferiors)
1201                 (assert subs-left)                 (assert subs-left)
1202                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
# Line 1178  a host-structure or string." Line 1210  a host-structure or string."
1210                     (new new-subs-left)                     (new new-subs-left)
1211                     (substitute-into to-part subs-left diddle-case)                     (substitute-into to-part subs-left diddle-case)
1212                   (setf subs-left new-subs-left)                   (setf subs-left new-subs-left)
1213                   new))                   (res new)))
1214                (t (res to-part)))))                (t (res to-part)))))
1215          (res))))          (res))))
1216    
# Line 1458  a host-structure or string." Line 1490  a host-structure or string."
1490                             *logical-hosts*)))                             *logical-hosts*)))
1491         (if (or found (not errorp))         (if (or found (not errorp))
1492             found             found
1493             (error "Logical host not yet defined: ~S" thing))))             (error 'simple-file-error
1494                      :pathname thing
1495                      :format-control "Logical host not yet defined: ~S"
1496                      :format-arguments (list thing)))))
1497      (logical-host thing)))      (logical-host thing)))
1498    
1499    
# Line 1701  a host-structure or string." Line 1736  a host-structure or string."
1736                    (t (error "Invalid keyword: ~S" piece))))))                    (t (error "Invalid keyword: ~S" piece))))))
1737         (apply #'concatenate 'simple-string (strings))))))         (apply #'concatenate 'simple-string (strings))))))
1738    
1739    ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
1740    ;;;
1741    (defun unparse-enough-namestring (pathname defaults)
1742      (let* ((path-dir (pathname-directory pathname))
1743            (def-dir (pathname-directory defaults))
1744            (enough-dir
1745             ;; Go down the directory lists to see what matches.  What's
1746             ;; left is what we want, more or less.
1747             (cond ((and (eq (first path-dir) (first def-dir))
1748                         (eq (first path-dir) :absolute))
1749                    ;; Both paths are :absolute, so find where the common
1750                    ;; parts end and return what's left
1751                    (do* ((p (rest path-dir) (rest p))
1752                          (d (rest def-dir) (rest d)))
1753                         ((or (endp p) (endp d)
1754                              (not (equal (first p) (first d))))
1755                          `(:relative ,@p))))
1756                   (t
1757                    ;; At least one path is :relative, so just return the
1758                    ;; original path.  If the original path is :relative,
1759                    ;; then that's the right one.  If PATH-DIR is
1760                    ;; :absolute, we want to return that except when
1761                    ;; DEF-DIR is :absolute, as handled above. so return
1762                    ;; the original directory.
1763                    path-dir))))
1764        (make-pathname :host (pathname-host pathname)
1765                      :directory enough-dir
1766                      :name (pathname-name pathname)
1767                      :type (pathname-type pathname)
1768                      :version (pathname-version pathname))))
1769    
1770  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1771  ;;;  ;;;
# Line 1795  a host-structure or string." Line 1860  a host-structure or string."
1860    (typecase pathname    (typecase pathname
1861      (logical-pathname      (logical-pathname
1862       (dolist (x (logical-host-canon-transls (%pathname-host pathname))       (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1863                  (error "No translation for ~S" pathname))                  (error 'simple-file-error
1864                           :pathname pathname
1865                           :format-control "No translation for ~S"
1866                           :format-arguments (list pathname)))
1867         (destructuring-bind (from to) x         (destructuring-bind (from to) x
1868           (when (pathname-match-p pathname from)           (when (pathname-match-p pathname from)
1869             (return (translate-logical-pathname             (return (translate-logical-pathname

Legend:
Removed from v.1.31  
changed lines
  Added in v.1.31.2.4

  ViewVC Help
Powered by ViewVC 1.1.5