1 ;;;; pathname parsing for Unix filesystems
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 ;;; Take a string and return a list of cons cells that mark the char
15 ;;; separated subseq. The first value is true if absolute directories
17 (defun split-at-slashes (namestr start end)
18 (declare (type simple-string namestr)
19 (type index start end))
20 (let ((absolute (and (/= start end)
21 (char= (schar namestr start) #\/))))
24 ;; Next, split the remainder into slash-separated chunks.
27 (let ((slash (position #\/ namestr :start start :end end)))
28 (pieces (cons start (or slash end)))
31 (setf start (1+ slash))))
32 (values absolute (pieces)))))
34 (defun parse-unix-namestring (namestring start end)
35 (declare (type simple-string namestring)
36 (type index start end))
37 (setf namestring (coerce namestring 'simple-string))
38 (multiple-value-bind (absolute pieces)
39 (split-at-slashes namestring start end)
40 (multiple-value-bind (name type version)
41 (let* ((tail (car (last pieces)))
42 (tail-start (car tail))
43 (tail-end (cdr tail)))
44 (unless (= tail-start tail-end)
45 (setf pieces (butlast pieces))
46 (extract-name-type-and-version namestring tail-start tail-end)))
49 (let ((position (position-if (lambda (char)
50 (or (char= char (code-char 0))
54 (error 'namestring-parse-error
55 :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
56 :namestring namestring
58 ;; Now we have everything we want. So return it.
59 (values nil ; no host for Unix namestrings
60 nil ; no device for Unix namestrings
62 (dolist (piece pieces)
63 (let ((piece-start (car piece))
64 (piece-end (cdr piece)))
65 (unless (= piece-start piece-end)
66 (cond ((string= namestring ".."
70 ((string= namestring "**"
73 (dirs :wild-inferiors))
75 (dirs (maybe-make-pattern namestring
79 (cons :absolute (dirs)))
81 (cons :relative (dirs)))
88 (defun parse-native-unix-namestring (namestring start end as-directory)
89 (declare (type simple-string namestring)
90 (type index start end))
91 (setf namestring (coerce namestring 'simple-string))
92 (multiple-value-bind (absolute ranges)
93 (split-at-slashes namestring start end)
94 (let* ((components (loop for ((start . end) . rest) on ranges
95 for piece = (subseq namestring start end)
96 collect (if (and (string= piece "..") rest)
99 (directory (if (and as-directory
100 (string/= "" (car (last components))))
102 (butlast components)))
105 (let* ((end (first (last components)))
106 (dot (position #\. end :from-end t)))
107 ;; FIXME: can we get this dot-interpretation knowledge
108 ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
109 ;; does slightly more work than that.
114 (list (subseq end 0 dot) (subseq end (1+ dot))))
119 (cons (if absolute :absolute :relative) directory)
120 (first name-and-type)
121 (second name-and-type)
124 (/show0 "filesys.lisp 300")
126 (defun unparse-unix-host (pathname)
127 (declare (type pathname pathname)
129 ;; this host designator needs to be recognized as a physical host in
130 ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
131 ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
135 (defun unparse-unix-file (pathname)
136 (declare (type pathname pathname))
138 (let* ((name (%pathname-name pathname))
139 (type (%pathname-type pathname))
140 (type-supplied (not (or (null type) (eq type :unspecific)))))
141 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
142 ;; translating logical pathnames to a filesystem without
143 ;; versions (like Unix).
145 (when (and (null type)
148 (position #\. name :start 1))
149 (error "too many dots in the name: ~S" pathname))
150 (when (and (typep name 'string)
152 (error "name is of length 0: ~S" pathname))
153 (strings (unparse-physical-piece name)))
156 (error "cannot specify the type without a file: ~S" pathname))
157 (when (typep type 'simple-string)
158 (when (position #\. type)
159 (error "type component can't have a #\. inside: ~S" pathname)))
161 (strings (unparse-physical-piece type))))
162 (apply #'concatenate 'simple-string (strings))))
164 (/show0 "filesys.lisp 406")
166 (defun unparse-unix-namestring (pathname)
167 (declare (type pathname pathname))
168 (concatenate 'simple-string
169 (unparse-physical-directory pathname)
170 (unparse-unix-file pathname)))
172 (defun unparse-native-unix-namestring (pathname as-file)
173 (declare (type pathname pathname))
174 (let* ((directory (pathname-directory pathname))
175 (name (pathname-name pathname))
176 (name-present-p (typep name '(not (member nil :unspecific))))
177 (name-string (if name-present-p name ""))
178 (type (pathname-type pathname))
179 (type-present-p (typep type '(not (member nil :unspecific))))
180 (type-string (if type-present-p type "")))
184 (with-output-to-string (s)
186 (ecase (car directory)
187 (:absolute (write-char #\/ s))
189 (loop for (piece . subdirs) on (cdr directory)
191 ((member :up) (write-string ".." s))
192 (string (write-string piece s))
193 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
195 if (or subdirs (stringp name))
196 do (write-char #\/ s)
202 (unless (stringp name-string) ;some kind of wild field
203 (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
204 (write-string name-string s)
206 (unless (stringp type-string) ;some kind of wild field
207 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
209 (write-string type-string s)))
210 (when type-present-p ; type without a name
212 "type component without a name component in NATIVE-NAMESTRING: ~S"
216 (defun unparse-unix-enough (pathname defaults)
217 (declare (type pathname pathname defaults))
219 (error "~S cannot be represented relative to ~S."
222 (let* ((pathname-directory (%pathname-directory pathname))
223 (defaults-directory (%pathname-directory defaults))
224 (prefix-len (length defaults-directory))
226 (cond ((null pathname-directory) '(:relative))
227 ((eq (car pathname-directory) :relative)
229 ((and (> prefix-len 0)
230 (>= (length pathname-directory) prefix-len)
231 (compare-component (subseq pathname-directory
234 ;; Pathname starts with a prefix of default. So
235 ;; just use a relative directory from then on out.
236 (cons :relative (nthcdr prefix-len pathname-directory)))
237 ((eq (car pathname-directory) :absolute)
238 ;; We are an absolute pathname, so we can just use it.
241 (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
242 (strings (unparse-physical-directory-list result-directory)))
243 (let* ((pathname-type (%pathname-type pathname))
244 (type-needed (and pathname-type
245 (not (eq pathname-type :unspecific))))
246 (pathname-name (%pathname-name pathname))
247 (name-needed (or type-needed
249 (not (compare-component pathname-name
253 (unless pathname-name (lose))
254 (when (and (null pathname-type)
255 (typep pathname-name 'simple-string)
256 (position #\. pathname-name :start 1))
257 (error "too many dots in the name: ~S" pathname))
258 (strings (unparse-physical-piece pathname-name)))
260 (when (or (null pathname-type) (eq pathname-type :unspecific))
262 (when (typep pathname-type 'simple-string)
263 (when (position #\. pathname-type)
264 (error "type component can't have a #\. inside: ~S" pathname)))
266 (strings (unparse-physical-piece pathname-type))))
267 (apply #'concatenate 'simple-string (strings)))))
269 (defun simplify-unix-namestring (src)
270 (declare (type simple-string src))
271 (let* ((src-len (length src))
272 (dst (make-string src-len :element-type 'character))
276 (macrolet ((deposit (char)
278 (setf (schar dst dst-len) ,char)
280 (dotimes (src-index src-len)
281 (let ((char (schar src src-index)))
282 (cond ((char= char #\.)
289 ;; either ``/...' or ``...//...'
291 (setf last-slash dst-len)
294 ;; either ``./...'' or ``..././...''
299 ((and last-slash (not (zerop last-slash)))
300 ;; There is something before this ..
301 (let ((prev-prev-slash
302 (position #\/ dst :end last-slash :from-end t)))
303 (cond ((and (= (+ (or prev-prev-slash 0) 2)
305 (char= (schar dst (- last-slash 2)) #\.)
306 (char= (schar dst (1- last-slash)) #\.))
307 ;; The something before this .. is another ..
309 (setf last-slash dst-len))
311 ;; The something is some directory or other.
316 (setf last-slash prev-prev-slash)))))
318 ;; There is nothing before this .., so we need to keep it
319 (setf last-slash dst-len)
322 ;; something other than a dot between slashes
323 (setf last-slash dst-len)
328 (setf (schar dst dst-len) char)
330 (when (and last-slash (not (zerop last-slash)))
333 ;; We've got ``foobar/.''
336 ;; We've got ``foobar/..''
337 (unless (and (>= last-slash 2)
338 (char= (schar dst (1- last-slash)) #\.)
339 (char= (schar dst (- last-slash 2)) #\.)
341 (char= (schar dst (- last-slash 3)) #\/)))
342 (let ((prev-prev-slash
343 (position #\/ dst :end last-slash :from-end t)))
345 (setf dst-len (1+ prev-prev-slash))
346 (return-from simplify-unix-namestring
347 (coerce "./" 'simple-string))))))))
348 (cond ((zerop dst-len)
353 (subseq dst 0 dst-len)))))