X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpathname.lisp;h=deb6343bb5136b9af8e6b345df20b5737e3782d8;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=a430f429a6783d52f2225dcef7f2461197bed2ec;hpb=4f7211e1d005696dcd29d8322fa531992ea8fed4;p=sbcl.git diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index a430f42..deb6343 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -17,30 +17,42 @@ ;;; pathname information into structure slot entries, and after ;;; translation the inverse (unparse) functions. (def!struct (host (:constructor nil)) - (parse (required-argument) :type function) - (unparse (required-argument) :type function) - (unparse-host (required-argument) :type function) - (unparse-directory (required-argument) :type function) - (unparse-file (required-argument) :type function) - (unparse-enough (required-argument) :type function) - (customary-case (required-argument) :type (member :upper :lower))) + (parse (missing-arg) :type function) + (parse-native (missing-arg) :type function) + (unparse (missing-arg) :type function) + (unparse-native (missing-arg) :type function) + (unparse-host (missing-arg) :type function) + (unparse-directory (missing-arg) :type function) + (unparse-file (missing-arg) :type function) + (unparse-enough (missing-arg) :type function) + (unparse-directory-separator (missing-arg) :type simple-string) + (customary-case (missing-arg) :type (member :upper :lower))) (def!method print-object ((host host) stream) (print-unreadable-object (host stream :type t :identity t))) (def!struct (logical-host - (:make-load-form-fun make-logical-host-load-form-fun) - (:include host - (:parse #'parse-logical-namestring) - (:unparse #'unparse-logical-namestring) - (:unparse-host - (lambda (x) - (logical-host-name (%pathname-host x)))) - (:unparse-directory #'unparse-logical-directory) - (:unparse-file #'unparse-unix-file) - (:unparse-enough #'unparse-enough-namestring) - (:customary-case :upper))) - (name "" :type simple-base-string) + (:make-load-form-fun make-logical-host-load-form-fun) + (:include host + (parse #'parse-logical-namestring) + (parse-native + (lambda (&rest x) + (error "called PARSE-NATIVE-NAMESTRING using a ~ + logical host: ~S" (first x)))) + (unparse #'unparse-logical-namestring) + (unparse-native + (lambda (&rest x) + (error "called NATIVE-NAMESTRING using a ~ + logical host: ~S" (first x)))) + (unparse-host + (lambda (x) + (logical-host-name (%pathname-host x)))) + (unparse-directory #'unparse-logical-directory) + (unparse-file #'unparse-logical-file) + (unparse-enough #'unparse-enough-namestring) + (unparse-directory-separator ";") + (customary-case :upper))) + (name "" :type simple-string) (translations nil :type list) (canon-transls nil :type list)) @@ -48,32 +60,31 @@ (print-unreadable-object (logical-host stream :type t) (prin1 (logical-host-name logical-host) stream))) -;;; What would it mean to dump a logical host and reload it into -;;; another Lisp image? It's not clear, so we don't support it. (defun make-logical-host-load-form-fun (logical-host) - (error "~@" - logical-host)) + (values `(find-logical-host ',(logical-host-name logical-host)) + nil)) ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. -(sb!xc:defstruct (pattern (:constructor make-pattern (pieces))) +(def!struct (pattern (:constructor make-pattern (pieces))) (pieces nil :type list)) ;;;; PATHNAME structures ;;; the various magic tokens that are allowed to appear in pretty much ;;; all pathname components -(sb!xc:deftype pathname-component-tokens () - '(member nil :unspecific :wild)) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (def!type pathname-component-tokens () + '(member nil :unspecific :wild :unc))) (sb!xc:defstruct (pathname (:conc-name %pathname-) - (:constructor %make-pathname (host - device - directory - name - type - version)) - (:predicate pathnamep)) + (:constructor %make-pathname (host + device + directory + name + type + version)) + (:predicate pathnamep)) ;; the host (at present either a UNIX or logical host) (host nil :type (or host null)) ;; the name of a logical or physical device holding files @@ -91,7 +102,7 @@ ;;; Logical pathnames have the following format: ;;; ;;; logical-namestring ::= -;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] +;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] ;;; ;;; host ::= word ;;; directory ::= word | wildcard-word | ** @@ -107,11 +118,54 @@ ;;; Logical pathnames are a subclass of PATHNAME. Their class ;;; relations are mimicked using structures for efficiency. (sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-) - (:include pathname) - (:constructor %make-logical-pathname - (host - device - directory - name - type - version)))) + (:include pathname) + (:constructor %make-logical-pathname + (host + device + directory + name + type + version)))) + +;;; This is used both for Unix and Windows: while we accept both +;;; \ and / as directory separators on Windows, we print our +;;; own always with /, which is much less confusing what with +;;; being \ needing to be escaped. +(defun unparse-physical-directory (pathname) + (declare (pathname pathname)) + (unparse-physical-directory-list (%pathname-directory pathname))) + +(defun unparse-physical-directory-list (directory) + (declare (list directory)) + (collect ((pieces)) + (when directory + (ecase (pop directory) + (:absolute + (let ((next (pop directory))) + (cond ((eq :home next) + (pieces "~")) + ((and (consp next) (eq :home (car next))) + (pieces "~") + (pieces (second next))) + ((and (plusp (length next)) (char= #\~ (char next 0))) + ;; The only place we need to escape the tilde. + (pieces "\\") + (pieces next)) + (next + (push next directory))) + (pieces "/"))) + (:relative)) + (dolist (dir directory) + (typecase dir + ((member :up) + (pieces "../")) + ((member :back) + (error ":BACK cannot be represented in namestrings.")) + ((member :wild-inferiors) + (pieces "**/")) + ((or simple-string pattern (member :wild)) + (pieces (unparse-physical-piece dir)) + (pieces "/")) + (t + (error "invalid directory component: ~S" dir))))) + (apply #'concatenate 'simple-string (pieces))))