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 (def!struct (win32-host
15 (:make-load-form-fun make-host-load-form)
17 (parse #'parse-win32-namestring)
18 (parse-native #'parse-native-win32-namestring)
19 (unparse #'unparse-win32-namestring)
20 (unparse-native #'unparse-native-win32-namestring)
21 (unparse-host #'unparse-win32-host)
22 (unparse-directory #'unparse-physical-directory)
23 (unparse-file #'unparse-win32-file)
24 (unparse-enough #'unparse-win32-enough)
25 (unparse-directory-separator "\\")
26 (simplify-namestring #'simplify-win32-namestring)
27 (customary-case :lower))))
29 (defvar *physical-host* (make-win32-host))
32 (define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\"))
33 (define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC"))
35 (defun extract-device (namestr start end)
36 (declare (type simple-string namestr)
37 (type index start end))
38 (if (>= end (+ start 2))
39 (let ((c0 (char namestr start))
40 (c1 (char namestr (1+ start))))
41 (cond ((and (eql c1 #\:) (alpha-char-p c0))
42 ;; "X:" style, saved as X
43 (values (string (char namestr start)) (+ start 2)))
44 ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3)))
45 ;; "//UNC" style, saved as :UNC device, with host and share
46 ;; becoming directory components.
47 (values :unc (+ start 1)))
52 (defun split-at-slashes-and-backslashes (namestr start end)
53 (declare (type simple-string namestr)
54 (type index start end))
55 ;; FIXME: There is a fundamental brokenness in using the same
56 ;; character as escape character and directory separator in
57 ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
58 ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
59 ;; (:ABSOLUTE :WILD)! See lp#673625.
60 (let ((absolute (and (/= start end)
61 (or (char= (schar namestr start) #\/)
62 (char= (schar namestr start) #\\)))))
65 ;; Next, split the remainder into slash-separated chunks.
68 (let ((slash (position-if (lambda (c)
71 namestr :start start :end end)))
72 (pieces (cons start (or slash end)))
75 (setf start (1+ slash))))
76 (values absolute (pieces)))))
78 (defun parse-win32-namestring (namestring start end)
79 (declare (type simple-string namestring)
80 (type index start end))
81 (setf namestring (coerce namestring 'simple-string))
82 (multiple-value-bind (device new-start)
83 (extract-device namestring start end)
84 (multiple-value-bind (absolute pieces)
85 (split-at-slashes-and-backslashes namestring new-start end)
86 (multiple-value-bind (name type version)
87 (let* ((tail (car (last pieces)))
88 (tail-start (car tail))
89 (tail-end (cdr tail)))
90 (unless (= tail-start tail-end)
91 (setf pieces (butlast pieces))
92 (extract-name-type-and-version namestring tail-start tail-end)))
95 (let ((position (position-if (lambda (char)
96 (or (char= char (code-char 0))
100 (error 'namestring-parse-error
101 :complaint "can't embed #\\Nul or #\\/ in Windows namestring"
102 :namestring namestring
106 ;; Deal with ~ and ~user.
108 (destructuring-bind (start . end) (car pieces)
109 (when (and (not absolute)
110 (not (eql start end))
111 (string= namestring "~"
115 (if (> end (1+ start))
116 (setf home (list :home (subseq namestring (1+ start) end)))
120 ;; Now we have everything we want. So return it.
121 (values nil ; no host for Win32 namestrings
124 (dolist (piece pieces)
125 (let ((piece-start (car piece))
126 (piece-end (cdr piece)))
127 (unless (= piece-start piece-end)
128 (cond ((string= namestring ".."
132 ((string= namestring "**"
135 (dirs :wild-inferiors))
137 (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 (error "No printed representation for a relative UNC pathname."))
222 (concatenate 'simple-string "\\\\" device)
223 (concatenate 'simple-string "//" device))))))
225 (defun unparse-win32-file (pathname)
226 (declare (type pathname pathname))
228 (let* ((name (%pathname-name pathname))
229 (type (%pathname-type pathname))
230 (type-supplied (not (or (null type) (eq type :unspecific)))))
231 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
232 ;; translating logical pathnames to a filesystem without
233 ;; versions (like Win32).
235 (when (and (null type)
238 (position #\. name :start 1))
239 (error "too many dots in the name: ~S" pathname))
240 (when (and (typep name 'string)
242 (error "name is of length 0: ~S" pathname))
243 (strings (unparse-physical-piece name)))
246 (error "cannot specify the type without a file: ~S" pathname))
247 (when (typep type 'simple-string)
248 (when (position #\. type)
249 (error "type component can't have a #\. inside: ~S" pathname)))
251 (strings (unparse-physical-piece type))))
252 (apply #'concatenate 'simple-string (strings))))
254 (defun unparse-win32-namestring (pathname)
255 (declare (type pathname pathname))
256 (concatenate 'simple-string
257 (unparse-win32-device pathname)
258 (unparse-physical-directory pathname)
259 (unparse-win32-file pathname)))
261 (defun unparse-native-win32-namestring (pathname as-file)
262 (declare (type pathname pathname))
263 (let* ((device (pathname-device pathname))
264 (directory (pathname-directory pathname))
265 (name (pathname-name pathname))
266 (name-present-p (typep name '(not (member nil :unspecific))))
267 (name-string (if name-present-p name ""))
268 (type (pathname-type pathname))
269 (type-present-p (typep type '(not (member nil :unspecific))))
270 (type-string (if type-present-p type ""))
271 (absolutep (and device (eql :absolute (car directory)))))
274 (when (and absolutep (member :up directory))
275 ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
279 (make-pathname :defaults pathname :directory '(:relative))
280 (make-pathname :defaults pathname
281 :directory (substitute :back :up directory))))))
283 (with-output-to-string (s)
285 (write-string (case device
286 (:unc +unc-file-name-prefix+)
287 (otherwise +long-file-name-prefix+)) s))
288 (when (or (not absolutep) (not (member device '(:unc nil))))
289 (write-string (unparse-win32-device pathname t) s))
291 (ecase (pop directory)
293 (let ((next (pop directory)))
294 ;; Don't use USER-HOMEDIR-NAMESTRING, since
295 ;; it can be specified as C:/User/user
296 ;; and (native-namestring (user-homedir-pathname))
297 ;; will be not equal to it, because it's parsed first.
298 (cond ((eq :home next)
299 (write-string (native-namestring (user-homedir-pathname))
301 ((and (consp next) (eq :home (car next)))
302 (let ((where (user-homedir-pathname (second next))))
304 (write-string (native-namestring where) s)
305 (error "User homedir unknown for: ~S"
307 ;; namestring of user-homedir-pathname already has
311 (push next directory))
313 (write-char #\\ s)))))
315 (loop for (piece . subdirs) on directory
317 ((member :up) (write-string ".." s))
318 (string (write-string piece s))
319 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
321 if (or subdirs (stringp name))
322 do (write-char #\\ s)
328 (unless (stringp name-string) ;some kind of wild field
329 (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
330 (write-string name-string s)
332 (unless (stringp type-string) ;some kind of wild field
333 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
335 (write-string type-string s)))
338 "type component without a name component in NATIVE-NAMESTRING: ~S"
341 (let ((string (get-output-stream-string s)))
342 (return-from unparse-native-win32-namestring
343 (cond ((< (- 260 12) (length string))
344 ;; KLUDGE: account for additional length of 8.3 name to make
345 ;; directories always accessible
346 (coerce string 'simple-string))
349 (subseq string (1- (length +unc-file-name-prefix+)))
351 (t (subseq string (length +long-file-name-prefix+))))))))
355 (defun unparse-win32-enough (pathname defaults)
356 (declare (type pathname pathname defaults))
358 (error "~S cannot be represented relative to ~S."
361 (let* ((pathname-directory (%pathname-directory pathname))
362 (defaults-directory (%pathname-directory defaults))
363 (prefix-len (length defaults-directory))
365 (cond ((null pathname-directory) '(:relative))
366 ((eq (car pathname-directory) :relative)
368 ((and (> prefix-len 0)
369 (>= (length pathname-directory) prefix-len)
370 (compare-component (subseq pathname-directory
373 ;; Pathname starts with a prefix of default. So
374 ;; just use a relative directory from then on out.
375 (cons :relative (nthcdr prefix-len pathname-directory)))
376 ((eq (car pathname-directory) :absolute)
377 ;; We are an absolute pathname, so we can just use it.
380 (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
381 (strings (unparse-physical-directory-list result-directory)))
382 (let* ((pathname-type (%pathname-type pathname))
383 (type-needed (and pathname-type
384 (not (eq pathname-type :unspecific))))
385 (pathname-name (%pathname-name pathname))
386 (name-needed (or type-needed
388 (not (compare-component pathname-name
392 (unless pathname-name (lose))
393 (when (and (null pathname-type)
394 (typep pathname-name 'simple-string)
395 (position #\. pathname-name :start 1))
396 (error "too many dots in the name: ~S" pathname))
397 (strings (unparse-physical-piece pathname-name)))
399 (when (or (null pathname-type) (eq pathname-type :unspecific))
401 (when (typep pathname-type 'simple-string)
402 (when (position #\. pathname-type)
403 (error "type component can't have a #\. inside: ~S" pathname)))
405 (strings (unparse-physical-piece pathname-type))))
406 (apply #'concatenate 'simple-string (strings)))))
408 ;; FIXME: This has been converted rather blindly from the Unix
409 ;; version, with no reference to any Windows docs what so ever.
410 (defun simplify-win32-namestring (src)
411 (declare (type simple-string src))
412 (let* ((src-len (length src))
413 (dst (make-string src-len :element-type 'character))
417 (flet ((deposit (char)
418 (setf (schar dst dst-len) char)
422 (dotimes (src-index src-len)
423 (let ((char (schar src src-index)))
424 (cond ((char= char #\.)
431 ;; either ``/...' or ``...//...'
433 (setf last-slash dst-len)
436 ;; either ``./...'' or ``..././...''
441 ((and last-slash (not (zerop last-slash)))
442 ;; There is something before this ..
443 (let ((prev-prev-slash
444 (position-if #'slashp dst :end last-slash :from-end t)))
445 (cond ((and (= (+ (or prev-prev-slash 0) 2)
447 (char= (schar dst (- last-slash 2)) #\.)
448 (char= (schar dst (1- last-slash)) #\.))
449 ;; The something before this .. is another ..
451 (setf last-slash dst-len))
453 ;; The something is some directory or other.
458 (setf last-slash prev-prev-slash)))))
460 ;; There is nothing before this .., so we need to keep it
461 (setf last-slash dst-len)
464 ;; something other than a dot between slashes
465 (setf last-slash dst-len)
470 (setf (schar dst dst-len) char)
473 (when (and last-slash (not (zerop last-slash)))
476 ;; We've got ``foobar/.''
479 ;; We've got ``foobar/..''
480 (unless (and (>= last-slash 2)
481 (char= (schar dst (1- last-slash)) #\.)
482 (char= (schar dst (- last-slash 2)) #\.)
484 (slashp (schar dst (- last-slash 3)))))
485 (let ((prev-prev-slash
486 (position-if #'slashp dst :end last-slash :from-end t)))
488 (setf dst-len (1+ prev-prev-slash))
489 (return-from simplify-win32-namestring
490 (coerce ".\\" 'simple-string)))))))))
491 (cond ((zerop dst-len)
496 (subseq dst 0 dst-len)))))