1.0.48.13: SET-SYNTAX-FROM-CHAR and dispatch-macro characterness
[sbcl.git] / src / code / win32-pathname.lisp
1 ;;;; pathname parsing for Win32 filesystems
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!IMPL")
13
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)
33                             end)))
34                  (values (subseq namestr (+ start 2) p) p)))
35               (t
36                (values nil start))))
37       (values nil start)))
38
39 (defun split-at-slashes-and-backslashes (namestr start end)
40   (declare (type simple-string namestr)
41            (type index start end))
42   ;; FIXME: There is a fundamental brokenness in using the same
43   ;; character as escape character and directory separator in
44   ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
45   ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
46   ;; (:ABSOLUTE :WILD)! See lp#673625.
47   (let ((absolute (and (/= start end)
48                        (or (char= (schar namestr start) #\/)
49                            (char= (schar namestr start) #\\)))))
50     (when absolute
51       (incf start))
52     ;; Next, split the remainder into slash-separated chunks.
53     (collect ((pieces))
54       (loop
55          (let ((slash (position-if (lambda (c)
56                                      (or (char= c #\/)
57                                          (char= c #\\)))
58                                    namestr :start start :end end)))
59            (pieces (cons start (or slash end)))
60            (unless slash
61              (return))
62            (setf start (1+ slash))))
63       (values absolute (pieces)))))
64
65 (defun parse-win32-namestring (namestring start end)
66   (declare (type simple-string namestring)
67            (type index start end))
68   (setf namestring (coerce namestring 'simple-string))
69   (multiple-value-bind (device new-start)
70       (extract-device namestring start end)
71     (multiple-value-bind (absolute pieces)
72         (split-at-slashes-and-backslashes namestring new-start end)
73       (multiple-value-bind (name type version)
74           (let* ((tail (car (last pieces)))
75                  (tail-start (car tail))
76                  (tail-end (cdr tail)))
77             (unless (= tail-start tail-end)
78               (setf pieces (butlast pieces))
79               (extract-name-type-and-version namestring tail-start tail-end)))
80
81         (when (stringp name)
82           (let ((position (position-if (lambda (char)
83                                          (or (char= char (code-char 0))
84                                              (char= char #\/)))
85                                        name)))
86             (when position
87               (error 'namestring-parse-error
88                      :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
89                      :namestring namestring
90                      :offset position))))
91
92         (let (home)
93           ;; Deal with ~ and ~user.
94           (when (car pieces)
95             (destructuring-bind (start . end) (car pieces)
96               (when (and (not absolute)
97                          (not (eql start end))
98                          (string= namestring "~"
99                                   :start1 start
100                                   :end1 (1+ start)))
101                 (setf absolute t)
102                 (if (> end (1+ start))
103                     (setf home (list :home (subseq namestring (1+ start) end)))
104                     (setf home :home))
105                 (pop pieces))))
106
107           ;; Now we have everything we want. So return it.
108           (values nil                 ; no host for Win32 namestrings
109                   device
110                   (collect ((dirs))
111                     (dolist (piece pieces)
112                       (let ((piece-start (car piece))
113                             (piece-end (cdr piece)))
114                         (unless (= piece-start piece-end)
115                           (cond ((string= namestring ".."
116                                           :start1 piece-start
117                                           :end1 piece-end)
118                                  (dirs :up))
119                                 ((string= namestring "**"
120                                           :start1 piece-start
121                                           :end1 piece-end)
122                                  (dirs :wild-inferiors))
123                                 (t
124                                  (dirs (maybe-make-pattern namestring
125                                                            piece-start
126                                                            piece-end)))))))
127                     (cond (absolute
128                            (if home
129                                (list* :absolute home (dirs))
130                                (cons :absolute (dirs))))
131                           ((dirs)
132                            (cons :relative (dirs)))
133                           (t
134                            nil)))
135                   name
136                   type
137                   version))))))
138
139 (defun parse-native-win32-namestring (namestring start end as-directory)
140   (declare (type simple-string namestring)
141            (type index start end))
142   (setf namestring (coerce namestring 'simple-string))
143   (multiple-value-bind (device new-start)
144       (extract-device namestring start end)
145     (multiple-value-bind (absolute ranges)
146         (split-at-slashes-and-backslashes namestring new-start end)
147       (let* ((components (loop for ((start . end) . rest) on ranges
148                                for piece = (subseq namestring start end)
149                                collect (if (and (string= piece "..") rest)
150                                            :up
151                                            piece)))
152              (directory (if (and as-directory
153                                  (string/= "" (car (last components))))
154                             components
155                             (butlast components)))
156              (name-and-type
157               (unless as-directory
158                 (let* ((end (first (last components)))
159                        (dot (position #\. end :from-end t)))
160                   ;; FIXME: can we get this dot-interpretation knowledge
161                   ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
162                   ;; does slightly more work than that.
163                   (cond
164                     ((string= end "")
165                      (list nil nil))
166                     ((and dot (> dot 0))
167                      (list (subseq end 0 dot) (subseq end (1+ dot))))
168                     (t
169                      (list end nil)))))))
170         (values nil
171                 device
172                 (cons (if absolute :absolute :relative) directory)
173                 (first name-and-type)
174                 (second name-and-type)
175                 nil)))))
176
177
178
179 (defun unparse-win32-host (pathname)
180   (declare (type pathname pathname)
181            (ignore pathname))
182   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
183   "")
184
185 (defun unparse-win32-device (pathname &optional native)
186   (declare (type pathname pathname))
187   (let ((device (pathname-device pathname))
188         (directory (pathname-directory pathname)))
189     (cond ((or (null device) (eq device :unspecific))
190            "")
191           ((and (= 1 (length device)) (alpha-char-p (char device 0)))
192            (concatenate 'simple-string device ":"))
193           ((and (consp directory) (eq :relative (car directory)))
194            (error "No printed representation for a relative UNC pathname."))
195           (t
196            (if native
197                (concatenate 'simple-string "\\\\" device)
198                (concatenate 'simple-string "//" device))))))
199
200 (defun unparse-win32-file (pathname)
201   (declare (type pathname pathname))
202   (collect ((strings))
203     (let* ((name (%pathname-name pathname))
204            (type (%pathname-type pathname))
205            (type-supplied (not (or (null type) (eq type :unspecific)))))
206       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
207       ;; translating logical pathnames to a filesystem without
208       ;; versions (like Win32).
209       (when name
210         (when (and (null type)
211                    (typep name 'string)
212                    (> (length name) 0)
213                    (position #\. name :start 1))
214           (error "too many dots in the name: ~S" pathname))
215         (when (and (typep name 'string)
216                    (string= name ""))
217           (error "name is of length 0: ~S" pathname))
218         (strings (unparse-physical-piece name)))
219       (when type-supplied
220         (unless name
221           (error "cannot specify the type without a file: ~S" pathname))
222         (when (typep type 'simple-string)
223           (when (position #\. type)
224             (error "type component can't have a #\. inside: ~S" pathname)))
225         (strings ".")
226         (strings (unparse-physical-piece type))))
227     (apply #'concatenate 'simple-string (strings))))
228
229 (defun unparse-win32-namestring (pathname)
230   (declare (type pathname pathname))
231   (concatenate 'simple-string
232                (unparse-win32-device pathname)
233                (unparse-physical-directory pathname)
234                (unparse-win32-file pathname)))
235
236 (defun unparse-native-win32-namestring (pathname as-file)
237   (declare (type pathname pathname))
238   (let* ((device (pathname-device pathname))
239          (directory (pathname-directory pathname))
240          (name (pathname-name pathname))
241          (name-present-p (typep name '(not (member nil :unspecific))))
242          (name-string (if name-present-p name ""))
243          (type (pathname-type pathname))
244          (type-present-p (typep type '(not (member nil :unspecific))))
245          (type-string (if type-present-p type "")))
246     (when name-present-p
247       (setf as-file nil))
248     (coerce
249      (with-output-to-string (s)
250        (when device
251          (write-string (unparse-win32-device pathname t) s))
252        (when directory
253          (ecase (pop directory)
254            (:absolute
255             (let ((next (pop directory)))
256               (cond ((eq :home next)
257                      (write-string (user-homedir-namestring) s))
258                     ((and (consp next) (eq :home (car next)))
259                      (let ((where (user-homedir-namestring (second next))))
260                        (if where
261                            (write-string where s)
262                            (error "User homedir unknown for: ~S" (second next)))))
263                     (next
264                      (push next directory)))
265               (write-char #\\ s)))
266            (:relative)))
267        (loop for (piece . subdirs) on directory
268           do (typecase piece
269                ((member :up) (write-string ".." s))
270                (string (write-string piece s))
271                (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
272                          piece)))
273           if (or subdirs (stringp name))
274           do (write-char #\\ s)
275           else
276           do (unless as-file
277                (write-char #\\ s)))
278        (if name-present-p
279            (progn
280              (unless (stringp name-string) ;some kind of wild field
281                (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
282              (write-string name-string s)
283              (when type-present-p
284                (unless (stringp type-string) ;some kind of wild field
285                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
286                (write-char #\. s)
287                (write-string type-string s)))
288            (when type-present-p ;
289              (error
290               "type component without a name component in NATIVE-NAMESTRING: ~S"
291               type))))
292      'simple-string)))
293
294 ;;; FIXME.
295 (defun unparse-win32-enough (pathname defaults)
296   (declare (type pathname pathname defaults))
297   (flet ((lose ()
298            (error "~S cannot be represented relative to ~S."
299                   pathname defaults)))
300     (collect ((strings))
301       (let* ((pathname-directory (%pathname-directory pathname))
302              (defaults-directory (%pathname-directory defaults))
303              (prefix-len (length defaults-directory))
304              (result-directory
305               (cond ((null pathname-directory) '(:relative))
306                     ((eq (car pathname-directory) :relative)
307                      pathname-directory)
308                     ((and (> prefix-len 0)
309                           (>= (length pathname-directory) prefix-len)
310                           (compare-component (subseq pathname-directory
311                                                      0 prefix-len)
312                                              defaults-directory))
313                      ;; Pathname starts with a prefix of default. So
314                      ;; just use a relative directory from then on out.
315                      (cons :relative (nthcdr prefix-len pathname-directory)))
316                     ((eq (car pathname-directory) :absolute)
317                      ;; We are an absolute pathname, so we can just use it.
318                      pathname-directory)
319                     (t
320                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
321         (strings (unparse-physical-directory-list result-directory)))
322       (let* ((pathname-type (%pathname-type pathname))
323              (type-needed (and pathname-type
324                                (not (eq pathname-type :unspecific))))
325              (pathname-name (%pathname-name pathname))
326              (name-needed (or type-needed
327                               (and pathname-name
328                                    (not (compare-component pathname-name
329                                                            (%pathname-name
330                                                             defaults)))))))
331         (when name-needed
332           (unless pathname-name (lose))
333           (when (and (null pathname-type)
334                      (typep pathname-name 'simple-string)
335                      (position #\. pathname-name :start 1))
336             (error "too many dots in the name: ~S" pathname))
337           (strings (unparse-physical-piece pathname-name)))
338         (when type-needed
339           (when (or (null pathname-type) (eq pathname-type :unspecific))
340             (lose))
341           (when (typep pathname-type 'simple-string)
342             (when (position #\. pathname-type)
343               (error "type component can't have a #\. inside: ~S" pathname)))
344           (strings ".")
345           (strings (unparse-physical-piece pathname-type))))
346       (apply #'concatenate 'simple-string (strings)))))
347
348 ;; FIXME: This has been converted rather blindly from the Unix
349 ;; version, with no reference to any Windows docs what so ever.
350 (defun simplify-win32-namestring (src)
351   (declare (type simple-string src))
352   (let* ((src-len (length src))
353          (dst (make-string src-len :element-type 'character))
354          (dst-len 0)
355          (dots 0)
356          (last-slash nil))
357     (flet ((deposit (char)
358              (setf (schar dst dst-len) char)
359              (incf dst-len))
360            (slashp (char)
361              (find char "\\/")))
362       (dotimes (src-index src-len)
363         (let ((char (schar src src-index)))
364           (cond ((char= char #\.)
365                  (when dots
366                    (incf dots))
367                  (deposit char))
368                 ((slashp char)
369                  (case dots
370                    (0
371                     ;; either ``/...' or ``...//...'
372                     (unless last-slash
373                       (setf last-slash dst-len)
374                       (deposit char)))
375                    (1
376                     ;; either ``./...'' or ``..././...''
377                     (decf dst-len))
378                    (2
379                     ;; We've found ..
380                     (cond
381                       ((and last-slash (not (zerop last-slash)))
382                        ;; There is something before this ..
383                        (let ((prev-prev-slash
384                               (position-if #'slashp dst :end last-slash :from-end t)))
385                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
386                                         last-slash)
387                                      (char= (schar dst (- last-slash 2)) #\.)
388                                      (char= (schar dst (1- last-slash)) #\.))
389                                 ;; The something before this .. is another ..
390                                 (deposit char)
391                                 (setf last-slash dst-len))
392                                (t
393                                 ;; The something is some directory or other.
394                                 (setf dst-len
395                                       (if prev-prev-slash
396                                           (1+ prev-prev-slash)
397                                           0))
398                                 (setf last-slash prev-prev-slash)))))
399                       (t
400                        ;; There is nothing before this .., so we need to keep it
401                        (setf last-slash dst-len)
402                        (deposit char))))
403                    (t
404                     ;; something other than a dot between slashes
405                     (setf last-slash dst-len)
406                     (deposit char)))
407                  (setf dots 0))
408                 (t
409                  (setf dots nil)
410                  (setf (schar dst dst-len) char)
411                  (incf dst-len)))))
412       ;; ...finish off
413       (when (and last-slash (not (zerop last-slash)))
414         (case dots
415           (1
416            ;; We've got  ``foobar/.''
417            (decf dst-len))
418           (2
419            ;; We've got ``foobar/..''
420            (unless (and (>= last-slash 2)
421                         (char= (schar dst (1- last-slash)) #\.)
422                         (char= (schar dst (- last-slash 2)) #\.)
423                         (or (= last-slash 2)
424                             (slashp (schar dst (- last-slash 3)))))
425              (let ((prev-prev-slash
426                     (position-if #'slashp dst :end last-slash :from-end t)))
427                (if prev-prev-slash
428                    (setf dst-len (1+ prev-prev-slash))
429                    (return-from simplify-win32-namestring
430                      (coerce ".\\" 'simple-string)))))))))
431     (cond ((zerop dst-len)
432            ".\\")
433           ((= dst-len src-len)
434            dst)
435           (t
436            (subseq dst 0 dst-len)))))