1 ;;;; pathname parsing for Win32 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 (defun extract-device (namestr start end
)
15 (declare (type simple-string namestr
)
16 (type index start end
))
17 (if (and (>= end
(+ start
2))
18 (alpha-char-p (char namestr start
))
19 (eql (char namestr
(1+ start
)) #\
:))
20 (values (string (char namestr start
)) (+ start
2))
23 (defun split-at-slashes-and-backslashes (namestr start end
)
24 (declare (type simple-string namestr
)
25 (type index start end
))
26 (let ((absolute (and (/= start end
)
27 (or (char= (schar namestr start
) #\
/)
28 (char= (schar namestr start
) #\\)))))
31 ;; Next, split the remainder into slash-separated chunks.
34 (let ((slash (position-if (lambda (c)
37 namestr
:start start
:end end
)))
38 (pieces (cons start
(or slash end
)))
41 (setf start
(1+ slash
))))
42 (values absolute
(pieces)))))
44 (defun parse-win32-namestring (namestring start end
)
45 (declare (type simple-string namestring
)
46 (type index start end
))
47 (setf namestring
(coerce namestring
'simple-string
))
48 (multiple-value-bind (device new-start
)
49 (extract-device namestring start end
)
50 (multiple-value-bind (absolute pieces
)
51 (split-at-slashes-and-backslashes namestring new-start end
)
52 (multiple-value-bind (name type version
)
53 (let* ((tail (car (last pieces
)))
54 (tail-start (car tail
))
55 (tail-end (cdr tail
)))
56 (unless (= tail-start tail-end
)
57 (setf pieces
(butlast pieces
))
58 (extract-name-type-and-version namestring tail-start tail-end
)))
61 (let ((position (position-if (lambda (char)
62 (or (char= char
(code-char 0))
66 (error 'namestring-parse-error
67 :complaint
"can't embed #\\Nul or #\\/ in Unix namestring"
68 :namestring namestring
70 ;; Now we have everything we want. So return it.
71 (values nil
; no host for Win32 namestrings
74 (dolist (piece pieces
)
75 (let ((piece-start (car piece
))
76 (piece-end (cdr piece
)))
77 (unless (= piece-start piece-end
)
78 (cond ((string= namestring
".."
82 ((string= namestring
"**"
85 (dirs :wild-inferiors
))
87 (dirs (maybe-make-pattern namestring
91 (cons :absolute
(dirs)))
93 (cons :relative
(dirs)))
100 (defun parse-native-win32-namestring (namestring start end as-directory
)
101 (declare (type simple-string namestring
)
102 (type index start end
))
103 (setf namestring
(coerce namestring
'simple-string
))
104 (multiple-value-bind (device new-start
)
105 (extract-device namestring start end
)
106 (multiple-value-bind (absolute ranges
)
107 (split-at-slashes-and-backslashes namestring new-start end
)
108 (let* ((components (loop for
((start . end
) . rest
) on ranges
109 for piece
= (subseq namestring start end
)
110 collect
(if (and (string= piece
"..") rest
)
113 (directory (if (and as-directory
114 (string/= "" (car (last components
))))
116 (butlast components
)))
119 (let* ((end (first (last components
)))
120 (dot (position #\. end
:from-end t
)))
121 ;; FIXME: can we get this dot-interpretation knowledge
122 ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
123 ;; does slightly more work than that.
128 (list (subseq end
0 dot
) (subseq end
(1+ dot
))))
133 (cons (if absolute
:absolute
:relative
) directory
)
134 (first name-and-type
)
135 (second name-and-type
)
140 (defun unparse-win32-host (pathname)
141 (declare (type pathname pathname
)
143 ;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good.
146 (defun unparse-win32-device (pathname)
147 (declare (type pathname pathname
))
148 (let ((device (pathname-device pathname
)))
149 (if (or (null device
) (eq device
:unspecific
))
151 (concatenate 'simple-string
(string device
) ":"))))
153 (defun unparse-win32-piece (thing)
157 (let* ((srclen (length thing
))
160 (case (schar thing i
)
163 (let ((result (make-string dstlen
))
165 (dotimes (src srclen
)
166 (let ((char (schar thing src
)))
169 (setf (schar result dst
) #\\)
171 (setf (schar result dst
) char
)
176 (dolist (piece (pattern-pieces thing
))
190 (strings (cdr piece
))
193 (error "invalid pattern piece: ~S" piece
))))))
198 (defun unparse-win32-directory-list (directory)
199 (declare (type list directory
))
202 (ecase (pop directory
)
208 (dolist (dir directory
)
213 (error ":BACK cannot be represented in namestrings."))
214 ((member :wild-inferiors
)
216 ((or simple-string pattern
(member :wild
))
217 (pieces (unparse-unix-piece dir
))
220 (error "invalid directory component: ~S" dir
)))))
221 (apply #'concatenate
'simple-string
(pieces))))
223 (defun unparse-win32-directory (pathname)
224 (declare (type pathname pathname
))
225 (unparse-win32-directory-list (%pathname-directory pathname
)))
227 (defun unparse-win32-file (pathname)
228 (declare (type pathname pathname
))
230 (let* ((name (%pathname-name pathname
))
231 (type (%pathname-type pathname
))
232 (type-supplied (not (or (null type
) (eq type
:unspecific
)))))
233 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
234 ;; translating logical pathnames to a filesystem without
235 ;; versions (like Win32).
237 (when (and (null type
)
240 (position #\. name
:start
1))
241 (error "too many dots in the name: ~S" pathname
))
242 (when (and (typep name
'string
)
244 (error "name is of length 0: ~S" pathname
))
245 (strings (unparse-unix-piece name
)))
248 (error "cannot specify the type without a file: ~S" pathname
))
249 (when (typep type
'simple-string
)
250 (when (position #\. type
)
251 (error "type component can't have a #\. inside: ~S" pathname
)))
253 (strings (unparse-unix-piece type
))))
254 (apply #'concatenate
'simple-string
(strings))))
256 (defun unparse-win32-namestring (pathname)
257 (declare (type pathname pathname
))
258 (concatenate 'simple-string
259 (unparse-win32-device pathname
)
260 (unparse-win32-directory pathname
)
261 (unparse-win32-file pathname
)))
263 (defun unparse-native-win32-namestring (pathname as-file
)
264 (declare (type pathname pathname
)
265 ;; Windows doesn't like directory names with trailing slashes.
267 (let* ((device (pathname-device pathname
))
268 (directory (pathname-directory pathname
))
269 (name (pathname-name pathname
))
270 (name-present-p (typep name
'(not (member nil
:unspecific
))))
271 (name-string (if name-present-p name
""))
272 (type (pathname-type pathname
))
273 (type-present-p (typep type
'(not (member nil
:unspecific
))))
274 (type-string (if type-present-p type
"")))
278 (with-output-to-string (s)
280 (write-string device s
)
284 (ecase (pop directory
)
285 (:absolute
(write-char #\\ s
))
287 (unless directory
(go :done
))
289 (let ((piece (pop directory
)))
291 ((member :up
) (write-string ".." s
))
292 (string (write-string piece s
))
293 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
295 (when (or directory name
)
302 (unless (stringp name-string
) ;some kind of wild field
303 (error "ungood name component in NATIVE-NAMESTRING: ~S" name
))
304 (write-string name-string s
)
306 (unless (stringp type-string
) ;some kind of wild field
307 (error "ungood type component in NATIVE-NAMESTRING: ~S" type
))
309 (write-string type-string s
)))
310 (when type-present-p
;
312 "type component without a name component in NATIVE-NAMESTRING: ~S"
317 (defun unparse-win32-enough (pathname defaults
)
318 (declare (type pathname pathname defaults
))
320 (error "~S cannot be represented relative to ~S."
323 (let* ((pathname-directory (%pathname-directory pathname
))
324 (defaults-directory (%pathname-directory defaults
))
325 (prefix-len (length defaults-directory
))
327 (cond ((null pathname-directory
) '(:relative
))
328 ((eq (car pathname-directory
) :relative
)
330 ((and (> prefix-len
0)
331 (>= (length pathname-directory
) prefix-len
)
332 (compare-component (subseq pathname-directory
335 ;; Pathname starts with a prefix of default. So
336 ;; just use a relative directory from then on out.
337 (cons :relative
(nthcdr prefix-len pathname-directory
)))
338 ((eq (car pathname-directory
) :absolute
)
339 ;; We are an absolute pathname, so we can just use it.
342 (bug "Bad fallthrough in ~S" 'unparse-unix-enough
)))))
343 (strings (unparse-unix-directory-list result-directory
)))
344 (let* ((pathname-type (%pathname-type pathname
))
345 (type-needed (and pathname-type
346 (not (eq pathname-type
:unspecific
))))
347 (pathname-name (%pathname-name pathname
))
348 (name-needed (or type-needed
350 (not (compare-component pathname-name
354 (unless pathname-name
(lose))
355 (when (and (null pathname-type
)
356 (typep pathname-name
'simple-string
)
357 (position #\. pathname-name
:start
1))
358 (error "too many dots in the name: ~S" pathname
))
359 (strings (unparse-unix-piece pathname-name
)))
361 (when (or (null pathname-type
) (eq pathname-type
:unspecific
))
363 (when (typep pathname-type
'simple-string
)
364 (when (position #\. pathname-type
)
365 (error "type component can't have a #\. inside: ~S" pathname
)))
367 (strings (unparse-unix-piece pathname-type
))))
368 (apply #'concatenate
'simple-string
(strings)))))
370 ;; FIXME: This has been converted rather blindly from the Unix
371 ;; version, with no reference to any Windows docs what so ever.
372 (defun simplify-win32-namestring (src)
373 (declare (type simple-string src
))
374 (let* ((src-len (length src
))
375 (dst (make-string src-len
:element-type
'character
))
379 (flet ((deposit (char)
380 (setf (schar dst dst-len
) char
)
384 (dotimes (src-index src-len
)
385 (let ((char (schar src src-index
)))
386 (cond ((char= char
#\.
)
393 ;; either ``/...' or ``...//...'
395 (setf last-slash dst-len
)
398 ;; either ``./...'' or ``..././...''
403 ((and last-slash
(not (zerop last-slash
)))
404 ;; There is something before this ..
405 (let ((prev-prev-slash
406 (position-if #'slashp dst
:end last-slash
:from-end t
)))
407 (cond ((and (= (+ (or prev-prev-slash
0) 2)
409 (char= (schar dst
(- last-slash
2)) #\.
)
410 (char= (schar dst
(1- last-slash
)) #\.
))
411 ;; The something before this .. is another ..
413 (setf last-slash dst-len
))
415 ;; The something is some directory or other.
420 (setf last-slash prev-prev-slash
)))))
422 ;; There is nothing before this .., so we need to keep it
423 (setf last-slash dst-len
)
426 ;; something other than a dot between slashes
427 (setf last-slash dst-len
)
432 (setf (schar dst dst-len
) char
)
435 (when (and last-slash
(not (zerop last-slash
)))
438 ;; We've got ``foobar/.''
441 ;; We've got ``foobar/..''
442 (unless (and (>= last-slash
2)
443 (char= (schar dst
(1- last-slash
)) #\.
)
444 (char= (schar dst
(- last-slash
2)) #\.
)
446 (slashp (schar dst
(- last-slash
3)))))
447 (let ((prev-prev-slash
448 (position-if #'slashp dst
:end last-slash
:from-end t
)))
450 (setf dst-len
(1+ prev-prev-slash
))
451 (return-from simplify-win32-namestring
452 (coerce ".\\" 'simple-string
)))))))))
453 (cond ((zerop dst-len
)
458 (subseq dst
0 dst-len
)))))