1;;;; the known-to-the-cross-compiler part of PATHNAME logic 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!IMPL") 13 14;;;; data types used by pathnames 15 16;;; The HOST structure holds the functions that both parse the 17;;; pathname information into structure slot entries, and after 18;;; translation the inverse (unparse) functions. 19(sb!xc:defstruct (host (:constructor nil) 20 (:print-object 21 (lambda (host stream) 22 (print-unreadable-object 23 (host stream :type t :identity t))))) 24 (parse (missing-arg) :type function) 25 (parse-native (missing-arg) :type function) 26 (unparse (missing-arg) :type function) 27 (unparse-native (missing-arg) :type function) 28 (unparse-host (missing-arg) :type function) 29 (unparse-directory (missing-arg) :type function) 30 (unparse-file (missing-arg) :type function) 31 (unparse-enough (missing-arg) :type function) 32 (unparse-directory-separator (missing-arg) :type simple-string) 33 (simplify-namestring (missing-arg) :type function) 34 (customary-case (missing-arg) :type (member :upper :lower))) 35 36(sb!xc:defstruct 37 (logical-host 38 (:print-object 39 (lambda (logical-host stream) 40 (print-unreadable-object (logical-host stream :type t) 41 (prin1 (logical-host-name logical-host) stream)))) 42 (:include host 43 (parse #'parse-logical-namestring) 44 (parse-native 45 (lambda (&rest x) 46 (error "called PARSE-NATIVE-NAMESTRING using a ~ 47 logical host: ~S" (first x)))) 48 (unparse #'unparse-logical-namestring) 49 (unparse-native 50 (lambda (&rest x) 51 (error "called NATIVE-NAMESTRING using a ~ 52 logical host: ~S" (first x)))) 53 (unparse-host 54 (lambda (x) 55 (logical-host-name (%pathname-host x)))) 56 (unparse-directory #'unparse-logical-directory) 57 (unparse-file #'unparse-logical-file) 58 (unparse-enough #'unparse-enough-namestring) 59 (unparse-directory-separator ";") 60 (simplify-namestring #'identity) 61 (customary-case :upper))) 62 (name "" :type simple-string) 63 (translations nil :type list) 64 (canon-transls nil :type list)) 65 66#-sb-xc-host 67(defmethod make-load-form ((logical-host logical-host) &optional env) 68 (declare (ignore env)) 69 (values `(find-logical-host ',(logical-host-name logical-host)) 70 nil)) 71 72;;; A PATTERN is a list of entries and wildcards used for pattern 73;;; matches of translations. 74(def!struct (pattern (:constructor make-pattern (pieces))) 75 (pieces nil :type list)) 76 77;;;; PATHNAME structures 78 79;;; the various magic tokens that are allowed to appear in pretty much 80;;; all pathname components 81(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) 82 (def!type pathname-component-tokens () 83 '(member nil :unspecific :wild :unc))) 84 85(sb!xc:defstruct (pathname (:conc-name %pathname-) 86 (:constructor %make-pathname (host 87 device 88 directory 89 name 90 type 91 version)) 92 (:predicate pathnamep)) 93 ;; the host (at present either a UNIX or logical host) 94 (host nil :type (or host null)) 95 ;; the name of a logical or physical device holding files 96 (device nil :type (or simple-string pathname-component-tokens)) 97 ;; a list of strings that are the component subdirectory components 98 (directory nil :type list) 99 ;; the filename 100 (name nil :type (or simple-string pattern pathname-component-tokens)) 101 ;; the type extension of the file 102 (type nil :type (or simple-string pattern pathname-component-tokens)) 103 ;; the version number of the file, a positive integer (not supported 104 ;; on standard Unix filesystems) 105 (version nil :type (or integer pathname-component-tokens (member :newest)))) 106 107;;; Logical pathnames have the following format: 108;;; 109;;; logical-namestring ::= 110;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] 111;;; 112;;; host ::= word 113;;; directory ::= word | wildcard-word | ** 114;;; name ::= word | wildcard-word 115;;; type ::= word | wildcard-word 116;;; version ::= pos-int | newest | NEWEST | * 117;;; word ::= {uppercase-letter | digit | -}+ 118;;; wildcard-word ::= [word] '* {word '*}* [word] 119;;; pos-int ::= integer > 0 120;;; 121;;; Physical pathnames include all these slots and a device slot. 122 123;;; Logical pathnames are a subclass of PATHNAME. Their class 124;;; relations are mimicked using structures for efficiency. 125(sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-) 126 (:include pathname) 127 (:constructor %make-logical-pathname 128 (host 129 device 130 directory 131 name 132 type 133 version)))) 134 135;;; This is used both for Unix and Windows: while we accept both 136;;; \ and / as directory separators on Windows, we print our 137;;; own always with /, which is much less confusing what with 138;;; being \ needing to be escaped. 139#-sb-xc-host ; %PATHNAME-DIRECTORY is target-only 140(defun unparse-physical-directory (pathname escape-char) 141 (declare (pathname pathname)) 142 (unparse-physical-directory-list (%pathname-directory pathname) escape-char)) 143 144#-sb-xc-host 145(defun unparse-physical-directory-list (directory escape-char) 146 (declare (list directory)) 147 (collect ((pieces)) 148 (when directory 149 (ecase (pop directory) 150 (:absolute 151 (let ((next (pop directory))) 152 (cond ((eq :home next) 153 (pieces "~")) 154 ((and (consp next) (eq :home (car next))) 155 (pieces "~") 156 (pieces (second next))) 157 ((and (plusp (length next)) (char= #\~ (char next 0))) 158 ;; The only place we need to escape the tilde. 159 (pieces "\\") 160 (pieces next)) 161 (next 162 (push next directory))) 163 (pieces "/"))) 164 (:relative)) 165 (dolist (dir directory) 166 (typecase dir 167 ((member :up) 168 (pieces "../")) 169 ((member :back) 170 (error ":BACK cannot be represented in namestrings.")) 171 ((member :wild-inferiors) 172 (pieces "**/")) 173 ((or simple-string pattern (member :wild)) 174 (pieces (unparse-physical-piece dir escape-char)) 175 (pieces "/")) 176 (t 177 (error "invalid directory component: ~S" dir))))) 178 (apply #'concatenate 'simple-string (pieces)))) 179