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 (defstruct (win32-host
  15              (:include host
  16                        (parse #'parse-win32-namestring)
  17                        (parse-native #'parse-native-win32-namestring)
  18                        (unparse #'unparse-win32-namestring)
  19                        (unparse-native #'unparse-native-win32-namestring)
  20                        (unparse-host #'unparse-win32-host)
  21                        (unparse-directory #'unparse-win32-directory)
  22                        (unparse-file #'unparse-win32-file)
  23                        (unparse-enough #'unparse-win32-enough)
  24                        (unparse-directory-separator "\\")
  25                        (simplify-namestring #'simplify-win32-namestring)
  26                        (customary-case :lower))))
  27
  28 (setq *physical-host* (make-win32-host))
  29
  30 ;;;
  31 (define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\"))
  32 (define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC"))
  33
  34 (defun extract-device (namestr start end)
  35   (declare (type simple-string namestr)
  36            (type index start end))
  37   (if (>= end (+ start 2))
  38       (let ((c0 (char namestr start))
  39             (c1 (char namestr (1+ start))))
  40         (cond ((and (eql c1 #\:) (alpha-char-p c0))
  41                ;; "X:" style, saved as X
  42                (values (string (char namestr start)) (+ start 2)))
  43               ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3)))
  44                ;; "//UNC" style, saved as :UNC device, with host and share
  45                ;; becoming directory components.
  46                (values :unc (+ start 1)))
  47               (t
  48                (values nil start))))
  49       (values nil start)))
  50
  51 (defun split-at-slashes-and-backslashes (namestr start end)
  52   (declare (type simple-string namestr)
  53            (type index start end))
  54   ;; FIXME: There is a fundamental brokenness in using the same
  55   ;; character as escape character and directory separator in
  56   ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
  57   ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
  58   ;; (:ABSOLUTE :WILD)! See lp#673625.
  59   (let ((absolute (and (/= start end)
  60                        (or (char= (schar namestr start) #\/)
  61                            (char= (schar namestr start) #\\)))))
  62     (when absolute
  63       (incf start))
  64     ;; Next, split the remainder into slash-separated chunks.
  65     (collect ((pieces))
  66       (loop
  67          (let ((slash (position-if (lambda (c)
  68                                      (or (char= c #\/)
  69                                          (char= c #\\)))
  70                                    namestr :start start :end end)))
  71            (pieces (cons start (or slash end)))
  72            (unless slash
  73              (return))
  74            (setf start (1+ slash))))
  75       (values absolute (pieces)))))
  76
  77 (defun parse-win32-namestring (namestring start end)
  78   (declare (type simple-string namestring)
  79            (type index start end))
  80   (setf namestring (coerce namestring 'simple-string))
  81   (multiple-value-bind (device new-start)
  82       (extract-device namestring start end)
  83     (multiple-value-bind (absolute pieces)
  84         (split-at-slashes-and-backslashes namestring new-start end)
  85       (multiple-value-bind (name type version)
  86           (let* ((tail (car (last pieces)))
  87                  (tail-start (car tail))
  88                  (tail-end (cdr tail)))
  89             (unless (= tail-start tail-end)
  90               (setf pieces (butlast pieces))
  91               (extract-name-type-and-version namestring tail-start tail-end #\^)))
  92
  93         (when (stringp name)
  94           (let ((position (position-if (lambda (char)
  95                                          (or (char= char (code-char 0))
  96                                              (char= char #\/)))
  97                                        name)))
  98             (when position
  99               (error 'namestring-parse-error
 100                      :complaint "can't embed #\\Nul or #\\/ in Windows namestring"
 101                      :namestring namestring
 102                      :offset position))))
 103
 104         (let (home)
 105           ;; Deal with ~ and ~user.
 106           (when (car pieces)
 107             (destructuring-bind (start . end) (car pieces)
 108               (when (and (not absolute)
 109                          (not (eql start end))
 110                          (string= namestring "~"
 111                                   :start1 start
 112                                   :end1 (1+ start)))
 113                 (setf absolute t)
 114                 (if (> end (1+ start))
 115                     (setf home (list :home (subseq namestring (1+ start) end)))
 116                     (setf home :home))
 117                 (pop pieces))))
 118
 119           ;; Now we have everything we want. So return it.
 120           (values nil                 ; no host for Win32 namestrings
 121                   device
 122                   (collect ((dirs))
 123                     (dolist (piece pieces)
 124                       (let ((piece-start (car piece))
 125                             (piece-end (cdr piece)))
 126                         (unless (= piece-start piece-end)
 127                           (cond ((string= namestring ".."
 128                                           :start1 piece-start
 129                                           :end1 piece-end)
 130                                  (dirs :up))
 131                                 ((string= namestring "**"
 132                                           :start1 piece-start
 133                                           :end1 piece-end)
 134                                  (dirs :wild-inferiors))
 135                                 (t
 136                                  (dirs (maybe-make-pattern namestring
 137                                                            piece-start
 138                                                            piece-end
 139                                                            #\^)))))))
 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                 (cond (absolute
 196                        (cons :absolute directory))
 197                       (directory
 198                        (cons :relative directory))
 199                       (as-directory
 200                        '(:absolute)))
 201                 (first name-and-type)
 202                 (second name-and-type)
 203                 nil)))))
 204
 205 (defun unparse-win32-host (pathname)
 206   (declare (type pathname pathname)
 207            (ignore pathname))
 208   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
 209   "")
 210
 211 (defun unparse-win32-device (pathname &optional native)
 212   (declare (type pathname pathname))
 213   (let ((device (pathname-device pathname))
 214         (directory (pathname-directory pathname)))
 215     (cond ((not (pathname-component-present-p device))
 216            "")
 217           ((eq device :unc)
 218            (if native "\\" "/"))
 219           ((and (= 1 (length device)) (alpha-char-p (char device 0)))
 220            (concatenate 'simple-string device ":"))
 221           ((and (consp directory) (eq :relative (car directory)))
 222            (no-native-namestring-error
 223             pathname
 224             "there is no printed representation for a relative UNC pathname"))
 225           (t
 226            (if native
 227                (concatenate 'simple-string "\\\\" device)
 228                (concatenate 'simple-string "//" device))))))
 229
 230 (defun unparse-win32-directory (pathname)
 231   (unparse-physical-directory pathname #\^))
 232
 233 (defun unparse-win32-file (pathname)
 234   (declare (type pathname pathname))
 235   (unparse-physical-file pathname #\^))
 236
 237 (defun unparse-win32-namestring (pathname)
 238   (declare (type pathname pathname))
 239   (concatenate 'simple-string
 240                (unparse-win32-device pathname)
 241                (unparse-physical-directory pathname #\^)
 242                (unparse-physical-file pathname #\^)))
 243
 244 (defun unparse-native-win32-namestring (pathname as-file)
 245   (declare (type pathname pathname))
 246   (let* ((device (pathname-device pathname))
 247          (devicep (not (member device '(:unc nil))))
 248          (directory (pathname-directory pathname))
 249          (absolutep (and device (eql :absolute (car directory))))
 250          (seperator-after-directory-p
 251           (or (pathname-component-present-p (pathname-name pathname))
 252               (not as-file))))
 253     (when (and absolutep (member :up directory))
 254       ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
 255       (setf directory
 256             (pathname-directory
 257              (merge-pathnames
 258               (make-pathname :defaults pathname :directory '(:relative))
 259               (make-pathname :defaults pathname
 260                              :directory (substitute :back :up directory))))))
 261     (coerce
 262      (%with-output-to-string (s)
 263        (when absolutep
 264          (write-string (case device
 265                          (:unc +unc-file-name-prefix+)
 266                          (otherwise +long-file-name-prefix+))
 267                        s))
 268        (when (or (not absolutep) devicep)
 269          (write-string (unparse-win32-device pathname t) s))
 270        (when directory
 271          (ecase (pop directory)
 272            (:absolute
 273             (let ((next (pop directory)))
 274               (cond
 275                 ((typep next '(or (eql :home) (cons (eql :home))))
 276                  (let* ((username (when (consp next) (second next)))
 277                         (home (handler-case
 278                                   (if username
 279                                       (parse-native-namestring
 280                                        (user-homedir-namestring username))
 281                                       (user-homedir-pathname))
 282                                 (error (condition)
 283                                   (no-native-namestring-error
 284                                    pathname
 285                                    "user homedir not known~@[ for ~S~]: ~A"
 286                                    username condition)))))
 287                    (when (and (or absolutep devicep)
 288                               (not (string-equal device (pathname-device home))))
 289                      (no-native-namestring-error
 290                       pathname
 291                       "Device in homedir ~S conflicts which device ~S"
 292                       home device))
 293                    (write-string (native-namestring home) s)))
 294                 ;; namestring of user-homedir-pathname already has
 295                 ;; // at the end
 296                 (next
 297                  (write-char #\\ s)
 298                  (push next directory))
 299                 (t
 300                  (write-char #\\ s)))))
 301            (:relative)))
 302        (loop for (piece . subdirs) on directory
 303              do (typecase piece
 304                   ((member :up :back) (write-string ".." s))
 305                   (string (write-string piece s))
 306                   (t (no-native-namestring-error pathname
 307                                                  "Bad directory segment in NATIVE-NAMESTRING: ~S."
 308                                                  piece)))
 309              when (or subdirs seperator-after-directory-p)
 310              do (write-char #\\ s))
 311        (write-string (unparse-native-physical-file pathname) s)
 312        (when absolutep
 313          (let ((string (get-output-stream-string s)))
 314            (return-from unparse-native-win32-namestring
 315              (cond ((< (- 260 12) (length string))
 316                     ;; KLUDGE: account for additional length of 8.3 name to make
 317                     ;; directories always accessible
 318                     (coerce string 'simple-string))
 319                    ((eq :unc device)
 320                     (replace
 321                      (subseq string (1- (length +unc-file-name-prefix+)))
 322                      "\\"))
 323                    (t (subseq string (length +long-file-name-prefix+))))))))
 324      'simple-string)))
 325
 326 (defun unparse-win32-enough (pathname defaults)
 327   (unparse-physical-enough pathname defaults #\^))
 328
 329 ;; FIXME: This has been converted rather blindly from the Unix
 330 ;; version, with no reference to any Windows docs what so ever.
 331 (defun simplify-win32-namestring (src)
 332   (declare (type simple-string src))
 333   (let* ((src-len (length src))
 334          (dst (make-string src-len :element-type 'character))
 335          (dst-len 0)
 336          (dots 0)
 337          (last-slash nil))
 338     (flet ((deposit (char)
 339              (setf (schar dst dst-len) char)
 340              (incf dst-len))
 341            (slashp (char)
 342              (find char "\\/")))
 343       (dotimes (src-index src-len)
 344         (let ((char (schar src src-index)))
 345           (cond ((char= char #\.)
 346                  (when dots
 347                    (incf dots))
 348                  (deposit char))
 349                 ((slashp char)
 350                  (case dots
 351                    (0
 352                     ;; either ``/...' or ``...//...'
 353                     (unless last-slash
 354                       (setf last-slash dst-len)
 355                       (deposit char)))
 356                    (1
 357                     ;; either ``./...'' or ``..././...''
 358                     (decf dst-len))
 359                    (2
 360                     ;; We've found ..
 361                     (cond
 362                       ((and last-slash (not (zerop last-slash)))
 363                        ;; There is something before this ..
 364                        (let ((prev-prev-slash
 365                               (position-if #'slashp dst :end last-slash :from-end t)))
 366                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
 367                                         last-slash)
 368                                      (char= (schar dst (- last-slash 2)) #\.)
 369                                      (char= (schar dst (1- last-slash)) #\.))
 370                                 ;; The something before this .. is another ..
 371                                 (deposit char)
 372                                 (setf last-slash dst-len))
 373                                (t
 374                                 ;; The something is some directory or other.
 375                                 (setf dst-len
 376                                       (if prev-prev-slash
 377                                           (1+ prev-prev-slash)
 378                                           0))
 379                                 (setf last-slash prev-prev-slash)))))
 380                       (t
 381                        ;; There is nothing before this .., so we need to keep it
 382                        (setf last-slash dst-len)
 383                        (deposit char))))
 384                    (t
 385                     ;; something other than a dot between slashes
 386                     (setf last-slash dst-len)
 387                     (deposit char)))
 388                  (setf dots 0))
 389                 (t
 390                  (setf dots nil)
 391                  (setf (schar dst dst-len) char)
 392                  (incf dst-len)))))
 393       ;; ...finish off
 394       (when (and last-slash (not (zerop last-slash)))
 395         (case dots
 396           (1
 397            ;; We've got  ``foobar/.''
 398            (decf dst-len))
 399           (2
 400            ;; We've got ``foobar/..''
 401            (unless (and (>= last-slash 2)
 402                         (char= (schar dst (1- last-slash)) #\.)
 403                         (char= (schar dst (- last-slash 2)) #\.)
 404                         (or (= last-slash 2)
 405                             (slashp (schar dst (- last-slash 3)))))
 406              (let ((prev-prev-slash
 407                     (position-if #'slashp dst :end last-slash :from-end t)))
 408                (if prev-prev-slash
 409                    (setf dst-len (1+ prev-prev-slash))
 410                    (return-from simplify-win32-namestring
 411                      (coerce ".\\" 'simple-string)))))))))
 412     (cond ((zerop dst-len)
 413            ".\\")
 414           ((= dst-len src-len)
 415            dst)
 416           (t
 417            (subseq dst 0 dst-len)))))