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 (let* ((device (pathname-device pathname))
266 (directory (pathname-directory pathname))
267 (name (pathname-name pathname))
268 (name-present-p (typep name '(not (member nil :unspecific))))
269 (name-string (if name-present-p name ""))
270 (type (pathname-type pathname))
271 (type-present-p (typep type '(not (member nil :unspecific))))
272 (type-string (if type-present-p type "")))
276 (with-output-to-string (s)
278 (write-string device s)
281 (ecase (pop directory)
282 (:absolute (write-char #\\ s))
284 (unless directory (go :done))
286 (let ((piece (pop directory)))
288 ((member :up) (write-string ".." s))
289 (string (write-string piece s))
290 (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
292 (when (or directory (not as-file))
299 (unless (stringp name-string) ;some kind of wild field
300 (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
301 (write-string name-string s)
303 (unless (stringp type-string) ;some kind of wild field
304 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
306 (write-string type-string s)))
307 (when type-present-p ;
309 "type component without a name component in NATIVE-NAMESTRING: ~S"
314 (defun unparse-win32-enough (pathname defaults)
315 (declare (type pathname pathname defaults))
317 (error "~S cannot be represented relative to ~S."
320 (let* ((pathname-directory (%pathname-directory pathname))
321 (defaults-directory (%pathname-directory defaults))
322 (prefix-len (length defaults-directory))
324 (cond ((null pathname-directory) '(:relative))
325 ((eq (car pathname-directory) :relative)
327 ((and (> prefix-len 0)
328 (>= (length pathname-directory) prefix-len)
329 (compare-component (subseq pathname-directory
332 ;; Pathname starts with a prefix of default. So
333 ;; just use a relative directory from then on out.
334 (cons :relative (nthcdr prefix-len pathname-directory)))
335 ((eq (car pathname-directory) :absolute)
336 ;; We are an absolute pathname, so we can just use it.
339 (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
340 (strings (unparse-unix-directory-list result-directory)))
341 (let* ((pathname-type (%pathname-type pathname))
342 (type-needed (and pathname-type
343 (not (eq pathname-type :unspecific))))
344 (pathname-name (%pathname-name pathname))
345 (name-needed (or type-needed
347 (not (compare-component pathname-name
351 (unless pathname-name (lose))
352 (when (and (null pathname-type)
353 (typep pathname-name 'simple-string)
354 (position #\. pathname-name :start 1))
355 (error "too many dots in the name: ~S" pathname))
356 (strings (unparse-unix-piece pathname-name)))
358 (when (or (null pathname-type) (eq pathname-type :unspecific))
360 (when (typep pathname-type 'simple-string)
361 (when (position #\. pathname-type)
362 (error "type component can't have a #\. inside: ~S" pathname)))
364 (strings (unparse-unix-piece pathname-type))))
365 (apply #'concatenate 'simple-string (strings)))))
367 ;; FIXME: This has been converted rather blindly from the Unix
368 ;; version, with no reference to any Windows docs what so ever.
369 (defun simplify-win32-namestring (src)
370 (declare (type simple-string src))
371 (let* ((src-len (length src))
372 (dst (make-string src-len :element-type 'character))
376 (flet ((deposit (char)
377 (setf (schar dst dst-len) char)
381 (dotimes (src-index src-len)
382 (let ((char (schar src src-index)))
383 (cond ((char= char #\.)
390 ;; either ``/...' or ``...//...'
392 (setf last-slash dst-len)
395 ;; either ``./...'' or ``..././...''
400 ((and last-slash (not (zerop last-slash)))
401 ;; There is something before this ..
402 (let ((prev-prev-slash
403 (position-if #'slashp dst :end last-slash :from-end t)))
404 (cond ((and (= (+ (or prev-prev-slash 0) 2)
406 (char= (schar dst (- last-slash 2)) #\.)
407 (char= (schar dst (1- last-slash)) #\.))
408 ;; The something before this .. is another ..
410 (setf last-slash dst-len))
412 ;; The something is some directory or other.
417 (setf last-slash prev-prev-slash)))))
419 ;; There is nothing before this .., so we need to keep it
420 (setf last-slash dst-len)
423 ;; something other than a dot between slashes
424 (setf last-slash dst-len)
429 (setf (schar dst dst-len) char)
432 (when (and last-slash (not (zerop last-slash)))
435 ;; We've got ``foobar/.''
438 ;; We've got ``foobar/..''
439 (unless (and (>= last-slash 2)
440 (char= (schar dst (1- last-slash)) #\.)
441 (char= (schar dst (- last-slash 2)) #\.)
443 (slashp (schar dst (- last-slash 3)))))
444 (let ((prev-prev-slash
445 (position-if #'slashp dst :end last-slash :from-end t)))
447 (setf dst-len (1+ prev-prev-slash))
448 (return-from simplify-win32-namestring
449 (coerce ".\\" 'simple-string)))))))))
450 (cond ((zerop dst-len)
455 (subseq dst 0 dst-len)))))