X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpathname.lisp;h=deb6343bb5136b9af8e6b345df20b5737e3782d8;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=c20a0aa1fb47274ec2695670d77f58acf3ab028a;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index c20a0aa..deb6343 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -10,77 +10,99 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; data types used by pathnames ;;; The HOST structure holds the functions that both parse the ;;; pathname information into structure slot entries, and after ;;; translation the inverse (unparse) functions. -(sb!xc:defstruct (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))) +(def!struct (host (:constructor nil)) + (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))) -(sb!xc:defstruct (logical-host - (: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 #'identity) - (:customary-case :upper))) - (name "" :type simple-base-string) +(def!struct (logical-host + (: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)) +(def!method print-object ((logical-host logical-host) stream) + (print-unreadable-object (logical-host stream :type t) + (prin1 (logical-host-name logical-host) stream))) + +(defun make-logical-host-load-form-fun (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 component-tokens () ; FIXME: rename to 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 - (device nil :type (or simple-string component-tokens)) + (device nil :type (or simple-string pathname-component-tokens)) ;; a list of strings that are the component subdirectory components (directory nil :type list) ;; the filename - (name nil :type (or simple-string pattern component-tokens)) + (name nil :type (or simple-string pattern pathname-component-tokens)) ;; the type extension of the file - (type nil :type (or simple-string pattern component-tokens)) + (type nil :type (or simple-string pattern pathname-component-tokens)) ;; the version number of the file, a positive integer (not supported ;; on standard Unix filesystems) - (version nil :type (or integer component-tokens (member :newest)))) + (version nil :type (or integer pathname-component-tokens (member :newest)))) ;;; Logical pathnames have the following format: ;;; ;;; logical-namestring ::= -;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] +;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] ;;; ;;; host ::= word ;;; directory ::= word | wildcard-word | ** @@ -93,30 +115,57 @@ ;;; ;;; 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. +;;; 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)))) - -(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))))