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