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-directory-list (directory)
136 (declare (type list directory
))
139 (ecase (pop directory
)
145 (dolist (dir directory
)
150 (error ":BACK cannot be represented in namestrings."))
151 ((member :wild-inferiors
)
153 ((or simple-string pattern
(member :wild
))
154 (pieces (unparse-physical-piece dir
))
157 (error "invalid directory component: ~S" dir
)))))
158 (apply #'concatenate
'simple-string
(pieces))))
160 (defun unparse-unix-directory (pathname)
161 (declare (type pathname pathname
))
162 (unparse-unix-directory-list (%pathname-directory pathname
)))
164 (defun unparse-unix-file (pathname)
165 (declare (type pathname pathname
))
167 (let* ((name (%pathname-name pathname
))
168 (type (%pathname-type pathname
))
169 (type-supplied (not (or (null type
) (eq type
:unspecific
)))))
170 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
171 ;; translating logical pathnames to a filesystem without
172 ;; versions (like Unix).
174 (when (and (null type
)
177 (position #\. name
:start
1))
178 (error "too many dots in the name: ~S" pathname
))
179 (when (and (typep name
'string
)
181 (error "name is of length 0: ~S" pathname
))
182 (strings (unparse-physical-piece name
)))
185 (error "cannot specify the type without a file: ~S" pathname
))
186 (when (typep type
'simple-string
)
187 (when (position #\. type
)
188 (error "type component can't have a #\. inside: ~S" pathname
)))
190 (strings (unparse-physical-piece type
))))
191 (apply #'concatenate
'simple-string
(strings))))
193 (/show0
"filesys.lisp 406")
195 (defun unparse-unix-namestring (pathname)
196 (declare (type pathname pathname
))
197 (concatenate 'simple-string
198 (unparse-unix-directory pathname
)
199 (unparse-unix-file pathname
)))
201 (defun unparse-native-unix-namestring (pathname as-file
)
202 (declare (type pathname pathname
))
203 (let* ((directory (pathname-directory pathname
))
204 (name (pathname-name pathname
))
205 (name-present-p (typep name
'(not (member nil
:unspecific
))))
206 (name-string (if name-present-p name
""))
207 (type (pathname-type pathname
))
208 (type-present-p (typep type
'(not (member nil
:unspecific
))))
209 (type-string (if type-present-p type
"")))
213 (with-output-to-string (s)
215 (ecase (car directory
)
216 (:absolute
(write-char #\
/ s
))
218 (loop for
(piece . subdirs
) on
(cdr directory
)
220 ((member :up
) (write-string ".." s
))
221 (string (write-string piece s
))
222 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
224 if
(or subdirs
(stringp name
))
225 do
(write-char #\
/ s
)
231 (unless (stringp name-string
) ;some kind of wild field
232 (error "ungood name component in NATIVE-NAMESTRING: ~S" name
))
233 (write-string name-string s
)
235 (unless (stringp type-string
) ;some kind of wild field
236 (error "ungood type component in NATIVE-NAMESTRING: ~S" type
))
238 (write-string type-string s
)))
239 (when type-present-p
; type without a name
241 "type component without a name component in NATIVE-NAMESTRING: ~S"
245 (defun unparse-unix-enough (pathname defaults
)
246 (declare (type pathname pathname defaults
))
248 (error "~S cannot be represented relative to ~S."
251 (let* ((pathname-directory (%pathname-directory pathname
))
252 (defaults-directory (%pathname-directory defaults
))
253 (prefix-len (length defaults-directory
))
255 (cond ((null pathname-directory
) '(:relative
))
256 ((eq (car pathname-directory
) :relative
)
258 ((and (> prefix-len
0)
259 (>= (length pathname-directory
) prefix-len
)
260 (compare-component (subseq pathname-directory
263 ;; Pathname starts with a prefix of default. So
264 ;; just use a relative directory from then on out.
265 (cons :relative
(nthcdr prefix-len pathname-directory
)))
266 ((eq (car pathname-directory
) :absolute
)
267 ;; We are an absolute pathname, so we can just use it.
270 (bug "Bad fallthrough in ~S" 'unparse-unix-enough
)))))
271 (strings (unparse-unix-directory-list result-directory
)))
272 (let* ((pathname-type (%pathname-type pathname
))
273 (type-needed (and pathname-type
274 (not (eq pathname-type
:unspecific
))))
275 (pathname-name (%pathname-name pathname
))
276 (name-needed (or type-needed
278 (not (compare-component pathname-name
282 (unless pathname-name
(lose))
283 (when (and (null pathname-type
)
284 (typep pathname-name
'simple-string
)
285 (position #\. pathname-name
:start
1))
286 (error "too many dots in the name: ~S" pathname
))
287 (strings (unparse-physical-piece pathname-name
)))
289 (when (or (null pathname-type
) (eq pathname-type
:unspecific
))
291 (when (typep pathname-type
'simple-string
)
292 (when (position #\. pathname-type
)
293 (error "type component can't have a #\. inside: ~S" pathname
)))
295 (strings (unparse-physical-piece pathname-type
))))
296 (apply #'concatenate
'simple-string
(strings)))))
298 (defun simplify-unix-namestring (src)
299 (declare (type simple-string src
))
300 (let* ((src-len (length src
))
301 (dst (make-string src-len
:element-type
'character
))
305 (macrolet ((deposit (char)
307 (setf (schar dst dst-len
) ,char
)
309 (dotimes (src-index src-len
)
310 (let ((char (schar src src-index
)))
311 (cond ((char= char
#\.
)
318 ;; either ``/...' or ``...//...'
320 (setf last-slash dst-len
)
323 ;; either ``./...'' or ``..././...''
328 ((and last-slash
(not (zerop last-slash
)))
329 ;; There is something before this ..
330 (let ((prev-prev-slash
331 (position #\
/ dst
:end last-slash
:from-end t
)))
332 (cond ((and (= (+ (or prev-prev-slash
0) 2)
334 (char= (schar dst
(- last-slash
2)) #\.
)
335 (char= (schar dst
(1- last-slash
)) #\.
))
336 ;; The something before this .. is another ..
338 (setf last-slash dst-len
))
340 ;; The something is some directory or other.
345 (setf last-slash prev-prev-slash
)))))
347 ;; There is nothing before this .., so we need to keep it
348 (setf last-slash dst-len
)
351 ;; something other than a dot between slashes
352 (setf last-slash dst-len
)
357 (setf (schar dst dst-len
) char
)
359 (when (and last-slash
(not (zerop last-slash
)))
362 ;; We've got ``foobar/.''
365 ;; We've got ``foobar/..''
366 (unless (and (>= last-slash
2)
367 (char= (schar dst
(1- last-slash
)) #\.
)
368 (char= (schar dst
(- last-slash
2)) #\.
)
370 (char= (schar dst
(- last-slash
3)) #\
/)))
371 (let ((prev-prev-slash
372 (position #\
/ dst
:end last-slash
:from-end t
)))
374 (setf dst-len
(1+ prev-prev-slash
))
375 (return-from simplify-unix-namestring
376 (coerce "./" 'simple-string
))))))))
377 (cond ((zerop dst-len
)
382 (subseq dst
0 dst-len
)))))