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