/[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.2 by pw, Tue May 23 16:36:42 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 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 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.2

  ViewVC Help
Powered by ViewVC 1.1.5