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 (>= end (+ start 2))
18 (let ((c0 (char namestr start))
19 (c1 (char namestr (1+ start))))
20 (cond ((and (eql c1 #\:) (alpha-char-p c0))
21 ;; "X:" style, saved as X
22 (values (string (char namestr start)) (+ start 2)))
23 ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3)))
24 ;; "//UNC" style, saved as UNC
25 ;; FIXME: at unparsing time we tell these apart by length,
26 ;; which seems a bit lossy -- presumably one-letter UNC
27 ;; hosts can exist as well. That seems a less troublesome
28 ;; restriction than disallowing UNC hosts whose names match
29 ;; logical pathname hosts... Time will tell -- both LispWorks
30 ;; and ACL use the host component for UNC hosts, so maybe
31 ;; we will end up there as well.
32 (let ((p (or (position c0 namestr :start (+ start 3) :end end)
34 (values (subseq namestr (+ start 2) p) p)))
39 (defun split-at-slashes-and-backslashes (namestr start end)
40 (declare (type simple-string namestr)
41 (type index start end))
42 (let ((absolute (and (/= start end)
43 (or (char= (schar namestr start) #\/)
44 (char= (schar namestr start) #\\)))))
47 ;; Next, split the remainder into slash-separated chunks.
50 (let ((slash (position-if (lambda (c)
53 namestr :start start :end end)))
54 (pieces (cons start (or slash end)))
57 (setf start (1+ slash))))
58 (values absolute (pieces)))))
60 (defun parse-win32-namestring (namestring start end)
61 (declare (type simple-string namestring)
62 (type index start end))
63 (setf namestring (coerce namestring 'simple-string))
64 (multiple-value-bind (device new-start)
65 (extract-device namestring start end)
66 (multiple-value-bind (absolute pieces)
67 (split-at-slashes-and-backslashes namestring new-start end)
68 (multiple-value-bind (name type version)
69 (let* ((tail (car (last pieces)))
70 (tail-start (car tail))
71 (tail-end (cdr tail)))
72 (unless (= tail-start tail-end)
73 (setf pieces (butlast pieces))
74 (extract-name-type-and-version namestring tail-start tail-end)))
77 (let ((position (position-if (lambda (char)
78 (or (char= char (code-char 0))
82 (error 'namestring-parse-error
83 :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
84 :namestring namestring
86 ;; Now we have everything we want. So return it.
87 (values nil ; no host for Win32 namestrings
90 (dolist (piece pieces)
91 (let ((piece-start (car piece))
92 (piece-end (cdr piece)))
93 (unless (= piece-start piece-end)
94 (cond ((string= namestring ".."
98 ((string= namestring "**"
101 (dirs :wild-inferiors))
103 (dirs (maybe-make-pattern namestring
107 (cons :absolute (dirs)))
109 (cons :relative (dirs)))
116 (defun parse-native-win32-namestring (namestring start end as-directory)
117 (declare (type simple-string namestring)
118 (type index start end))
119 (setf namestring (coerce namestring 'simple-string))
120 (multiple-value-bind (device new-start)
121 (extract-device namestring start end)
122 (multiple-value-bind (absolute ranges)
123 (split-at-slashes-and-backslashes namestring new-start end)
124 (let* ((components (loop for ((start . end) . rest) on ranges
125 for piece = (subseq namestring start end)
126 collect (if (and (string= piece "..") rest)
129 (directory (if (and as-directory
130 (string/= "" (car (last components))))
132 (butlast components)))
135 (let* ((end (first (last components)))
136 (dot (position #\. end :from-end t)))
137 ;; FIXME: can we get this dot-interpretation knowledge
138 ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
139 ;; does slightly more work than that.
144 (list (subseq end 0 dot) (subseq end (1+ dot))))
149 (cons (if absolute :absolute :relative) directory)
150 (first name-and-type)
151 (second name-and-type)
156 (defun unparse-win32-host (pathname)
157 (declare (type pathname pathname)
159 ;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good.
162 (defun unparse-win32-device (pathname &optional native)
163 (declare (type pathname pathname))
164 (let ((device (pathname-device pathname))
165 (directory (pathname-directory pathname)))
166 (cond ((or (null device) (eq device :unspecific))
168 ((and (= 1 (length device)) (alpha-char-p (char device 0)))
169 (concatenate 'simple-string device ":"))
170 ((and (consp directory) (eq :relative (car directory)))
171 (error "No printed representation for a relative UNC pathname."))
174 (concatenate 'simple-string "\\\\" device)
175 (concatenate 'simple-string "//" device))))))
177 (defun unparse-win32-file (pathname)
178 (declare (type pathname pathname))
180 (let* ((name (%pathname-name pathname))
181 (type (%pathname-type pathname))
182 (type-supplied (not (or (null type) (eq type :unspecific)))))
183 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
184 ;; translating logical pathnames to a filesystem without
185 ;; versions (like Win32).
187 (when (and (null type)
190 (position #\. name :start 1))
191 (error "too many dots in the name: ~S" pathname))
192 (when (and (typep name 'string)
194 (error "name is of length 0: ~S" pathname))
195 (strings (unparse-physical-piece name)))
198 (error "cannot specify the type without a file: ~S" pathname))
199 (when (typep type 'simple-string)
200 (when (position #\. type)
201 (error "type component can't have a #\. inside: ~S" pathname)))
203 (strings (unparse-physical-piece type))))
204 (apply #'concatenate 'simple-string (strings))))
206 (defun unparse-win32-namestring (pathname)
207 (declare (type pathname pathname))
208 (concatenate 'simple-string
209 (unparse-win32-device pathname)
210 (unparse-physical-directory pathname)
211 (unparse-win32-file pathname)))
213 (defun unparse-native-win32-namestring (pathname as-file)
214 (declare (type pathname pathname))
215 (let* ((device (pathname-device pathname))
216 (directory (pathname-directory pathname))
217 (name (pathname-name pathname))
218 (name-present-p (typep name '(not (member nil :unspecific))))
219 (name-string (if name-present-p name ""))
220 (type (pathname-type pathname))
221 (type-present-p (typep type '(not (member nil :unspecific))))
222 (type-string (if type-present-p type "")))
226 (with-output-to-string (s)
228 (write-string (unparse-win32-device pathname t) s))
230 (ecase (car directory)
231 (:absolute (write-char #\\ s))
233 (loop for (piece . subdirs) on (cdr directory)
235 ((member :up) (write-string ".." s))
236 (string (write-string piece s))
237 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
239 if (or subdirs (stringp name))
240 do (write-char #\\ s)
246 (unless (stringp name-string) ;some kind of wild field
247 (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
248 (write-string name-string s)
250 (unless (stringp type-string) ;some kind of wild field
251 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
253 (write-string type-string s)))
254 (when type-present-p ;
256 "type component without a name component in NATIVE-NAMESTRING: ~S"
261 (defun unparse-win32-enough (pathname defaults)
262 (declare (type pathname pathname defaults))
264 (error "~S cannot be represented relative to ~S."
267 (let* ((pathname-directory (%pathname-directory pathname))
268 (defaults-directory (%pathname-directory defaults))
269 (prefix-len (length defaults-directory))
271 (cond ((null pathname-directory) '(:relative))
272 ((eq (car pathname-directory) :relative)
274 ((and (> prefix-len 0)
275 (>= (length pathname-directory) prefix-len)
276 (compare-component (subseq pathname-directory
279 ;; Pathname starts with a prefix of default. So
280 ;; just use a relative directory from then on out.
281 (cons :relative (nthcdr prefix-len pathname-directory)))
282 ((eq (car pathname-directory) :absolute)
283 ;; We are an absolute pathname, so we can just use it.
286 (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
287 (strings (unparse-physical-directory-list result-directory)))
288 (let* ((pathname-type (%pathname-type pathname))
289 (type-needed (and pathname-type
290 (not (eq pathname-type :unspecific))))
291 (pathname-name (%pathname-name pathname))
292 (name-needed (or type-needed
294 (not (compare-component pathname-name
298 (unless pathname-name (lose))
299 (when (and (null pathname-type)
300 (typep pathname-name 'simple-string)
301 (position #\. pathname-name :start 1))
302 (error "too many dots in the name: ~S" pathname))
303 (strings (unparse-physical-piece pathname-name)))
305 (when (or (null pathname-type) (eq pathname-type :unspecific))
307 (when (typep pathname-type 'simple-string)
308 (when (position #\. pathname-type)
309 (error "type component can't have a #\. inside: ~S" pathname)))
311 (strings (unparse-physical-piece pathname-type))))
312 (apply #'concatenate 'simple-string (strings)))))
314 ;; FIXME: This has been converted rather blindly from the Unix
315 ;; version, with no reference to any Windows docs what so ever.
316 (defun simplify-win32-namestring (src)
317 (declare (type simple-string src))
318 (let* ((src-len (length src))
319 (dst (make-string src-len :element-type 'character))
323 (flet ((deposit (char)
324 (setf (schar dst dst-len) char)
328 (dotimes (src-index src-len)
329 (let ((char (schar src src-index)))
330 (cond ((char= char #\.)
337 ;; either ``/...' or ``...//...'
339 (setf last-slash dst-len)
342 ;; either ``./...'' or ``..././...''
347 ((and last-slash (not (zerop last-slash)))
348 ;; There is something before this ..
349 (let ((prev-prev-slash
350 (position-if #'slashp dst :end last-slash :from-end t)))
351 (cond ((and (= (+ (or prev-prev-slash 0) 2)
353 (char= (schar dst (- last-slash 2)) #\.)
354 (char= (schar dst (1- last-slash)) #\.))
355 ;; The something before this .. is another ..
357 (setf last-slash dst-len))
359 ;; The something is some directory or other.
364 (setf last-slash prev-prev-slash)))))
366 ;; There is nothing before this .., so we need to keep it
367 (setf last-slash dst-len)
370 ;; something other than a dot between slashes
371 (setf last-slash dst-len)
376 (setf (schar dst dst-len) char)
379 (when (and last-slash (not (zerop last-slash)))
382 ;; We've got ``foobar/.''
385 ;; We've got ``foobar/..''
386 (unless (and (>= last-slash 2)
387 (char= (schar dst (1- last-slash)) #\.)
388 (char= (schar dst (- last-slash 2)) #\.)
390 (slashp (schar dst (- last-slash 3)))))
391 (let ((prev-prev-slash
392 (position-if #'slashp dst :end last-slash :from-end t)))
394 (setf dst-len (1+ prev-prev-slash))
395 (return-from simplify-win32-namestring
396 (coerce ".\\" 'simple-string)))))))))
397 (cond ((zerop dst-len)
402 (subseq dst 0 dst-len)))))