X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpathname.lisp;h=deb6343bb5136b9af8e6b345df20b5737e3782d8;hb=b7d22ded1428e8d3e87c37164aa6742dd28aa6ce;hp=94a9cfb17e99b0cc981cff920f8fa9c66012af8b;hpb=6fa0ad323b5031017e62ee5d7e016eae2cf79efd;p=sbcl.git diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 94a9cfb..deb6343 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -17,27 +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)) @@ -45,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 @@ -88,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 | ** @@ -102,29 +116,56 @@ ;;; Physical pathnames include all these slots and a device slot. ;;; Logical pathnames are a subclass of PATHNAME. Their class -;;; relations are mimicked using structures for efficency. +;;; 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)))) - -(defmacro-mundanely enumerate-search-list ((var pathname &optional result) - &body body) - #!+sb-doc - "Execute BODY with VAR bound to each successive possible expansion for - PATHNAME and then return RESULT. Note: if PATHNAME does not contain a - search-list, then BODY is executed exactly once. Everything is wrapped - in a block named NIL, so RETURN can be used to terminate early. Note: - VAR is *not* bound inside of RESULT." - (let ((body-name (gensym))) - `(block nil - (flet ((,body-name (,var) - ,@body)) - (%enumerate-search-list ,pathname #',body-name) - ,result)))) + (: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))))