/[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.89 by rtoy, Sun Jan 31 16:10:35 2010 UTC revision 1.89.4.1 by rtoy, Thu Feb 25 20:34:50 2010 UTC
# Line 16  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17    
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(pathname pathnamep logical-pathname  (export '(pathname pathnamep logical-pathname
22            parse-namestring merge-pathnames make-pathname            parse-namestring merge-pathnames make-pathname
# Line 33  Line 34 
34  (in-package "LISP")  (in-package "LISP")
35    
36  (defvar *autoload-translations* nil  (defvar *autoload-translations* nil
37    "When non-nil, attempt to load \"library:<host>.translations\" to resolve    _N"When non-nil, attempt to load \"library:<host>.translations\" to resolve
38     an otherwise undefined logical host.")     an otherwise undefined logical host.")
39    
40    
# Line 282  Line 283 
283  ;;; PATH-DESIGNATOR -- internal type  ;;; PATH-DESIGNATOR -- internal type
284  ;;;  ;;;
285  (deftype path-designator ()  (deftype path-designator ()
286    "A path specification, either a string, file-stream or pathname."    _N"A path specification, either a string, file-stream or pathname."
287    ;; This used to be stream, not file-stream, but ANSI CL says a    ;; This used to be stream, not file-stream, but ANSI CL says a
288    ;; pathname designator is a string, a pathname or a stream    ;; pathname designator is a string, a pathname or a stream
289    ;; associated with a file.  In the places we use path-designator, we    ;; associated with a file.  In the places we use path-designator, we
# Line 529  Line 530 
530  ;;; PATHNAME -- Interface  ;;; PATHNAME -- Interface
531  ;;;  ;;;
532  (defun pathname (thing)  (defun pathname (thing)
533    "Convert thing (a pathname, string or stream) into a pathname."    _N"Convert thing (a pathname, string or stream) into a pathname."
534    (declare (type path-designator thing))    (declare (type path-designator thing))
535    (with-pathname (pathname thing)    (with-pathname (pathname thing)
536      pathname))      pathname))
# Line 631  Line 632 
632                          &optional                          &optional
633                          (defaults *default-pathname-defaults*)                          (defaults *default-pathname-defaults*)
634                          (default-version :newest))                          (default-version :newest))
635    "Construct a filled in pathname by completing the unspecified components    _N"Construct a filled in pathname by completing the unspecified components
636     from the defaults."     from the defaults."
637    (declare (type path-designator pathname)    (declare (type path-designator pathname)
638             (type path-designator defaults)             (type path-designator defaults)
# Line 690  Line 691 
691                  (results (maybe-diddle-case (coerce piece 'simple-string)                  (results (maybe-diddle-case (coerce piece 'simple-string)
692                                              diddle-case)))                                              diddle-case)))
693                 (t                 (t
694                  (error "~S is not allowed as a directory component." piece))))                  (error _"~S is not allowed as a directory component." piece))))
695         (results)))         (results)))
696      (simple-string      (simple-string
697       `(:absolute       `(:absolute
# Line 710  Line 711 
711                             (version nil versionp)                             (version nil versionp)
712                             defaults                             defaults
713                             (case :local))                             (case :local))
714    "Makes a new pathname from the component arguments.  Note that host is    _N"Makes a new pathname from the component arguments.  Note that host is
715  a host-structure or string."  a host-structure or string."
716    (declare (type (or null string host component-tokens) host)    (declare (type (or null string host component-tokens) host)
717             (type (or string component-tokens) device)             (type (or string component-tokens) device)
# Line 789  a host-structure or string." Line 790  a host-structure or string."
790                 (let ((unix-directory-separator #\/))                 (let ((unix-directory-separator #\/))
791                   (when (eq host (%pathname-host *default-pathname-defaults*))                   (when (eq host (%pathname-host *default-pathname-defaults*))
792                     (when (find unix-directory-separator name)                     (when (find unix-directory-separator name)
793                       (warn "Silly argument for a unix ~A: ~S"                       (warn _"Silly argument for a unix ~A: ~S"
794                             name-or-type name)))))))                             name-or-type name)))))))
795        (check-component-validity name :pathname-name)        (check-component-validity name :pathname-name)
796        (check-component-validity type :pathname-type)        (check-component-validity type :pathname-type)
# Line 802  a host-structure or string." Line 803  a host-structure or string."
803                       (and (string= name ".")                       (and (string= name ".")
804                            (not type))))                            (not type))))
805          ;;          ;;
806          (warn "Silly argument for a unix PATHNAME-NAME: ~S" name)))          (warn _"Silly argument for a unix PATHNAME-NAME: ~S" name)))
807    
808      ;; More sanity checking      ;; More sanity checking
809      (when dir      (when dir
# Line 835  a host-structure or string." Line 836  a host-structure or string."
836                 :pathname (make-pathname :directory (remove-if #'(lambda (x)                 :pathname (make-pathname :directory (remove-if #'(lambda (x)
837                                                                    (member x '(:up :back)))                                                                    (member x '(:up :back)))
838                                                                dir))                                                                dir))
839                 :format-control "Illegal pathname: ~                 :format-control _"Illegal pathname: ~
840                                  Directory with ~S immediately followed by ~S"                                  Directory with ~S immediately followed by ~S"
841                 :format-arguments (list (first d) (second d)))))                 :format-arguments (list (first d) (second d)))))
842    
# Line 863  a host-structure or string." Line 864  a host-structure or string."
864  ;;; PATHNAME-HOST -- Interface  ;;; PATHNAME-HOST -- Interface
865  ;;;  ;;;
866  (defun pathname-host (pathname &key (case :local))  (defun pathname-host (pathname &key (case :local))
867    "Accessor for the pathname's host."    _N"Accessor for the pathname's host."
868    (declare (type path-designator pathname)    (declare (type path-designator pathname)
869             (type (member :local :common) case)             (type (member :local :common) case)
870             (values (or string null))             (values (or string null))
# Line 873  a host-structure or string." Line 874  a host-structure or string."
874  ;;; PATHNAME-DEVICE -- Interface  ;;; PATHNAME-DEVICE -- Interface
875  ;;;  ;;;
876  (defun pathname-device (pathname &key (case :local))  (defun pathname-device (pathname &key (case :local))
877    "Accessor for pathname's device."    _N"Accessor for pathname's device."
878    (declare (type path-designator pathname)    (declare (type path-designator pathname)
879             (type (member :local :common) case))             (type (member :local :common) case))
880    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 886  a host-structure or string." Line 887  a host-structure or string."
887  ;;; PATHNAME-DIRECTORY -- Interface  ;;; PATHNAME-DIRECTORY -- Interface
888  ;;;  ;;;
889  (defun pathname-directory (pathname &key (case :local))  (defun pathname-directory (pathname &key (case :local))
890    "Accessor for the pathname's directory list."    _N"Accessor for the pathname's directory list."
891    (declare (type path-designator pathname)    (declare (type path-designator pathname)
892             (type (member :local :common) case))             (type (member :local :common) case))
893    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 907  a host-structure or string." Line 908  a host-structure or string."
908  ;;; PATHNAME-NAME -- Interface  ;;; PATHNAME-NAME -- Interface
909  ;;;  ;;;
910  (defun pathname-name (pathname &key (case :local))  (defun pathname-name (pathname &key (case :local))
911    "Accessor for the pathname's name."    _N"Accessor for the pathname's name."
912    (declare (type path-designator pathname)    (declare (type path-designator pathname)
913             (type (member :local :common) case))             (type (member :local :common) case))
914    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 920  a host-structure or string." Line 921  a host-structure or string."
921  ;;; PATHNAME-TYPE  ;;; PATHNAME-TYPE
922  ;;;  ;;;
923  (defun pathname-type (pathname &key (case :local))  (defun pathname-type (pathname &key (case :local))
924    "Accessor for the pathname's name."    _N"Accessor for the pathname's name."
925    (declare (type path-designator pathname)    (declare (type path-designator pathname)
926             (type (member :local :common) case))             (type (member :local :common) case))
927    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 933  a host-structure or string." Line 934  a host-structure or string."
934  ;;; PATHNAME-VERSION  ;;; PATHNAME-VERSION
935  ;;;  ;;;
936  (defun pathname-version (pathname)  (defun pathname-version (pathname)
937    "Accessor for the pathname's version."    _N"Accessor for the pathname's version."
938    (declare (type path-designator pathname))    (declare (type path-designator pathname))
939    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
940      (%pathname-version pathname)))      (%pathname-version pathname)))
# Line 944  a host-structure or string." Line 945  a host-structure or string."
945  ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal  ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal
946  ;;;  ;;;
947  (defun %print-namestring-parse-error (condition stream)  (defun %print-namestring-parse-error (condition stream)
948    (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"    (format stream _"Parse error in namestring: ~?~%  ~A~%  ~V@T^"
949            (namestring-parse-error-complaint condition)            (namestring-parse-error-complaint condition)
950            (namestring-parse-error-arguments condition)            (namestring-parse-error-arguments condition)
951            (namestring-parse-error-namestring condition)            (namestring-parse-error-namestring condition)
# Line 985  a host-structure or string." Line 986  a host-structure or string."
986                               (extract-logical-host-prefix namestr start end)                               (extract-logical-host-prefix namestr start end)
987                               default-host)))                               default-host)))
988          (unless parse-host          (unless parse-host
989            (error "When Host arg is not supplied, Defaults arg must ~            (error _"When Host arg is not supplied, Defaults arg must ~
990                    have a non-null PATHNAME-HOST."))                    have a non-null PATHNAME-HOST."))
991    
992          (multiple-value-bind          (multiple-value-bind
993              (new-host device directory file type version)              (new-host device directory file type version)
994              (funcall (host-parse parse-host) namestr start end)              (funcall (host-parse parse-host) namestr start end)
995            (when (and host new-host (not (eq new-host host)))            (when (and host new-host (not (eq new-host host)))
996              (error "Host in namestring: ~S~@              (error _"Host in namestring: ~S~@
997                      does not match explicit host argument: ~S"                      does not match explicit host argument: ~S"
998                     namestr host))                     namestr host))
999            (let ((pn-host (or new-host parse-host)))            (let ((pn-host (or new-host parse-host)))
# Line 1021  a host-structure or string." Line 1022  a host-structure or string."
1022  (defun parse-namestring (thing  (defun parse-namestring (thing
1023                           &optional host (defaults *default-pathname-defaults*)                           &optional host (defaults *default-pathname-defaults*)
1024                           &key (start 0) end junk-allowed)                           &key (start 0) end junk-allowed)
1025    "Converts pathname, a pathname designator, into a pathname structure,    _N"Converts pathname, a pathname designator, into a pathname structure,
1026     for a physical pathname, returns the printed representation. Host may be     for a physical pathname, returns the printed representation. Host may be
1027     a physical host structure or host namestring."     a physical host structure or host namestring."
1028    (declare (type path-designator thing)    (declare (type path-designator thing)
# Line 1075  a host-structure or string." Line 1076  a host-structure or string."
1076                   ;; but leaves its interpretation                   ;; but leaves its interpretation
1077                   ;; implementation-defined. Our interpretation                   ;; implementation-defined. Our interpretation
1078                   ;; is that it's unsupported.:-|                   ;; is that it's unsupported.:-|
1079                   (error "A LIST representing a pathname host is not ~                   (error _"A LIST representing a pathname host is not ~
1080                                supported in this implementation:~%  ~S"                                supported in this implementation:~%  ~S"
1081                          host))                          host))
1082                  (host                  (host
# Line 1091  a host-structure or string." Line 1092  a host-structure or string."
1092          (pathname          (pathname
1093           (let ((host (if host host (%pathname-host defaults))))           (let ((host (if host host (%pathname-host defaults))))
1094             (unless (eq host (%pathname-host thing))             (unless (eq host (%pathname-host thing))
1095               (error "Hosts do not match: ~S and ~S."               (error _"Hosts do not match: ~S and ~S."
1096                      host (%pathname-host thing))))                      host (%pathname-host thing))))
1097           (values thing start))           (values thing start))
1098          (stream          (stream
# Line 1100  a host-structure or string." Line 1101  a host-structure or string."
1101               (error 'simple-type-error               (error 'simple-type-error
1102                      :datum thing                      :datum thing
1103                      :expected-type 'pathname                      :expected-type 'pathname
1104                      :format-control "Can't figure out the file associated with stream:~%  ~S"                      :format-control _"Can't figure out the file associated with stream:~%  ~S"
1105                      :format-arguments (list thing)))                      :format-arguments (list thing)))
1106             (values name nil)))))))             (values name nil)))))))
1107    
# Line 1108  a host-structure or string." Line 1109  a host-structure or string."
1109  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
1110  ;;;  ;;;
1111  (defun namestring (pathname)  (defun namestring (pathname)
1112    "Construct the full (name)string form of the pathname."    _N"Construct the full (name)string form of the pathname."
1113    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1114             (values (or null simple-base-string)))             (values (or null simple-base-string)))
1115    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1121  a host-structure or string." Line 1122  a host-structure or string."
1122                        *unix-host*)                        *unix-host*)
1123                        ))                        ))
1124          (unless host          (unless host
1125            (error "Cannot determine the namestring for pathnames with no ~            (error _"Cannot determine the namestring for pathnames with no ~
1126                    host:~%  ~S" pathname))                    host:~%  ~S" pathname))
1127          (funcall (host-unparse host) pathname)))))          (funcall (host-unparse host) pathname)))))
1128    
# Line 1129  a host-structure or string." Line 1130  a host-structure or string."
1130  ;;; HOST-NAMESTRING -- Interface  ;;; HOST-NAMESTRING -- Interface
1131  ;;;  ;;;
1132  (defun host-namestring (pathname)  (defun host-namestring (pathname)
1133    "Returns a string representation of the name of the host in the pathname."    _N"Returns a string representation of the name of the host in the pathname."
1134    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1135             (values (or null simple-base-string)))             (values (or null simple-base-string)))
1136    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1137  a host-structure or string." Line 1138  a host-structure or string."
1138        (if host        (if host
1139            (funcall (host-unparse-host host) pathname)            (funcall (host-unparse-host host) pathname)
1140            (error            (error
1141             "Cannot determine the namestring for pathnames with no host:~%  ~S"             _"Cannot determine the namestring for pathnames with no host:~%  ~S"
1142             pathname)))))             pathname)))))
1143    
1144  ;;; DIRECTORY-NAMESTRING -- Interface  ;;; DIRECTORY-NAMESTRING -- Interface
1145  ;;;  ;;;
1146  (defun directory-namestring (pathname)  (defun directory-namestring (pathname)
1147    "Returns a string representation of the directories used in the pathname."    _N"Returns a string representation of the directories used in the pathname."
1148    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1149             (values (or null simple-base-string)))             (values (or null simple-base-string)))
1150    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1151  a host-structure or string." Line 1152  a host-structure or string."
1152        (if host        (if host
1153            (funcall (host-unparse-directory host) pathname)            (funcall (host-unparse-directory host) pathname)
1154            (error            (error
1155             "Cannot determine the namestring for pathnames with no host:~%  ~S"             _"Cannot determine the namestring for pathnames with no host:~%  ~S"
1156             pathname)))))             pathname)))))
1157    
1158  ;;; FILE-NAMESTRING -- Interface  ;;; FILE-NAMESTRING -- Interface
1159  ;;;  ;;;
1160  (defun file-namestring (pathname)  (defun file-namestring (pathname)
1161    "Returns a string representation of the name used in the pathname."    _N"Returns a string representation of the name used in the pathname."
1162    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1163             (values (or null simple-base-string)))             (values (or null simple-base-string)))
1164    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1165  a host-structure or string." Line 1166  a host-structure or string."
1166        (if host        (if host
1167            (funcall (host-unparse-file host) pathname)            (funcall (host-unparse-file host) pathname)
1168            (error            (error
1169             "Cannot determine the namestring for pathnames with no host:~%  ~S"             _"Cannot determine the namestring for pathnames with no host:~%  ~S"
1170             pathname)))))             pathname)))))
1171    
1172  ;;; ENOUGH-NAMESTRING -- Interface  ;;; ENOUGH-NAMESTRING -- Interface
1173  ;;;  ;;;
1174  (defun enough-namestring (pathname  (defun enough-namestring (pathname
1175                            &optional (defaults *default-pathname-defaults*))                            &optional (defaults *default-pathname-defaults*))
1176    "Returns an abbreviated pathname sufficent to identify the pathname relative    _N"Returns an abbreviated pathname sufficent to identify the pathname relative
1177     to the defaults."     to the defaults."
1178    (declare (type path-designator pathname defaults))    (declare (type path-designator pathname defaults))
1179    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1186  a host-structure or string." Line 1187  a host-structure or string."
1187                  (funcall (host-unparse-enough host) pathname defaults)                  (funcall (host-unparse-enough host) pathname defaults)
1188                  (namestring pathname)))                  (namestring pathname)))
1189            (error            (error
1190             "Cannot determine the namestring for pathnames with no host:~%  ~S"             _"Cannot determine the namestring for pathnames with no host:~%  ~S"
1191             pathname)))))             pathname)))))
1192    
1193    
# Line 1195  a host-structure or string." Line 1196  a host-structure or string."
1196  ;;; WILD-PATHNAME-P -- Interface  ;;; WILD-PATHNAME-P -- Interface
1197  ;;;  ;;;
1198  (defun wild-pathname-p (pathname &optional field-key)  (defun wild-pathname-p (pathname &optional field-key)
1199    "Predicate for determining whether pathname contains any wildcards."    _N"Predicate for determining whether pathname contains any wildcards."
1200    (declare (type path-designator pathname)    (declare (type path-designator pathname)
1201             (type (member nil :host :device :directory :name :type :version)             (type (member nil :host :device :directory :name :type :version)
1202                   field-key))                   field-key))
# Line 1221  a host-structure or string." Line 1222  a host-structure or string."
1222  ;;; PATHNAME-MATCH-P -- Interface  ;;; PATHNAME-MATCH-P -- Interface
1223  ;;;  ;;;
1224  (defun pathname-match-p (in-pathname in-wildname)  (defun pathname-match-p (in-pathname in-wildname)
1225    "Pathname matches the wildname template?"    _N"Pathname matches the wildname template?"
1226    (declare (type path-designator in-pathname)    (declare (type path-designator in-pathname)
1227             ;; Not path-designator because a file-stream can't have a             ;; Not path-designator because a file-stream can't have a
1228             ;; wild pathname.             ;; wild pathname.
# Line 1264  a host-structure or string." Line 1265  a host-structure or string."
1265              (t              (t
1266               (setf in-wildcard t)               (setf in-wildcard t)
1267               (unless subs               (unless subs
1268                 (error "Not enough wildcards in FROM pattern to match ~                 (error _"Not enough wildcards in FROM pattern to match ~
1269                         TO pattern:~%  ~S"                         TO pattern:~%  ~S"
1270                        pattern))                        pattern))
1271               (let ((sub (pop subs)))               (let ((sub (pop subs)))
# Line 1279  a host-structure or string." Line 1280  a host-structure or string."
1280                   (simple-string                   (simple-string
1281                    (push sub strings))                    (push sub strings))
1282                   (t                   (t
1283                    (error "Can't substitute this into the middle of a word:~                    (error _"Can't substitute this into the middle of a word:~
1284                            ~%  ~S"                            ~%  ~S"
1285                           sub)))))))                           sub)))))))
1286    
# Line 1300  a host-structure or string." Line 1301  a host-structure or string."
1301  ;;;    Called when we can't see how source and from matched.  ;;;    Called when we can't see how source and from matched.
1302  ;;;  ;;;
1303  (defun didnt-match-error (source from)  (defun didnt-match-error (source from)
1304    (error "Pathname components from Source and From args to TRANSLATE-PATHNAME~@    (error _"Pathname components from Source and From args to TRANSLATE-PATHNAME~@
1305            did not match:~%  ~S ~S"            did not match:~%  ~S ~S"
1306           source from))           source from))
1307    
# Line 1442  a host-structure or string." Line 1443  a host-structure or string."
1443                 (assert subs-left)                 (assert subs-left)
1444                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
1445                   (when (listp match)                   (when (listp match)
1446                     (error ":WILD-INFERIORS not paired in from and to ~                     (error _":WILD-INFERIORS not paired in from and to ~
1447                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S" from to))
1448                   (res (maybe-diddle-case match diddle-case))))                   (res (maybe-diddle-case match diddle-case))))
1449                ((member :wild-inferiors)                ((member :wild-inferiors)
1450                 (assert subs-left)                 (assert subs-left)
1451                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
1452                   (unless (listp match)                   (unless (listp match)
1453                     (error ":WILD-INFERIORS not paired in from and to ~                     (error _":WILD-INFERIORS not paired in from and to ~
1454                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S" from to))
1455                   (dolist (x match)                   (dolist (x match)
1456                     (res (maybe-diddle-case x diddle-case)))))                     (res (maybe-diddle-case x diddle-case)))))
# Line 1466  a host-structure or string." Line 1467  a host-structure or string."
1467  ;;; TRANSLATE-PATHNAME -- Interface  ;;; TRANSLATE-PATHNAME -- Interface
1468  ;;;  ;;;
1469  (defun translate-pathname (source from-wildname to-wildname &key)  (defun translate-pathname (source from-wildname to-wildname &key)
1470    "Use the source pathname to translate the from-wildname's wild and    _N"Use the source pathname to translate the from-wildname's wild and
1471     unspecified elements into a completed to-pathname based on the to-wildname."     unspecified elements into a completed to-pathname based on the to-wildname."
1472    (declare (type path-designator source from-wildname to-wildname))    (declare (type path-designator source from-wildname to-wildname))
1473    (with-pathname (source source)    (with-pathname (source source)
# Line 1486  a host-structure or string." Line 1487  a host-structure or string."
1487                                               (,field to)                                               (,field to)
1488                                               diddle-case)))                                               diddle-case)))
1489                              (if (eq result :error)                              (if (eq result :error)
1490                                  (error "~S doesn't match ~S" source from)                                  (error _"~S doesn't match ~S" source from)
1491                                  result))))                                  result))))
1492                (%make-pathname-object                (%make-pathname-object
1493                 (or to-host source-host)                 (or to-host source-host)
# Line 1535  a host-structure or string." Line 1536  a host-structure or string."
1536    (let ((search-list (gethash (string-downcase name) *search-lists*)))    (let ((search-list (gethash (string-downcase name) *search-lists*)))
1537      (if search-list search-list      (if search-list search-list
1538          (when flame-not-found-p          (when flame-not-found-p
1539            (error "Search-list ~a not defined." name)))))            (error _"Search-list ~a not defined." name)))))
1540    
1541  ;;; INTERN-SEARCH-LIST -- internal interface.  ;;; INTERN-SEARCH-LIST -- internal interface.
1542  ;;;  ;;;
# Line 1558  a host-structure or string." Line 1559  a host-structure or string."
1559  ;;; out the expansions and set defined to NIL.  ;;; out the expansions and set defined to NIL.
1560  ;;;  ;;;
1561  (defun clear-search-list (name)  (defun clear-search-list (name)
1562    "Clear the current definition for the search-list NAME.  Returns T if such    _N"Clear the current definition for the search-list NAME.  Returns T if such
1563     a definition existed, and NIL if not."     a definition existed, and NIL if not."
1564    (let* ((name (string-downcase name))    (let* ((name (string-downcase name))
1565           (search-list (gethash name *search-lists*)))           (search-list (gethash name *search-lists*)))
# Line 1573  a host-structure or string." Line 1574  a host-structure or string."
1574  ;;; just mark them as being undefined.  ;;; just mark them as being undefined.
1575  ;;;  ;;;
1576  (defun clear-all-search-lists ()  (defun clear-all-search-lists ()
1577    "Clear the definition for all search-lists.  Only use this if you know    _N"Clear the definition for all search-lists.  Only use this if you know
1578     what you are doing."     what you are doing."
1579    (maphash #'(lambda (name search-list)    (maphash #'(lambda (name search-list)
1580                 (declare (ignore name))                 (declare (ignore name))
# Line 1595  a host-structure or string." Line 1596  a host-structure or string."
1596        (cond ((search-list-p search-list)        (cond ((search-list-p search-list)
1597               search-list)               search-list)
1598              (flame-if-none              (flame-if-none
1599               (error "~S doesn't start with a search-list." pathname))               (error _"~S doesn't start with a search-list." pathname))
1600              (t              (t
1601               nil)))))               nil)))))
1602    
# Line 1605  a host-structure or string." Line 1606  a host-structure or string."
1606  ;;; bunch of pathnames.  ;;; bunch of pathnames.
1607  ;;;  ;;;
1608  (defun search-list (pathname)  (defun search-list (pathname)
1609    "Return the expansions for the search-list starting PATHNAME.  If PATHNAME    _N"Return the expansions for the search-list starting PATHNAME.  If PATHNAME
1610     does not start with a search-list, then an error is signaled.  If     does not start with a search-list, then an error is signaled.  If
1611     the search-list has not been defined yet, then an error is signaled.     the search-list has not been defined yet, then an error is signaled.
1612     The expansion for a search-list can be set with SETF."     The expansion for a search-list can be set with SETF."
# Line 1617  a host-structure or string." Line 1618  a host-structure or string."
1618                        (make-pathname :host host                        (make-pathname :host host
1619                                       :directory (cons :absolute directory)))                                       :directory (cons :absolute directory)))
1620                    (search-list-expansions search-list))                    (search-list-expansions search-list))
1621            (error "Search list ~S has not been defined yet." pathname)))))            (error _"Search list ~S has not been defined yet." pathname)))))
1622    
1623  ;;; SEARCH-LIST-DEFINED-P -- public.  ;;; SEARCH-LIST-DEFINED-P -- public.
1624  ;;;  ;;;
1625  (defun search-list-defined-p (pathname)  (defun search-list-defined-p (pathname)
1626    "Returns T if the search-list starting PATHNAME is currently defined, and    _N"Returns T if the search-list starting PATHNAME is currently defined, and
1627     NIL otherwise.  An error is signaled if PATHNAME does not start with a     NIL otherwise.  An error is signaled if PATHNAME does not start with a
1628     search-list."     search-list."
1629    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
# Line 1639  a host-structure or string." Line 1640  a host-structure or string."
1640      (labels      (labels
1641          ((check (target-list path)          ((check (target-list path)
1642             (when (eq search-list target-list)             (when (eq search-list target-list)
1643               (error "That would result in a circularity:~%  ~               (error _"That would result in a circularity:~%  ~
1644                       ~A~{ -> ~A~} -> ~A"                       ~A~{ -> ~A~} -> ~A"
1645                      (search-list-name search-list)                      (search-list-name search-list)
1646                      (reverse path)                      (reverse path)
# Line 1653  a host-structure or string." Line 1654  a host-structure or string."
1654               (when (or (pathname-name pathname)               (when (or (pathname-name pathname)
1655                         (pathname-type pathname)                         (pathname-type pathname)
1656                         (pathname-version pathname))                         (pathname-version pathname))
1657                 (error "Search-lists cannot expand into pathnames that have ~                 (error _"Search-lists cannot expand into pathnames that have ~
1658                         a name, type, or ~%version specified:~%  ~S"                         a name, type, or ~%version specified:~%  ~S"
1659                        pathname))                        pathname))
1660               (let ((directory (pathname-directory pathname)))               (let ((directory (pathname-directory pathname)))
# Line 1676  a host-structure or string." Line 1677  a host-structure or string."
1677  ;;; ENUMERATE-SEARCH-LIST -- public.  ;;; ENUMERATE-SEARCH-LIST -- public.
1678  ;;;  ;;;
1679  (defmacro enumerate-search-list ((var pathname &optional result) &body body)  (defmacro enumerate-search-list ((var pathname &optional result) &body body)
1680    "Execute BODY with VAR bound to each successive possible expansion for    _N"Execute BODY with VAR bound to each successive possible expansion for
1681     PATHNAME and then return RESULT.  Note: if PATHNAME does not contain a     PATHNAME and then return RESULT.  Note: if PATHNAME does not contain a
1682     search-list, then BODY is executed exactly once.  Everything is wrapped     search-list, then BODY is executed exactly once.  Everything is wrapped
1683     in a block named NIL, so RETURN can be used to terminate early.  Note:     in a block named NIL, so RETURN can be used to terminate early.  Note:
# Line 1697  a host-structure or string." Line 1698  a host-structure or string."
1698       ((not search-list)       ((not search-list)
1699        (funcall function pathname))        (funcall function pathname))
1700       ((not (search-list-defined search-list))       ((not (search-list-defined search-list))
1701        (error "Undefined search list: ~A"        (error _"Undefined search list: ~A"
1702               (search-list-name search-list)))               (search-list-name search-list)))
1703       (t       (t
1704        (let ((tail (cddr (pathname-directory pathname))))        (let ((tail (cddr (pathname-directory pathname))))
# Line 1729  a host-structure or string." Line 1730  a host-structure or string."
1730        (let ((ch (schar word i)))        (let ((ch (schar word i)))
1731          (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))          (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1732            (error 'namestring-parse-error            (error 'namestring-parse-error
1733                   :complaint "Logical namestring character ~                   :complaint _"Logical namestring character ~
1734                               is not alphanumeric or hyphen:~%  ~S"                               is not alphanumeric or hyphen:~%  ~S"
1735                   :arguments (list ch)                   :arguments (list ch)
1736                   :namestring word :offset i))))                   :namestring word :offset i))))
# Line 1764  a host-structure or string." Line 1765  a host-structure or string."
1765             found             found
1766             (error 'simple-file-error             (error 'simple-file-error
1767                    :pathname thing                    :pathname thing
1768                    :format-control "Logical host not yet defined: ~S"                    :format-control _"Logical host not yet defined: ~S"
1769                    :format-arguments (list thing)))))                    :format-arguments (list thing)))))
1770      (logical-host thing)))      (logical-host thing)))
1771    
# Line 1800  a host-structure or string." Line 1801  a host-structure or string."
1801              (if (= pos last-pos)              (if (= pos last-pos)
1802                  (when (pattern)                  (when (pattern)
1803                    (error 'namestring-parse-error                    (error 'namestring-parse-error
1804                           :complaint "Double asterisk inside of logical ~                           :complaint _"Double asterisk inside of logical ~
1805                                       word: ~S"                                       word: ~S"
1806                           :arguments (list chunk)                           :arguments (list chunk)
1807                           :namestring namestring                           :namestring namestring
# Line 1839  a host-structure or string." Line 1840  a host-structure or string."
1840            (setq prev (1+ i))            (setq prev (1+ i))
1841            (unless (member ch '(#\; #\: #\.))            (unless (member ch '(#\; #\: #\.))
1842              (error 'namestring-parse-error              (error 'namestring-parse-error
1843                     :complaint "Illegal character for logical pathname:~%  ~S"                     :complaint _"Illegal character for logical pathname:~%  ~S"
1844                     :arguments (list ch)                     :arguments (list ch)
1845                     :namestring namestr                     :namestring namestr
1846                     :offset i))                     :offset i))
# Line 1863  a host-structure or string." Line 1864  a host-structure or string."
1864        (labels ((expecting (what chunks)        (labels ((expecting (what chunks)
1865                   (unless (and chunks (simple-string-p (caar chunks)))                   (unless (and chunks (simple-string-p (caar chunks)))
1866                     (error 'namestring-parse-error                     (error 'namestring-parse-error
1867                            :complaint "Expecting ~A, got ~:[nothing~;~:*~S~]."                            :complaint _"Expecting ~A, got ~:[nothing~;~:*~S~]."
1868                            :arguments (list what (caar chunks))                            :arguments (list what (caar chunks))
1869                            :namestring namestr                            :namestring namestr
1870                            :offset (if chunks (cdar chunks) end)))                            :offset (if chunks (cdar chunks) end)))
# Line 1872  a host-structure or string." Line 1873  a host-structure or string."
1873                   (case (caadr chunks)                   (case (caadr chunks)
1874                     (#\:                     (#\:
1875                      (setq host                      (setq host
1876                            (find-logical-host (expecting "a host name" chunks)))                            (find-logical-host (expecting _"a host name" chunks)))
1877                      (parse-relative (cddr chunks)))                      (parse-relative (cddr chunks)))
1878                     (t                     (t
1879                      (parse-relative chunks))))                      (parse-relative chunks))))
# Line 1888  a host-structure or string." Line 1889  a host-structure or string."
1889                   (case (caadr chunks)                   (case (caadr chunks)
1890                     (#\;                     (#\;
1891                      (directory                      (directory
1892                       (let ((res (expecting "a directory name" chunks)))                       (let ((res (expecting _"a directory name" chunks)))
1893                         (cond ((string= res "..") :up)                         (cond ((string= res "..") :up)
1894                               ((string= res "**") :wild-inferiors)                               ((string= res "**") :wild-inferiors)
1895                               (t                               (t
# Line 1898  a host-structure or string." Line 1899  a host-structure or string."
1899                      (parse-name chunks))))                      (parse-name chunks))))
1900                 (parse-name (chunks)                 (parse-name (chunks)
1901                   (when chunks                   (when chunks
1902                     (expecting "a file name" chunks)                     (expecting _"a file name" chunks)
1903                     (setq name (maybe-make-logical-pattern namestr chunks))                     (setq name (maybe-make-logical-pattern namestr chunks))
1904                     (expecting-dot (cdr chunks))))                     (expecting-dot (cdr chunks))))
1905                 (expecting-dot (chunks)                 (expecting-dot (chunks)
1906                   (when chunks                   (when chunks
1907                     (unless (eql (caar chunks) #\.)                     (unless (eql (caar chunks) #\.)
1908                       (error 'namestring-parse-error                       (error 'namestring-parse-error
1909                              :complaint "Expecting a dot, got ~S."                              :complaint _"Expecting a dot, got ~S."
1910                              :arguments (list (caar chunks))                              :arguments (list (caar chunks))
1911                              :namestring namestr                              :namestring namestr
1912                              :offset (cdar chunks)))                              :offset (cdar chunks)))
# Line 1913  a host-structure or string." Line 1914  a host-structure or string."
1914                         (parse-version (cdr chunks))                         (parse-version (cdr chunks))
1915                         (parse-type (cdr chunks)))))                         (parse-type (cdr chunks)))))
1916                 (parse-type (chunks)                 (parse-type (chunks)
1917                   (expecting "a file type" chunks)                   (expecting _"a file type" chunks)
1918                   (setq type (maybe-make-logical-pattern namestr chunks))                   (setq type (maybe-make-logical-pattern namestr chunks))
1919                   (expecting-dot (cdr chunks)))                   (expecting-dot (cdr chunks)))
1920                 (parse-version (chunks)                 (parse-version (chunks)
1921                   (let ((str (expecting "a positive integer, * or NEWEST"                   (let ((str (expecting _"a positive integer, * or NEWEST"
1922                                         chunks)))                                         chunks)))
1923                     (cond                     (cond
1924                      ((string= str "*") (setq version :wild))                      ((string= str "*") (setq version :wild))
# Line 1928  a host-structure or string." Line 1929  a host-structure or string."
1929                           (parse-integer str :junk-allowed t)                           (parse-integer str :junk-allowed t)
1930                         (unless (and res (plusp res))                         (unless (and res (plusp res))
1931                           (error 'namestring-parse-error                           (error 'namestring-parse-error
1932                                  :complaint "Expected a positive integer, ~                                  :complaint _"Expected a positive integer, ~
1933                                              got ~S"                                              got ~S"
1934                                  :arguments (list str)                                  :arguments (list str)
1935                                  :namestring namestr                                  :namestring namestr
# Line 1936  a host-structure or string." Line 1937  a host-structure or string."
1937                         (setq version res)))))                         (setq version res)))))
1938                   (when (cdr chunks)                   (when (cdr chunks)
1939                     (error 'namestring-parse-error                     (error 'namestring-parse-error
1940                            :complaint "Extra stuff after end of file name."                            :complaint _"Extra stuff after end of file name."
1941                            :namestring namestr                            :namestring namestr
1942                            :offset (cdadr chunks)))))                            :offset (cdadr chunks)))))
1943          (parse-host (logical-chunkify namestr start end)))          (parse-host (logical-chunkify namestr start end)))
# Line 1962  a host-structure or string." Line 1963  a host-structure or string."
1963  ;;; LOGICAL-PATHNAME -- Public  ;;; LOGICAL-PATHNAME -- Public
1964  ;;;  ;;;
1965  (defun logical-pathname (pathspec)  (defun logical-pathname (pathspec)
1966    "Converts the pathspec argument to a logical-pathname and returns it."    _N"Converts the pathspec argument to a logical-pathname and returns it."
1967    (declare (type (or logical-pathname string stream) pathspec)    (declare (type (or logical-pathname string stream) pathspec)
1968             (values logical-pathname))             (values logical-pathname))
1969    (if (typep pathspec 'logical-pathname)    (if (typep pathspec 'logical-pathname)
# Line 1972  a host-structure or string." Line 1973  a host-structure or string."
1973          (unless logical-p          (unless logical-p
1974            (error            (error
1975             'simple-type-error             'simple-type-error
1976             :format-control "Logical namestring does not specify a host:~%  ~S"             :format-control _"Logical namestring does not specify a host:~%  ~S"
1977             :format-arguments (list pathspec)             :format-arguments (list pathspec)
1978             :datum pathspec             :datum pathspec
1979             :expected-type '(satisfies logical-pathname-namestring-p)))             :expected-type '(satisfies logical-pathname-namestring-p)))
# Line 2005  a host-structure or string." Line 2006  a host-structure or string."
2006                  ((eq dir :wild-inferiors)                  ((eq dir :wild-inferiors)
2007                   (pieces "**;"))                   (pieces "**;"))
2008                  (t                  (t
2009                   (error "Invalid directory component: ~S" dir))))))                   (error _"Invalid directory component: ~S" dir))))))
2010      (apply #'concatenate 'simple-string (pieces))))      (apply #'concatenate 'simple-string (pieces))))
2011    
2012    
# Line 2024  a host-structure or string." Line 2025  a host-structure or string."
2025                     (strings "**"))                     (strings "**"))
2026                    ((eq piece :multi-char-wild)                    ((eq piece :multi-char-wild)
2027                     (strings "*"))                     (strings "*"))
2028                    (t (error "Invalid keyword: ~S" piece))))))                    (t (error _"Invalid keyword: ~S" piece))))))
2029         (apply #'concatenate 'simple-string (strings))))))         (apply #'concatenate 'simple-string (strings))))))
2030    
2031  ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal  ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
# Line 2087  a host-structure or string." Line 2088  a host-structure or string."
2088    (collect ((res))    (collect ((res))
2089      (dolist (tr transl-list)      (dolist (tr transl-list)
2090        (unless (and (consp tr) (= (length tr) 2))        (unless (and (consp tr) (= (length tr) 2))
2091          (error "Logical pathname translation is not a two-list:~%  ~S"          (error _"Logical pathname translation is not a two-list:~%  ~S"
2092                 tr))                 tr))
2093        (let ((from (first tr)))        (let ((from (first tr)))
2094          (res (list (if (typep from 'logical-pathname)          (res (list (if (typep from 'logical-pathname)
# Line 2100  a host-structure or string." Line 2101  a host-structure or string."
2101  ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public  ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public
2102  ;;;  ;;;
2103  (defun logical-pathname-translations (host)  (defun logical-pathname-translations (host)
2104    "Return the (logical) host object argument's list of translations."    _N"Return the (logical) host object argument's list of translations."
2105    (declare (type (or string logical-host) host)    (declare (type (or string logical-host) host)
2106             (values list))             (values list))
2107    (logical-host-translations (find-logical-host host)))    (logical-host-translations (find-logical-host host)))
# Line 2108  a host-structure or string." Line 2109  a host-structure or string."
2109  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public  ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public
2110  ;;;  ;;;
2111  (defun (setf logical-pathname-translations) (translations host)  (defun (setf logical-pathname-translations) (translations host)
2112    "Set the translations list for the logical host argument.    _N"Set the translations list for the logical host argument.
2113     Return translations."     Return translations."
2114    (declare (type (or string logical-host) host)    (declare (type (or string logical-host) host)
2115             (type list translations)             (type list translations)
# Line 2117  a host-structure or string." Line 2118  a host-structure or string."
2118    (let ((maybe-search-list-host (concatenate 'string host ":")))    (let ((maybe-search-list-host (concatenate 'string host ":")))
2119      (when (and (not (logical-pathname-p (pathname maybe-search-list-host)))      (when (and (not (logical-pathname-p (pathname maybe-search-list-host)))
2120                 (search-list-defined-p maybe-search-list-host))                 (search-list-defined-p maybe-search-list-host))
2121        (cerror "Clobber search-list host with logical pathname host"        (cerror _"Clobber search-list host with logical pathname host"
2122                "~S names a CMUCL search-list"                _"~S names a CMUCL search-list"
2123                host)))                host)))
2124    (let ((host (intern-logical-host host)))    (let ((host (intern-logical-host host)))
2125      (setf (logical-host-canon-transls host)      (setf (logical-host-canon-transls host)
# Line 2134  a host-structure or string." Line 2135  a host-structure or string."
2135  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public  ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
2136  ;;;  ;;;
2137  (defun load-logical-pathname-translations (host)  (defun load-logical-pathname-translations (host)
2138    "Search for a logical pathname named host, if not already defined. If already    _N"Search for a logical pathname named host, if not already defined. If already
2139     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
2140     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
2141     successfully, T is returned, else error."     successfully, T is returned, else error."
# Line 2148  a host-structure or string." Line 2149  a host-structure or string."
2149                                               :type "translations"))                                               :type "translations"))
2150          (if *load-verbose*          (if *load-verbose*
2151              (format *error-output*              (format *error-output*
2152                      ";; Loading pathname translations from ~A~%"                      _";; Loading pathname translations from ~A~%"
2153                      (namestring (truename in-str))))                      (namestring (truename in-str))))
2154          (setf (logical-pathname-translations host) (read in-str)))          (setf (logical-pathname-translations host) (read in-str)))
2155        t)))        t)))
# Line 2156  a host-structure or string." Line 2157  a host-structure or string."
2157  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public  ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
2158  ;;;  ;;;
2159  (defun translate-logical-pathname (pathname &key)  (defun translate-logical-pathname (pathname &key)
2160    "Translates pathname to a physical pathname, which is returned."    _N"Translates pathname to a physical pathname, which is returned."
2161    (declare (type path-designator pathname)    (declare (type path-designator pathname)
2162             (values (or null pathname)))             (values (or null pathname)))
2163    (typecase pathname    (typecase pathname
# Line 2164  a host-structure or string." Line 2165  a host-structure or string."
2165       (dolist (x (logical-host-canon-transls (%pathname-host pathname))       (dolist (x (logical-host-canon-transls (%pathname-host pathname))
2166                  (error 'simple-file-error                  (error 'simple-file-error
2167                         :pathname pathname                         :pathname pathname
2168                         :format-control "No translation for ~S"                         :format-control _"No translation for ~S"
2169                         :format-arguments (list pathname)))                         :format-arguments (list pathname)))
2170         (destructuring-bind (from to) x         (destructuring-bind (from to) x
2171           (when (pathname-match-p pathname from)           (when (pathname-match-p pathname from)

Legend:
Removed from v.1.89  
changed lines
  Added in v.1.89.4.1

  ViewVC Help
Powered by ViewVC 1.1.5