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 (defstruct (win32-host
16 (parse #'parse-win32-namestring
)
17 (parse-native #'parse-native-win32-namestring
)
18 (unparse #'unparse-win32-namestring
)
19 (unparse-native #'unparse-native-win32-namestring
)
20 (unparse-host #'unparse-win32-host
)
21 (unparse-directory #'unparse-win32-directory
)
22 (unparse-file #'unparse-win32-file
)
23 (unparse-enough #'unparse-win32-enough
)
24 (unparse-directory-separator "\\")
25 (simplify-namestring #'simplify-win32-namestring
)
26 (customary-case :lower
))))
28 (setq *physical-host
* (make-win32-host))
31 (define-symbol-macro +long-file-name-prefix
+ (quote "\\\\?\\"))
32 (define-symbol-macro +unc-file-name-prefix
+ (quote "\\\\?\\UNC"))
34 (defun extract-device (namestr start end
)
35 (declare (type simple-string namestr
)
36 (type index start end
))
37 (if (>= end
(+ start
2))
38 (let ((c0 (char namestr start
))
39 (c1 (char namestr
(1+ start
))))
40 (cond ((and (eql c1
#\
:) (alpha-char-p c0
))
41 ;; "X:" style, saved as X
42 (values (string (char namestr start
)) (+ start
2)))
43 ((and (member c0
'(#\
/ #\\)) (eql c0 c1
) (>= end
(+ start
3)))
44 ;; "//UNC" style, saved as :UNC device, with host and share
45 ;; becoming directory components.
46 (values :unc
(+ start
1)))
51 (defun split-at-slashes-and-backslashes (namestr start end
)
52 (declare (type simple-string namestr
)
53 (type index start end
))
54 ;; FIXME: There is a fundamental brokenness in using the same
55 ;; character as escape character and directory separator in
56 ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
57 ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
58 ;; (:ABSOLUTE :WILD)! See lp#673625.
59 (let ((absolute (and (/= start end
)
60 (or (char= (schar namestr start
) #\
/)
61 (char= (schar namestr start
) #\\)))))
64 ;; Next, split the remainder into slash-separated chunks.
67 (let ((slash (position-if (lambda (c)
70 namestr
:start start
:end end
)))
71 (pieces (cons start
(or slash end
)))
74 (setf start
(1+ slash
))))
75 (values absolute
(pieces)))))
77 (defun parse-win32-namestring (namestring start end
)
78 (declare (type simple-string namestring
)
79 (type index start end
))
80 (setf namestring
(coerce namestring
'simple-string
))
81 (multiple-value-bind (device new-start
)
82 (extract-device namestring start end
)
83 (multiple-value-bind (absolute pieces
)
84 (split-at-slashes-and-backslashes namestring new-start end
)
85 (multiple-value-bind (name type version
)
86 (let* ((tail (car (last pieces
)))
87 (tail-start (car tail
))
88 (tail-end (cdr tail
)))
89 (unless (= tail-start tail-end
)
90 (setf pieces
(butlast pieces
))
91 (extract-name-type-and-version namestring tail-start tail-end
#\^
)))
94 (let ((position (position-if (lambda (char)
95 (or (char= char
(code-char 0))
99 (error 'namestring-parse-error
100 :complaint
"can't embed #\\Nul or #\\/ in Windows namestring"
101 :namestring namestring
105 ;; Deal with ~ and ~user.
107 (destructuring-bind (start . end
) (car pieces
)
108 (when (and (not absolute
)
109 (not (eql start end
))
110 (string= namestring
"~"
114 (if (> end
(1+ start
))
115 (setf home
(list :home
(subseq namestring
(1+ start
) end
)))
119 ;; Now we have everything we want. So return it.
120 (values nil
; no host for Win32 namestrings
123 (dolist (piece pieces
)
124 (let ((piece-start (car piece
))
125 (piece-end (cdr piece
)))
126 (unless (= piece-start piece-end
)
127 (cond ((string= namestring
".."
131 ((string= namestring
"**"
134 (dirs :wild-inferiors
))
136 (dirs (maybe-make-pattern namestring
142 (list* :absolute home
(dirs))
143 (cons :absolute
(dirs))))
145 (cons :relative
(dirs)))
152 (defun parse-native-win32-namestring (namestring start end as-directory
)
153 (declare (type simple-string namestring
)
154 (type index start end
))
155 (setf namestring
(coerce namestring
'simple-string
))
156 (multiple-value-bind (device new-start
)
157 (cond ((= (length +unc-file-name-prefix
+)
158 (mismatch +unc-file-name-prefix
+ namestring
160 (values :unc
(+ start
(length +unc-file-name-prefix
+))))
161 ((= (length +long-file-name-prefix
+)
162 (mismatch +long-file-name-prefix
+ namestring
164 (extract-device namestring
165 (+ start
(length +long-file-name-prefix
+))
167 (t (extract-device namestring start end
)))
168 (multiple-value-bind (absolute ranges
)
169 (split-at-slashes-and-backslashes namestring new-start end
)
170 (let* ((components (loop for
((start . end
) . rest
) on ranges
171 for piece
= (subseq namestring start end
)
172 collect
(if (and (string= piece
"..") rest
)
175 (directory (if (and as-directory
176 (string/= "" (car (last components
))))
178 (butlast components
)))
181 (let* ((end (first (last components
)))
182 (dot (position #\. end
:from-end t
)))
183 ;; FIXME: can we get this dot-interpretation knowledge
184 ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
185 ;; does slightly more work than that.
190 (list (subseq end
0 dot
) (subseq end
(1+ dot
))))
195 (cons (if absolute
:absolute
:relative
) directory
)
196 (first name-and-type
)
197 (second name-and-type
)
202 (defun unparse-win32-host (pathname)
203 (declare (type pathname pathname
)
205 ;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good.
208 (defun unparse-win32-device (pathname &optional native
)
209 (declare (type pathname pathname
))
210 (let ((device (pathname-device pathname
))
211 (directory (pathname-directory pathname
)))
212 (cond ((or (null device
) (eq device
:unspecific
))
215 (if native
"\\" "/"))
216 ((and (= 1 (length device
)) (alpha-char-p (char device
0)))
217 (concatenate 'simple-string device
":"))
218 ((and (consp directory
) (eq :relative
(car directory
)))
219 (no-native-namestring-error
221 "there is no printed representation for a relative UNC pathname"))
224 (concatenate 'simple-string
"\\\\" device
)
225 (concatenate 'simple-string
"//" device
))))))
227 (defun unparse-win32-directory (pathname)
228 (unparse-physical-directory pathname
#\^
))
230 (defun unparse-win32-file (pathname)
231 (declare (type pathname pathname
))
232 (unparse-physical-file pathname
#\^
))
234 (defun unparse-win32-namestring (pathname)
235 (declare (type pathname pathname
))
236 (concatenate 'simple-string
237 (unparse-win32-device pathname
)
238 (unparse-physical-directory pathname
#\^
)
239 (unparse-physical-file pathname
#\^
)))
241 (defun unparse-native-win32-namestring (pathname as-file
)
242 (declare (type pathname pathname
))
243 (let* ((device (pathname-device pathname
))
244 (devicep (not (member device
'(:unc nil
))))
245 (directory (pathname-directory pathname
))
246 (absolutep (and device
(eql :absolute
(car directory
))))
247 (seperator-after-directory-p
248 (or (pathname-component-present-p (pathname-name pathname
))
250 (when (and absolutep
(member :up directory
))
251 ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
255 (make-pathname :defaults pathname
:directory
'(:relative
))
256 (make-pathname :defaults pathname
257 :directory
(substitute :back
:up directory
))))))
259 (with-simple-output-to-string (s)
262 (write-string (case device
263 (:unc
+unc-file-name-prefix
+)
264 (otherwise +long-file-name-prefix
+))
267 (write-string (unparse-win32-device pathname t
) s
)))
269 (ecase (pop directory
)
271 (let ((next (pop directory
)))
273 ((typep next
'(or (eql :home
) (cons (eql :home
))))
274 (let* ((username (when (consp next
) (second next
)))
277 (parse-native-namestring
278 (user-homedir-namestring username
))
279 (user-homedir-pathname))
281 (error "User homedir unknown~@[ for ~S~]: ~A."
282 username condition
)))))
283 (when (and (or absolutep devicep
)
284 (not (string-equal device
(pathname-device home
))))
285 (error "Device in homedir ~S conflicts which device ~S"
287 (write-string (native-namestring home
) s
)))
288 ;; namestring of user-homedir-pathname already has
292 (push next directory
))
294 (write-char #\\ s
)))))
296 (loop for
(piece . subdirs
) on directory
298 ((member :up
:back
) (write-string ".." s
))
299 (string (write-string piece s
))
300 (t (error "Bad directory segment in NATIVE-NAMESTRING: ~S."
302 when
(or subdirs seperator-after-directory-p
)
303 do
(write-char #\\ s
))
304 (write-string (unparse-native-physical-file pathname
) s
)
306 (let ((string (get-output-stream-string s
)))
307 (return-from unparse-native-win32-namestring
308 (cond ((< (- 260 12) (length string
))
309 ;; KLUDGE: account for additional length of 8.3 name to make
310 ;; directories always accessible
311 (coerce string
'simple-string
))
314 (subseq string
(1- (length +unc-file-name-prefix
+)))
316 (t (subseq string
(length +long-file-name-prefix
+))))))))
320 (defun unparse-win32-enough (pathname defaults
)
321 (declare (type pathname pathname defaults
))
323 (error "~S cannot be represented relative to ~S."
326 (let* ((pathname-directory (%pathname-directory pathname
))
327 (defaults-directory (%pathname-directory defaults
))
328 (prefix-len (length defaults-directory
))
330 (cond ((null pathname-directory
) '(:relative
))
331 ((eq (car pathname-directory
) :relative
)
333 ((and (> prefix-len
0)
334 (>= (length pathname-directory
) prefix-len
)
335 (compare-component (subseq pathname-directory
338 ;; Pathname starts with a prefix of default. So
339 ;; just use a relative directory from then on out.
340 (cons :relative
(nthcdr prefix-len pathname-directory
)))
341 ((eq (car pathname-directory
) :absolute
)
342 ;; We are an absolute pathname, so we can just use it.
345 (bug "Bad fallthrough in ~S" 'unparse-unix-enough
)))))
346 (strings (unparse-physical-directory-list result-directory
#\^
)))
347 (let* ((pathname-type (%pathname-type pathname
))
348 (type-needed (and pathname-type
349 (not (eq pathname-type
:unspecific
))))
350 (pathname-name (%pathname-name pathname
))
351 (name-needed (or type-needed
353 (not (compare-component pathname-name
357 (unless pathname-name
(lose))
358 (when (and (null pathname-type
)
359 (typep pathname-name
'simple-string
)
360 (position #\. pathname-name
:start
1))
361 (error "too many dots in the name: ~S" pathname
))
362 (strings (unparse-physical-piece pathname-name
#\^
)))
364 (when (or (null pathname-type
) (eq pathname-type
:unspecific
))
366 (when (typep pathname-type
'simple-string
)
367 (when (position #\. pathname-type
)
368 (error "type component can't have a #\. inside: ~S" pathname
)))
370 (strings (unparse-physical-piece pathname-type
#\^
))))
371 (apply #'concatenate
'simple-string
(strings)))))
373 ;; FIXME: This has been converted rather blindly from the Unix
374 ;; version, with no reference to any Windows docs what so ever.
375 (defun simplify-win32-namestring (src)
376 (declare (type simple-string src
))
377 (let* ((src-len (length src
))
378 (dst (make-string src-len
:element-type
'character
))
382 (flet ((deposit (char)
383 (setf (schar dst dst-len
) char
)
387 (dotimes (src-index src-len
)
388 (let ((char (schar src src-index
)))
389 (cond ((char= char
#\.
)
396 ;; either ``/...' or ``...//...'
398 (setf last-slash dst-len
)
401 ;; either ``./...'' or ``..././...''
406 ((and last-slash
(not (zerop last-slash
)))
407 ;; There is something before this ..
408 (let ((prev-prev-slash
409 (position-if #'slashp dst
:end last-slash
:from-end t
)))
410 (cond ((and (= (+ (or prev-prev-slash
0) 2)
412 (char= (schar dst
(- last-slash
2)) #\.
)
413 (char= (schar dst
(1- last-slash
)) #\.
))
414 ;; The something before this .. is another ..
416 (setf last-slash dst-len
))
418 ;; The something is some directory or other.
423 (setf last-slash prev-prev-slash
)))))
425 ;; There is nothing before this .., so we need to keep it
426 (setf last-slash dst-len
)
429 ;; something other than a dot between slashes
430 (setf last-slash dst-len
)
435 (setf (schar dst dst-len
) char
)
438 (when (and last-slash
(not (zerop last-slash
)))
441 ;; We've got ``foobar/.''
444 ;; We've got ``foobar/..''
445 (unless (and (>= last-slash
2)
446 (char= (schar dst
(1- last-slash
)) #\.
)
447 (char= (schar dst
(- last-slash
2)) #\.
)
449 (slashp (schar dst
(- last-slash
3)))))
450 (let ((prev-prev-slash
451 (position-if #'slashp dst
:end last-slash
:from-end t
)))
453 (setf dst-len
(1+ prev-prev-slash
))
454 (return-from simplify-win32-namestring
455 (coerce ".\\" 'simple-string
)))))))))
456 (cond ((zerop dst-len
)
461 (subseq dst
0 dst-len
)))))