/[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.5 by pw, Sat Mar 23 18:50:07 2002 UTC
# Line 17  Line 17 
17    
18  (in-package "LISP")  (in-package "LISP")
19    
20  (export '(pathname pathnamep logical-pathname logical-pathname-p  (export '(pathname pathnamep logical-pathname
21            parse-namestring merge-pathnames make-pathname            parse-namestring merge-pathnames make-pathname
22            pathname-host pathname-device pathname-directory pathname-name            pathname-host pathname-device pathname-directory pathname-name
23            pathname-type pathname-version namestring file-namestring            pathname-type pathname-version namestring file-namestring
# Line 28  Line 28 
28    
29  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
30  (export '(search-list search-list-defined-p clear-search-list  (export '(search-list search-list-defined-p clear-search-list
31                        enumerate-search-list))                        enumerate-search-list *autoload-translations*))
32    
33  (in-package "LISP")  (in-package "LISP")
34    
35    (defvar *autoload-translations* nil
36      "When non-nil, attempt to load \"library:<host>.translations\" to resolve
37       an otherwise undefined logical host.")
38    
39    
40  ;;;; HOST structures  ;;;; HOST structures
41    
# Line 53  Line 57 
57  ;;;  ;;;
58  (defun %print-host (host stream depth)  (defun %print-host (host stream depth)
59    (declare (ignore depth))    (declare (ignore depth))
60    (print-unreadable-object (host stream :type t :identity t)))    (print-unreadable-object (host stream :type t)))
61    
62  (defstruct (logical-host  (defstruct (logical-host
63              (:include host              (:include host
# Line 63  Line 67 
67                         #'(lambda (x) (logical-host-name (%pathname-host x))))                         #'(lambda (x) (logical-host-name (%pathname-host x))))
68                        (:unparse-directory #'unparse-logical-directory)                        (:unparse-directory #'unparse-logical-directory)
69                        (:unparse-file #'unparse-unix-file)                        (:unparse-file #'unparse-unix-file)
70                        (:unparse-enough #'identity)                        (:unparse-enough #'unparse-enough-namestring)
71                        (:customary-case :upper)))                        (:customary-case :upper)))
72    (name "" :type simple-base-string)    (name "" :type simple-base-string)
73    (translations nil :type list)    (translations nil :type list)
# Line 87  Line 91 
91    ;; Slot holds the host, at present either a UNIX or logical host.    ;; Slot holds the host, at present either a UNIX or logical host.
92    (host nil :type (or host null))    (host nil :type (or host null))
93    ;; Device is the name of a logical or physical device holding files.    ;; Device is the name of a logical or physical device holding files.
94    (device nil :type component-tokens)    (device nil :type (or simple-string component-tokens))
95    ;; A list of strings that are the component subdirectory components.    ;; A list of strings that are the component subdirectory components.
96    (directory nil :type list)    (directory nil :type list)
97    ;; The filename.    ;; The filename.
# Line 107  Line 111 
111    (let ((namestring (handler-case (namestring pathname)    (let ((namestring (handler-case (namestring pathname)
112                        (error nil))))                        (error nil))))
113      (cond (namestring      (cond (namestring
114             (format stream "#p~S" namestring))             (if (or *print-escape* *print-readably*)
115                   (format stream "#p~S" namestring)
116                   (format stream "~A" namestring)))
117            (*print-readably*            (*print-readably*
118             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
119            (t            (t
# Line 165  Line 171 
171    (let ((namestring (handler-case (namestring pathname)    (let ((namestring (handler-case (namestring pathname)
172                        (error nil))))                        (error nil))))
173      (cond (namestring      (cond (namestring
174             (format stream "#.(logical-pathname ~S)" namestring))             (if (or *print-escape* *print-readably*)
175                   (format stream "#.(logical-pathname ~S)" namestring)
176                   (format stream "~A" namestring)))
177            (*print-readably*            (*print-readably*
178             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
179            (t            (t
# Line 308  Line 316 
316    
317  ;;; DIRECTORY-COMPONENTS-MATCH  --  Internal  ;;; DIRECTORY-COMPONENTS-MATCH  --  Internal
318  ;;;  ;;;
319  ;;;    Pathname-match-p for directory components.  ;;;    Pathname-match-p for directory components. If thing is empty
320    ;;; then it matches :wild, (:absolute :wild-inferiors), or (:relative
321    ;;; :wild-inferiors).
322  ;;;  ;;;
323  (defun directory-components-match (thing wild)  (defun directory-components-match (thing wild)
324    (or (eq thing wild)    (or (eq thing wild)
325        (eq wild :wild)        (eq wild :wild)
326        (and (consp wild)        (and (consp wild)
327             (let ((wild1 (first wild)))             (let ((wild1 (first wild)))
328               (if (eq wild1 :wild-inferiors)               (cond ((and (null thing) (member wild1 '(:absolute :relative)))
329                   (let ((wild-subdirs (rest wild)))                      (equal (rest wild) '(:wild-inferiors)))
330                     (or (null wild-subdirs)                     ((eq wild1 :wild-inferiors)
331                         (loop                      (let ((wild-subdirs (rest wild)))
332                           (when (directory-components-match thing wild-subdirs)                        (or (null wild-subdirs)
333                             (return t))                            (loop
334                           (pop thing)                             (when (directory-components-match thing
335                           (unless thing (return nil)))))                                                               wild-subdirs)
336                   (and (consp thing)                               (return t))
337                        (components-match (first thing) wild1)                             (pop thing)
338                        (directory-components-match (rest thing)                             (unless thing (return nil))))))
339                                                    (rest wild))))))))                     ((consp thing)
340                        (and (components-match (first thing) wild1)
341                             (directory-components-match (rest thing)
342                                                         (rest wild)))))))))
343    
344    
345  ;;; COMPONENTS-MATCH -- Internal  ;;; COMPONENTS-MATCH -- Internal
# Line 560  Line 573 
573           (or (%pathname-type pathname)           (or (%pathname-type pathname)
574               (maybe-diddle-case (%pathname-type defaults)               (maybe-diddle-case (%pathname-type defaults)
575                                  diddle-case))                                  diddle-case))
576           (or (%pathname-version pathname)           (or (if (null (%pathname-name pathname))
577                     (or (%pathname-version pathname)
578                         (%pathname-version defaults))
579                     (%pathname-version pathname))
580               default-version))))))               default-version))))))
581    
582  ;;; IMPORT-DIRECTORY -- Internal  ;;; IMPORT-DIRECTORY -- Internal
# Line 611  Line 627 
627    "Makes a new pathname from the component arguments.  Note that host is    "Makes a new pathname from the component arguments.  Note that host is
628  a host-structure or string."  a host-structure or string."
629    (declare (type (or string host component-tokens) host)    (declare (type (or string host component-tokens) host)
630             (type component-tokens device)             (type (or string component-tokens) device)
631             (type (or list string pattern component-tokens) directory)             (type (or list string pattern component-tokens) directory)
632             (type (or string pattern component-tokens) name type)             (type (or string pattern component-tokens) name type)
633             (type (or integer component-tokens (member :newest)) version)             (type (or integer component-tokens (member :newest)) version)
# Line 660  a host-structure or string." Line 676  a host-structure or string."
676              (merge-directories dir              (merge-directories dir
677                                 (%pathname-directory defaults)                                 (%pathname-directory defaults)
678                                 diddle-defaults)))                                 diddle-defaults)))
679    
680        ;; A bit of sanity checking on user arguments.
681        (flet ((check-component-validity (name name-or-type)
682                 (when (stringp name)
683                   (let ((unix-directory-separator #\/))
684                     (when (eq host (pathname-host *default-pathname-defaults*))
685                       (when (find unix-directory-separator name)
686                         (warn "Silly argument for a unix ~A: ~S"
687                               name-or-type name)))))))
688          (check-component-validity name :pathname-name)
689          (check-component-validity type :pathname-type))
690    
691      (macrolet ((pick (var varp field)      (macrolet ((pick (var varp field)
692                   `(cond ((or (simple-string-p ,var)                   `(cond ((or (simple-string-p ,var)
# Line 780  a host-structure or string." Line 807  a host-structure or string."
807  ;;; call the parser, then check if the host matches.  ;;; call the parser, then check if the host matches.
808  ;;;  ;;;
809  (defun %parse-namestring (namestr host defaults start end junk-allowed)  (defun %parse-namestring (namestr host defaults start end junk-allowed)
810    (declare (type (or host null) host) (type string namestr)    (declare (type string namestr)
811             (type index start) (type (or index null) end))             (type (or host string null) host)
812               (type pathname defaults)
813               (type index start)
814               (type (or index null) end))
815    (if junk-allowed    (if junk-allowed
816        (handler-case        (handler-case
817            (%parse-namestring namestr host defaults start end nil)            (%parse-namestring namestr host defaults start end nil)
818          (namestring-parse-error (condition)          (namestring-parse-error (condition)
819            (values nil (namestring-parse-error-offset condition))))            (values nil (namestring-parse-error-offset condition))))
820        (let* ((end (or end (length namestr)))        (let* ((end (or end (length namestr)))
821                 (host (if (and host (stringp host))
822                           (find-logical-host host)
823                           host))
824                 (default-host (pathname-host defaults))
825               (parse-host (or host               (parse-host (or host
826                               (extract-logical-host-prefix namestr start end)                               (extract-logical-host-prefix namestr start end)
827                               (pathname-host defaults))))                               default-host)))
828          (unless parse-host          (unless parse-host
829            (error "When Host arg is not supplied, Defaults arg must ~            (error "When Host arg is not supplied, Defaults arg must ~
830                    have a non-null PATHNAME-HOST."))                    have a non-null PATHNAME-HOST."))
# Line 801  a host-structure or string." Line 835  a host-structure or string."
835            (when (and host new-host (not (eq new-host host)))            (when (and host new-host (not (eq new-host host)))
836              (error "Host in namestring: ~S~@              (error "Host in namestring: ~S~@
837                      does not match explicit host argument: ~S"                      does not match explicit host argument: ~S"
838                     host))                     namestr host))
839            (let ((pn-host (or new-host parse-host)))            (let ((pn-host (or new-host parse-host)))
840              (values (%make-pathname-object              (values (%make-pathname-object
841                       pn-host device directory file type version)                       pn-host device directory file type version)
# Line 819  a host-structure or string." Line 853  a host-structure or string."
853             (values (or logical-host null)))             (values (or logical-host null)))
854    (let ((colon-pos (position #\: namestr :start start :end end)))    (let ((colon-pos (position #\: namestr :start start :end end)))
855      (if colon-pos      (if colon-pos
856          (values (gethash (nstring-upcase (subseq namestr start colon-pos))          (find-logical-host (nstring-upcase (subseq namestr start colon-pos))
857                           *logical-hosts*))                             nil)
858          nil)))          nil)))
859    
   
860  ;;; PARSE-NAMESTRING -- Interface  ;;; PARSE-NAMESTRING -- Interface
861  ;;;  ;;;
862  (defun parse-namestring (thing  (defun parse-namestring (thing
# Line 833  a host-structure or string." Line 866  a host-structure or string."
866     for a physical pathname, returns the printed representation. Host may be     for a physical pathname, returns the printed representation. Host may be
867     a physical host structure or host namestring."     a physical host structure or host namestring."
868    (declare (type path-designator thing)    (declare (type path-designator thing)
869             (type (or null host) host)             (type (or null string host) host)
870             (type pathname defaults)             (type pathname defaults)
871             (type index start)             (type index start)
872             (type (or index null) end)             (type (or index null) end))
873             (type (or t null) junk-allowed)      (etypecase thing
            (values (or null pathname) (or null index)))  
     (typecase thing  
874        (simple-string        (simple-string
875         (%parse-namestring thing host defaults start end junk-allowed))         (%parse-namestring thing host defaults start end junk-allowed))
876        (string        (string
# Line 856  a host-structure or string." Line 887  a host-structure or string."
887           (unless name           (unless name
888             (error "Can't figure out the file associated with stream:~%  ~S"             (error "Can't figure out the file associated with stream:~%  ~S"
889                    thing))                    thing))
890           name))))           (values name nil)))))
891    
892    
893  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
# Line 954  a host-structure or string." Line 985  a host-structure or string."
985               (wild-pathname-p pathname :type)               (wild-pathname-p pathname :type)
986               (wild-pathname-p pathname :version)))               (wild-pathname-p pathname :version)))
987          (:host (frob (%pathname-host pathname)))          (:host (frob (%pathname-host pathname)))
988          (:device (frob (%pathname-host pathname)))          (:device (frob (%pathname-device pathname)))
989          (:directory (some #'frob (%pathname-directory pathname)))          (:directory (some #'frob (%pathname-directory pathname)))
990          (:name (frob (%pathname-name pathname)))          (:name (frob (%pathname-name pathname)))
991          (:type (frob (%pathname-type pathname)))          (:type (frob (%pathname-type pathname)))
# Line 992  a host-structure or string." Line 1023  a host-structure or string."
1023  (defun substitute-into (pattern subs diddle-case)  (defun substitute-into (pattern subs diddle-case)
1024    (declare (type pattern pattern)    (declare (type pattern pattern)
1025             (type list subs)             (type list subs)
1026             (values (or simple-base-string pattern)))             (values (or simple-base-string pattern) list))
1027    (let ((in-wildcard nil)    (let ((in-wildcard nil)
1028          (pieces nil)          (pieces nil)
1029          (strings nil))          (strings nil))
# Line 1146  a host-structure or string." Line 1177  a host-structure or string."
1177  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
1178  ;;; pathanames to produce the result directory component.  If any leaves the  ;;; pathanames to produce the result directory component.  If any leaves the
1179  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
1180  ;;; is always taken from the source directory.  ;;; is taken from the source directory, except if TO is :ABSOLUTE, in which
1181    ;;; case the result will be :ABSOLUTE.
1182  ;;;  ;;;
1183  (defun translate-directories (source from to diddle-case)  (defun translate-directories (source from to diddle-case)
1184    (if (not (and source to from))    (if (not (and source to from))
1185        (or to        (let ((source (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case))
1186            (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))                              source)))
1187            (if (null to)
1188                source
1189                (collect ((res))
1190                  (res (cond ((null source) (first to))
1191                             ((eq (first to) :absolute) :absolute)
1192                             (t (first source))))
1193                  (let ((match (rest source)))
1194                    (dolist (to-part (rest to))
1195                      (cond ((eq to-part :wild)
1196                             (when match
1197                               (res (first match))
1198                               (setf match nil)))
1199                            ((eq to-part :wild-inferiors)
1200                             (when match
1201                               (dolist (src-part match)
1202                                 (res src-part))
1203                               (setf match nil)))
1204                            (t
1205                             (res to-part)))))
1206                  (res))))
1207        (collect ((res))        (collect ((res))
1208          (res (first source))          (res (if (eq (first to) :absolute)
1209                     :absolute
1210                     (first source)))
1211          (let ((subs-left (compute-directory-substitutions (rest source)          (let ((subs-left (compute-directory-substitutions (rest source)
1212                                                            (rest from))))                                                            (rest from))))
1213            (dolist (to-part (rest to))            (dolist (to-part (rest to))
# Line 1164  a host-structure or string." Line 1218  a host-structure or string."
1218                   (when (listp match)                   (when (listp match)
1219                     (error ":WILD-INFERIORS not paired in from and to ~                     (error ":WILD-INFERIORS not paired in from and to ~
1220                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S" from to))
1221                   (maybe-diddle-case match diddle-case)))                   (res (maybe-diddle-case match diddle-case))))
1222                ((member :wild-inferiors)                ((member :wild-inferiors)
1223                 (assert subs-left)                 (assert subs-left)
1224                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
# Line 1178  a host-structure or string." Line 1232  a host-structure or string."
1232                     (new new-subs-left)                     (new new-subs-left)
1233                     (substitute-into to-part subs-left diddle-case)                     (substitute-into to-part subs-left diddle-case)
1234                   (setf subs-left new-subs-left)                   (setf subs-left new-subs-left)
1235                   new))                   (res new)))
1236                (t (res to-part)))))                (t (res to-part)))))
1237          (res))))          (res))))
1238    
# Line 1247  a host-structure or string." Line 1301  a host-structure or string."
1301  ;;;  ;;;
1302  (defvar *search-lists* (make-hash-table :test #'equal))  (defvar *search-lists* (make-hash-table :test #'equal))
1303    
1304    ;;; FIND-SEARCH-LIST -- internal
1305    ;;;
1306    (defun find-search-list (name &optional (flame-not-found-p t))
1307      (let ((search-list (gethash (string-downcase name) *search-lists*)))
1308        (if search-list search-list
1309            (when flame-not-found-p
1310              (error "Search-list ~a not defined." name)))))
1311    
1312  ;;; INTERN-SEARCH-LIST -- internal interface.  ;;; INTERN-SEARCH-LIST -- internal interface.
1313  ;;;  ;;;
1314  ;;; When search-lists are encountered in namestrings, they are converted to  ;;; When search-lists are encountered in namestrings, they are converted to
# Line 1265  a host-structure or string." Line 1327  a host-structure or string."
1327  ;;;  ;;;
1328  ;;; Clear the definition.  Note: we can't remove it from the hash-table  ;;; Clear the definition.  Note: we can't remove it from the hash-table
1329  ;;; because there may be pathnames still refering to it.  So we just clear  ;;; because there may be pathnames still refering to it.  So we just clear
1330  ;;; out the expansions and ste defined to NIL.  ;;; out the expansions and set defined to NIL.
1331  ;;;  ;;;
1332  (defun clear-search-list (name)  (defun clear-search-list (name)
1333    "Clear the current definition for the search-list NAME.  Returns T if such    "Clear the current definition for the search-list NAME.  Returns T if such
# Line 1454  a host-structure or string." Line 1516  a host-structure or string."
1516  (defun find-logical-host (thing &optional (errorp t))  (defun find-logical-host (thing &optional (errorp t))
1517    (etypecase thing    (etypecase thing
1518      (string      (string
1519       (let ((found (gethash (logical-word-or-lose thing)       (let* ((valid-hostname
1520                             *logical-hosts*)))               (catch 'error-bailout
1521                   (handler-bind
1522                       ((namestring-parse-error
1523                         (lambda(c)(declare (ignore c))
1524                           (unless errorp
1525                             (throw 'error-bailout nil)))))
1526                     (logical-word-or-lose thing))))
1527                (found
1528                 (and valid-hostname
1529                      (or (gethash valid-hostname *logical-hosts*)
1530                          (and *autoload-translations*
1531                               (ignore-errors
1532                                (load-logical-pathname-translations
1533                                 valid-hostname))
1534                               (gethash valid-hostname *logical-hosts*))))))
1535         (if (or found (not errorp))         (if (or found (not errorp))
1536             found             found
1537             (error "Logical host not yet defined: ~S" thing))))             (error 'simple-file-error
1538                      :pathname thing
1539                      :format-control "Logical host not yet defined: ~S"
1540                      :format-arguments (list thing)))))
1541      (logical-host thing)))      (logical-host thing)))
1542    
   
1543  ;;; INTERN-LOGICAL-HOST -- Internal  ;;; INTERN-LOGICAL-HOST -- Internal
1544  ;;;  ;;;
1545  ;;;   Given a logical host name or host, return a logical host, creating a new  ;;;   Given a logical host name or host, return a logical host, creating a new
# Line 1557  a host-structure or string." Line 1635  a host-structure or string."
1635        (labels ((expecting (what chunks)        (labels ((expecting (what chunks)
1636                   (unless (and chunks (simple-string-p (caar chunks)))                   (unless (and chunks (simple-string-p (caar chunks)))
1637                     (error 'namestring-parse-error                     (error 'namestring-parse-error
1638                            :complaint "Expecting ~A, got ~:[nothing~;~S~]."                            :complaint "Expecting ~A, got ~:[nothing~;~:*~S~]."
1639                            :arguments (list what (caar chunks))                            :arguments (list what (caar chunks))
1640                            :namestring namestr                            :namestring namestr
1641                            :offset (if chunks (cdar chunks) end)))                            :offset (if chunks (cdar chunks) end)))
# Line 1653  a host-structure or string." Line 1731  a host-structure or string."
1731        (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))        (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1732          (when (eq (%pathname-host res)          (when (eq (%pathname-host res)
1733                    (%pathname-host *logical-pathname-defaults*))                    (%pathname-host *logical-pathname-defaults*))
1734            (error "Logical namestring does not specify a host:~%  ~S"            (error
1735                   pathspec))             'simple-type-error
1736               :format-control "Logical namestring does not specify a host:~%  ~S"
1737               :format-arguments (list pathspec)
1738               :datum pathspec
1739               :expected-type '(satisfies logical-pathname-namestring-p)))
1740          res)))          res)))
1741    
1742    
1743    
1744  ;;;; Logical pathname unparsing:  ;;;; Logical pathname unparsing:
1745    
# Line 1701  a host-structure or string." Line 1784  a host-structure or string."
1784                    (t (error "Invalid keyword: ~S" piece))))))                    (t (error "Invalid keyword: ~S" piece))))))
1785         (apply #'concatenate 'simple-string (strings))))))         (apply #'concatenate 'simple-string (strings))))))
1786    
1787    ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
1788    ;;;
1789    (defun unparse-enough-namestring (pathname defaults)
1790      (let* ((path-dir (pathname-directory pathname))
1791            (def-dir (pathname-directory defaults))
1792            (enough-dir
1793             ;; Go down the directory lists to see what matches.  What's
1794             ;; left is what we want, more or less.
1795             (cond ((and (eq (first path-dir) (first def-dir))
1796                         (eq (first path-dir) :absolute))
1797                    ;; Both paths are :absolute, so find where the common
1798                    ;; parts end and return what's left
1799                    (do* ((p (rest path-dir) (rest p))
1800                          (d (rest def-dir) (rest d)))
1801                         ((or (endp p) (endp d)
1802                              (not (equal (first p) (first d))))
1803                          `(:relative ,@p))))
1804                   (t
1805                    ;; At least one path is :relative, so just return the
1806                    ;; original path.  If the original path is :relative,
1807                    ;; then that's the right one.  If PATH-DIR is
1808                    ;; :absolute, we want to return that except when
1809                    ;; DEF-DIR is :absolute, as handled above. so return
1810                    ;; the original directory.
1811                    path-dir))))
1812        (make-pathname :host (pathname-host pathname)
1813                      :directory enough-dir
1814                      :name (pathname-name pathname)
1815                      :type (pathname-type pathname)
1816                      :version (pathname-version pathname))))
1817    
1818  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1819  ;;;  ;;;
# Line 1744  a host-structure or string." Line 1857  a host-structure or string."
1857             (values list))             (values list))
1858    (logical-host-translations (find-logical-host host)))    (logical-host-translations (find-logical-host host)))
1859    
   
1860  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public
1861  ;;;  ;;;
1862  (defun (setf logical-pathname-translations) (translations host)  (defun (setf logical-pathname-translations) (translations host)
# Line 1774  a host-structure or string." Line 1886  a host-structure or string."
1886     successfully, T is returned, else error."     successfully, T is returned, else error."
1887    (declare (type string host)    (declare (type string host)
1888             (values (member t nil)))             (values (member t nil)))
1889    (unless (find-logical-host host nil)    (let ((*autoload-translations* nil))
1890      (with-open-file (in-str (make-pathname :defaults "library:"      (unless (or (string-equal host "library")
1891                                             :name host                  (find-logical-host host nil))
1892                                             :type "translations"))        (with-open-file (in-str (make-pathname :defaults "library:"
1893        (if *load-verbose*                                               :name (string-downcase host)
1894            (format *error-output*                                               :type "translations"))
1895                    ";; Loading pathname translations from ~A~%"          (if *load-verbose*
1896                    (namestring (truename in-str))))              (format *error-output*
1897        (setf (logical-pathname-translations host) (read in-str)))                      ";; Loading pathname translations from ~A~%"
1898      t))                      (namestring (truename in-str))))
1899            (setf (logical-pathname-translations host) (read in-str)))
1900          t)))
1901    
1902  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
1903  ;;;  ;;;
# Line 1795  a host-structure or string." Line 1908  a host-structure or string."
1908    (typecase pathname    (typecase pathname
1909      (logical-pathname      (logical-pathname
1910       (dolist (x (logical-host-canon-transls (%pathname-host pathname))       (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1911                  (error "No translation for ~S" pathname))                  (error 'simple-file-error
1912                           :pathname pathname
1913                           :format-control "No translation for ~S"
1914                           :format-arguments (list pathname)))
1915         (destructuring-bind (from to) x         (destructuring-bind (from to) x
1916           (when (pathname-match-p pathname from)           (when (pathname-match-p pathname from)
1917             (return (translate-logical-pathname             (return (translate-logical-pathname

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

  ViewVC Help
Powered by ViewVC 1.1.5