Fix equality between #p"~" and (user-homedir-pathname) on Win32.
[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 (def!struct (win32-host
15              (:make-load-form-fun make-host-load-form)
16              (:include host
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))))
28
29 (defvar *physical-host* (make-win32-host))
30
31 ;;;
32 (define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\"))
33 (define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC"))
34
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)))
48               (t
49                (values nil start))))
50       (values nil start)))
51
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) #\\)))))
63     (when absolute
64       (incf start))
65     ;; Next, split the remainder into slash-separated chunks.
66     (collect ((pieces))
67       (loop
68          (let ((slash (position-if (lambda (c)
69                                      (or (char= c #\/)
70                                          (char= c #\\)))
71                                    namestr :start start :end end)))
72            (pieces (cons start (or slash end)))
73            (unless slash
74              (return))
75            (setf start (1+ slash))))
76       (values absolute (pieces)))))
77
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)))
93
94         (when (stringp name)
95           (let ((position (position-if (lambda (char)
96                                          (or (char= char (code-char 0))
97                                              (char= char #\/)))
98                                        name)))
99             (when position
100               (error 'namestring-parse-error
101                      :complaint "can't embed #\\Nul or #\\/ in Windows namestring"
102                      :namestring namestring
103                      :offset position))))
104
105         (let (home)
106           ;; Deal with ~ and ~user.
107           (when (car pieces)
108             (destructuring-bind (start . end) (car pieces)
109               (when (and (not absolute)
110                          (not (eql start end))
111                          (string= namestring "~"
112                                   :start1 start
113                                   :end1 (1+ start)))
114                 (setf absolute t)
115                 (if (> end (1+ start))
116                     (setf home (list :home (subseq namestring (1+ start) end)))
117                     (setf home :home))
118                 (pop pieces))))
119
120           ;; Now we have everything we want. So return it.
121           (values nil                 ; no host for Win32 namestrings
122                   device
123                   (collect ((dirs))
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 ".."
129                                           :start1 piece-start
130                                           :end1 piece-end)
131                                  (dirs :up))
132                                 ((string= namestring "**"
133                                           :start1 piece-start
134                                           :end1 piece-end)
135                                  (dirs :wild-inferiors))
136                                 (t
137                                  (dirs (maybe-make-pattern namestring
138                                                            piece-start
139                                                            piece-end)))))))
140                     (cond (absolute
141                            (if home
142                                (list* :absolute home (dirs))
143                                (cons :absolute (dirs))))
144                           ((dirs)
145                            (cons :relative (dirs)))
146                           (t
147                            nil)))
148                   name
149                   type
150                   version))))))
151
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
159                           :start2 start))
160              (values :unc (+ start (length +unc-file-name-prefix+))))
161             ((= (length +long-file-name-prefix+)
162                 (mismatch +long-file-name-prefix+ namestring
163                           :start2 start))
164              (extract-device namestring
165                              (+ start (length +long-file-name-prefix+))
166                              end))
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)
173                                            :up
174                                            piece)))
175              (directory (if (and as-directory
176                                  (string/= "" (car (last components))))
177                             components
178                             (butlast components)))
179              (name-and-type
180               (unless as-directory
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.
186                   (cond
187                     ((string= end "")
188                      (list nil nil))
189                     ((and dot (> dot 0))
190                      (list (subseq end 0 dot) (subseq end (1+ dot))))
191                     (t
192                      (list end nil)))))))
193         (values nil
194                 device
195                 (cons (if absolute :absolute :relative) directory)
196                 (first name-and-type)
197                 (second name-and-type)
198                 nil)))))
199
200
201
202 (defun unparse-win32-host (pathname)
203   (declare (type pathname pathname)
204            (ignore pathname))
205   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
206   "")
207
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))
213            "")
214           ((eq device :unc)
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."))
220           (t
221            (if native
222                (concatenate 'simple-string "\\\\" device)
223                (concatenate 'simple-string "//" device))))))
224
225 (defun unparse-win32-file (pathname)
226   (declare (type pathname pathname))
227   (collect ((strings))
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).
234       (when name
235         (when (and (null type)
236                    (typep name 'string)
237                    (> (length name) 0)
238                    (position #\. name :start 1))
239           (error "too many dots in the name: ~S" pathname))
240         (when (and (typep name 'string)
241                    (string= name ""))
242           (error "name is of length 0: ~S" pathname))
243         (strings (unparse-physical-piece name)))
244       (when type-supplied
245         (unless 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)))
250         (strings ".")
251         (strings (unparse-physical-piece type))))
252     (apply #'concatenate 'simple-string (strings))))
253
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)))
260
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)))))
272     (when name-present-p
273       (setf as-file nil))
274     (when (and absolutep (member :up directory))
275       ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
276       (setf directory
277             (pathname-directory
278              (merge-pathnames
279               (make-pathname :defaults pathname :directory '(:relative))
280               (make-pathname :defaults pathname
281                              :directory (substitute :back :up directory))))))
282     (coerce
283      (with-output-to-string (s)
284        (when absolutep
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))
290        (when directory
291          (ecase (pop directory)
292            (:absolute
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))
300                                    s))
301                     ((and (consp next) (eq :home (car next)))
302                      (let ((where (user-homedir-pathname (second next))))
303                        (if where
304                            (write-string (native-namestring where) s)
305                            (error "User homedir unknown for: ~S"
306                                   (second next)))))
307                     ;; namestring of user-homedir-pathname already has
308                     ;; // at the end
309                     (next
310                      (write-char #\\ s)
311                      (push next directory))
312                     (t
313                      (write-char #\\ s)))))
314            (:relative)))
315        (loop for (piece . subdirs) on directory
316              do (typecase piece
317                   ((member :up) (write-string ".." s))
318                   (string (write-string piece s))
319                   (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
320                             piece)))
321              if (or subdirs (stringp name))
322              do (write-char #\\ s)
323              else
324              do (unless as-file
325                   (write-char #\\ s)))
326        (if name-present-p
327            (progn
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)
331              (when type-present-p
332                (unless (stringp type-string) ;some kind of wild field
333                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
334                (write-char #\. s)
335                (write-string type-string s)))
336            (when type-present-p
337              (error
338               "type component without a name component in NATIVE-NAMESTRING: ~S"
339               type)))
340        (when absolutep
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))
347                    ((eq :unc device)
348                     (replace
349                      (subseq string (1- (length +unc-file-name-prefix+)))
350                      "\\"))
351                    (t (subseq string (length +long-file-name-prefix+))))))))
352      'simple-string)))
353
354 ;;; FIXME.
355 (defun unparse-win32-enough (pathname defaults)
356   (declare (type pathname pathname defaults))
357   (flet ((lose ()
358            (error "~S cannot be represented relative to ~S."
359                   pathname defaults)))
360     (collect ((strings))
361       (let* ((pathname-directory (%pathname-directory pathname))
362              (defaults-directory (%pathname-directory defaults))
363              (prefix-len (length defaults-directory))
364              (result-directory
365               (cond ((null pathname-directory) '(:relative))
366                     ((eq (car pathname-directory) :relative)
367                      pathname-directory)
368                     ((and (> prefix-len 0)
369                           (>= (length pathname-directory) prefix-len)
370                           (compare-component (subseq pathname-directory
371                                                      0 prefix-len)
372                                              defaults-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.
378                      pathname-directory)
379                     (t
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
387                               (and pathname-name
388                                    (not (compare-component pathname-name
389                                                            (%pathname-name
390                                                             defaults)))))))
391         (when name-needed
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)))
398         (when type-needed
399           (when (or (null pathname-type) (eq pathname-type :unspecific))
400             (lose))
401           (when (typep pathname-type 'simple-string)
402             (when (position #\. pathname-type)
403               (error "type component can't have a #\. inside: ~S" pathname)))
404           (strings ".")
405           (strings (unparse-physical-piece pathname-type))))
406       (apply #'concatenate 'simple-string (strings)))))
407
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))
414          (dst-len 0)
415          (dots 0)
416          (last-slash nil))
417     (flet ((deposit (char)
418              (setf (schar dst dst-len) char)
419              (incf dst-len))
420            (slashp (char)
421              (find char "\\/")))
422       (dotimes (src-index src-len)
423         (let ((char (schar src src-index)))
424           (cond ((char= char #\.)
425                  (when dots
426                    (incf dots))
427                  (deposit char))
428                 ((slashp char)
429                  (case dots
430                    (0
431                     ;; either ``/...' or ``...//...'
432                     (unless last-slash
433                       (setf last-slash dst-len)
434                       (deposit char)))
435                    (1
436                     ;; either ``./...'' or ``..././...''
437                     (decf dst-len))
438                    (2
439                     ;; We've found ..
440                     (cond
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)
446                                         last-slash)
447                                      (char= (schar dst (- last-slash 2)) #\.)
448                                      (char= (schar dst (1- last-slash)) #\.))
449                                 ;; The something before this .. is another ..
450                                 (deposit char)
451                                 (setf last-slash dst-len))
452                                (t
453                                 ;; The something is some directory or other.
454                                 (setf dst-len
455                                       (if prev-prev-slash
456                                           (1+ prev-prev-slash)
457                                           0))
458                                 (setf last-slash prev-prev-slash)))))
459                       (t
460                        ;; There is nothing before this .., so we need to keep it
461                        (setf last-slash dst-len)
462                        (deposit char))))
463                    (t
464                     ;; something other than a dot between slashes
465                     (setf last-slash dst-len)
466                     (deposit char)))
467                  (setf dots 0))
468                 (t
469                  (setf dots nil)
470                  (setf (schar dst dst-len) char)
471                  (incf dst-len)))))
472       ;; ...finish off
473       (when (and last-slash (not (zerop last-slash)))
474         (case dots
475           (1
476            ;; We've got  ``foobar/.''
477            (decf dst-len))
478           (2
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)) #\.)
483                         (or (= 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)))
487                (if prev-prev-slash
488                    (setf dst-len (1+ prev-prev-slash))
489                    (return-from simplify-win32-namestring
490                      (coerce ".\\" 'simple-string)))))))))
491     (cond ((zerop dst-len)
492            ".\\")
493           ((= dst-len src-len)
494            dst)
495           (t
496            (subseq dst 0 dst-len)))))