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-win32-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                                                            #\^)))))))
 141                     (cond (absolute
 142                            (if home
 143                                (list* :absolute home (dirs))
 144                                (cons :absolute (dirs))))
 145                           ((dirs)
 146                            (cons :relative (dirs)))
 147                           (t
 148                            nil)))
 149                   name
 150                   type
 151                   version))))))
 152
 153 (defun parse-native-win32-namestring (namestring start end as-directory)
 154   (declare (type simple-string namestring)
 155            (type index start end))
 156   (setf namestring (coerce namestring 'simple-string))
 157   (multiple-value-bind (device new-start)
 158       (cond ((= (length +unc-file-name-prefix+)
 159                 (mismatch +unc-file-name-prefix+ namestring
 160                           :start2 start))
 161              (values :unc (+ start (length +unc-file-name-prefix+))))
 162             ((= (length +long-file-name-prefix+)
 163                 (mismatch +long-file-name-prefix+ namestring
 164                           :start2 start))
 165              (extract-device namestring
 166                              (+ start (length +long-file-name-prefix+))
 167                              end))
 168             (t (extract-device namestring start end)))
 169     (multiple-value-bind (absolute ranges)
 170         (split-at-slashes-and-backslashes namestring new-start end)
 171       (let* ((components (loop for ((start . end) . rest) on ranges
 172                                for piece = (subseq namestring start end)
 173                                collect (if (and (string= piece "..") rest)
 174                                            :up
 175                                            piece)))
 176              (directory (if (and as-directory
 177                                  (string/= "" (car (last components))))
 178                             components
 179                             (butlast components)))
 180              (name-and-type
 181               (unless as-directory
 182                 (let* ((end (first (last components)))
 183                        (dot (position #\. end :from-end t)))
 184                   ;; FIXME: can we get this dot-interpretation knowledge
 185                   ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
 186                   ;; does slightly more work than that.
 187                   (cond
 188                     ((string= end "")
 189                      (list nil nil))
 190                     ((and dot (> dot 0))
 191                      (list (subseq end 0 dot) (subseq end (1+ dot))))
 192                     (t
 193                      (list end nil)))))))
 194         (values nil
 195                 device
 196                 (cons (if absolute :absolute :relative) directory)
 197                 (first name-and-type)
 198                 (second name-and-type)
 199                 nil)))))
 200
 201
 202
 203 (defun unparse-win32-host (pathname)
 204   (declare (type pathname pathname)
 205            (ignore pathname))
 206   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
 207   "")
 208
 209 (defun unparse-win32-device (pathname &optional native)
 210   (declare (type pathname pathname))
 211   (let ((device (pathname-device pathname))
 212         (directory (pathname-directory pathname)))
 213     (cond ((or (null device) (eq device :unspecific))
 214            "")
 215           ((eq device :unc)
 216            (if native "\\" "/"))
 217           ((and (= 1 (length device)) (alpha-char-p (char device 0)))
 218            (concatenate 'simple-string device ":"))
 219           ((and (consp directory) (eq :relative (car directory)))
 220            (error "No printed representation for a relative UNC pathname."))
 221           (t
 222            (if native
 223                (concatenate 'simple-string "\\\\" device)
 224                (concatenate 'simple-string "//" device))))))
 225
 226 (defun unparse-win32-directory (pathname)
 227   (unparse-physical-directory pathname #\^))
 228
 229 (defun unparse-win32-file (pathname)
 230   (declare (type pathname pathname))
 231   (collect ((strings))
 232     (let* ((name (%pathname-name pathname))
 233            (type (%pathname-type pathname))
 234            (type-supplied (not (or (null type) (eq type :unspecific)))))
 235       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
 236       ;; translating logical pathnames to a filesystem without
 237       ;; versions (like Win32).
 238       (when name
 239         (when (and (null type)
 240                    (typep name 'string)
 241                    (> (length name) 0)
 242                    (position #\. name :start 1))
 243           (error "too many dots in the name: ~S" pathname))
 244         (when (and (typep name 'string)
 245                    (string= name ""))
 246           (error "name is of length 0: ~S" pathname))
 247         (strings (unparse-physical-piece name #\^)))
 248       (when type-supplied
 249         (unless name
 250           (error "cannot specify the type without a file: ~S" pathname))
 251         (when (typep type 'simple-string)
 252           (when (position #\. type)
 253             (error "type component can't have a #\. inside: ~S" pathname)))
 254         (strings ".")
 255         (strings (unparse-physical-piece type #\^))))
 256     (apply #'concatenate 'simple-string (strings))))
 257
 258 (defun unparse-win32-namestring (pathname)
 259   (declare (type pathname pathname))
 260   (concatenate 'simple-string
 261                (unparse-win32-device pathname)
 262                (unparse-physical-directory pathname #\^)
 263                (unparse-win32-file pathname)))
 264
 265 (defun unparse-native-win32-namestring (pathname as-file)
 266   (declare (type pathname pathname))
 267   (let* ((device (pathname-device pathname))
 268          (directory (pathname-directory pathname))
 269          (name (pathname-name pathname))
 270          (name-present-p (typep name '(not (member nil :unspecific))))
 271          (name-string (if name-present-p name ""))
 272          (type (pathname-type pathname))
 273          (type-present-p (typep type '(not (member nil :unspecific))))
 274          (type-string (if type-present-p type ""))
 275          (absolutep (and device (eql :absolute (car directory)))))
 276     (when name-present-p
 277       (setf as-file nil))
 278     (when (and absolutep (member :up directory))
 279       ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
 280       (setf directory
 281             (pathname-directory
 282              (merge-pathnames
 283               (make-pathname :defaults pathname :directory '(:relative))
 284               (make-pathname :defaults pathname
 285                              :directory (substitute :back :up directory))))))
 286     (coerce
 287      (with-simple-output-to-string (s)
 288        (when absolutep
 289          (write-string (case device
 290                          (:unc +unc-file-name-prefix+)
 291                          (otherwise +long-file-name-prefix+)) s))
 292        (when (or (not absolutep) (not (member device '(:unc nil))))
 293          (write-string (unparse-win32-device pathname t) s))
 294        (when directory
 295          (ecase (pop directory)
 296            (:absolute
 297             (let ((next (pop directory)))
 298               ;; Don't use USER-HOMEDIR-NAMESTRING, since
 299               ;; it can be specified as C:/User/user
 300               ;; and (native-namestring (user-homedir-pathname))
 301               ;; will be not equal to it, because it's parsed first.
 302               (cond ((eq :home next)
 303                      (write-string (native-namestring (user-homedir-pathname))
 304                                    s))
 305                     ((and (consp next) (eq :home (car next)))
 306                      (let ((where (user-homedir-pathname (second next))))
 307                        (if where
 308                            (write-string (native-namestring where) s)
 309                            (error "User homedir unknown for: ~S."
 310                                   (second next)))))
 311                     ;; namestring of user-homedir-pathname already has
 312                     ;; // at the end
 313                     (next
 314                      (write-char #\\ s)
 315                      (push next directory))
 316                     (t
 317                      (write-char #\\ s)))))
 318            (:relative)))
 319        (loop for (piece . subdirs) on directory
 320              do (typecase piece
 321                   ((member :up :back) (write-string ".." s))
 322                   (string (write-string piece s))
 323                   (t (error "Bad directory segment in NATIVE-NAMESTRING: ~S."
 324                             piece)))
 325              if (or subdirs (stringp name))
 326              do (write-char #\\ s)
 327              else
 328              do (unless as-file
 329                   (write-char #\\ s)))
 330        (if name-present-p
 331            (progn
 332              (unless (stringp name-string) ;some kind of wild field
 333                (error "Bad name component in NATIVE-NAMESTRING: ~S." name))
 334              (write-string name-string s)
 335              (when type-present-p
 336                (unless (stringp type-string) ;some kind of wild field
 337                  (error "Bad type component in NATIVE-NAMESTRING: ~S." type))
 338                (write-char #\. s)
 339                (write-string type-string s)))
 340            (when type-present-p
 341              (error
 342               "Type component without a name component in NATIVE-NAMESTRING: ~S."
 343               type)))
 344        (when absolutep
 345          (let ((string (get-output-stream-string s)))
 346            (return-from unparse-native-win32-namestring
 347              (cond ((< (- 260 12) (length string))
 348                     ;; KLUDGE: account for additional length of 8.3 name to make
 349                     ;; directories always accessible
 350                     (coerce string 'simple-string))
 351                    ((eq :unc device)
 352                     (replace
 353                      (subseq string (1- (length +unc-file-name-prefix+)))
 354                      "\\"))
 355                    (t (subseq string (length +long-file-name-prefix+))))))))
 356      'simple-string)))
 357
 358 ;;; FIXME.
 359 (defun unparse-win32-enough (pathname defaults)
 360   (declare (type pathname pathname defaults))
 361   (flet ((lose ()
 362            (error "~S cannot be represented relative to ~S."
 363                   pathname defaults)))
 364     (collect ((strings))
 365       (let* ((pathname-directory (%pathname-directory pathname))
 366              (defaults-directory (%pathname-directory defaults))
 367              (prefix-len (length defaults-directory))
 368              (result-directory
 369               (cond ((null pathname-directory) '(:relative))
 370                     ((eq (car pathname-directory) :relative)
 371                      pathname-directory)
 372                     ((and (> prefix-len 0)
 373                           (>= (length pathname-directory) prefix-len)
 374                           (compare-component (subseq pathname-directory
 375                                                      0 prefix-len)
 376                                              defaults-directory))
 377                      ;; Pathname starts with a prefix of default. So
 378                      ;; just use a relative directory from then on out.
 379                      (cons :relative (nthcdr prefix-len pathname-directory)))
 380                     ((eq (car pathname-directory) :absolute)
 381                      ;; We are an absolute pathname, so we can just use it.
 382                      pathname-directory)
 383                     (t
 384                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
 385         (strings (unparse-physical-directory-list result-directory #\^)))
 386       (let* ((pathname-type (%pathname-type pathname))
 387              (type-needed (and pathname-type
 388                                (not (eq pathname-type :unspecific))))
 389              (pathname-name (%pathname-name pathname))
 390              (name-needed (or type-needed
 391                               (and pathname-name
 392                                    (not (compare-component pathname-name
 393                                                            (%pathname-name
 394                                                             defaults)))))))
 395         (when name-needed
 396           (unless pathname-name (lose))
 397           (when (and (null pathname-type)
 398                      (typep pathname-name 'simple-string)
 399                      (position #\. pathname-name :start 1))
 400             (error "too many dots in the name: ~S" pathname))
 401           (strings (unparse-physical-piece pathname-name #\^)))
 402         (when type-needed
 403           (when (or (null pathname-type) (eq pathname-type :unspecific))
 404             (lose))
 405           (when (typep pathname-type 'simple-string)
 406             (when (position #\. pathname-type)
 407               (error "type component can't have a #\. inside: ~S" pathname)))
 408           (strings ".")
 409           (strings (unparse-physical-piece pathname-type #\^))))
 410       (apply #'concatenate 'simple-string (strings)))))
 411
 412 ;; FIXME: This has been converted rather blindly from the Unix
 413 ;; version, with no reference to any Windows docs what so ever.
 414 (defun simplify-win32-namestring (src)
 415   (declare (type simple-string src))
 416   (let* ((src-len (length src))
 417          (dst (make-string src-len :element-type 'character))
 418          (dst-len 0)
 419          (dots 0)
 420          (last-slash nil))
 421     (flet ((deposit (char)
 422              (setf (schar dst dst-len) char)
 423              (incf dst-len))
 424            (slashp (char)
 425              (find char "\\/")))
 426       (dotimes (src-index src-len)
 427         (let ((char (schar src src-index)))
 428           (cond ((char= char #\.)
 429                  (when dots
 430                    (incf dots))
 431                  (deposit char))
 432                 ((slashp char)
 433                  (case dots
 434                    (0
 435                     ;; either ``/...' or ``...//...'
 436                     (unless last-slash
 437                       (setf last-slash dst-len)
 438                       (deposit char)))
 439                    (1
 440                     ;; either ``./...'' or ``..././...''
 441                     (decf dst-len))
 442                    (2
 443                     ;; We've found ..
 444                     (cond
 445                       ((and last-slash (not (zerop last-slash)))
 446                        ;; There is something before this ..
 447                        (let ((prev-prev-slash
 448                               (position-if #'slashp dst :end last-slash :from-end t)))
 449                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
 450                                         last-slash)
 451                                      (char= (schar dst (- last-slash 2)) #\.)
 452                                      (char= (schar dst (1- last-slash)) #\.))
 453                                 ;; The something before this .. is another ..
 454                                 (deposit char)
 455                                 (setf last-slash dst-len))
 456                                (t
 457                                 ;; The something is some directory or other.
 458                                 (setf dst-len
 459                                       (if prev-prev-slash
 460                                           (1+ prev-prev-slash)
 461                                           0))
 462                                 (setf last-slash prev-prev-slash)))))
 463                       (t
 464                        ;; There is nothing before this .., so we need to keep it
 465                        (setf last-slash dst-len)
 466                        (deposit char))))
 467                    (t
 468                     ;; something other than a dot between slashes
 469                     (setf last-slash dst-len)
 470                     (deposit char)))
 471                  (setf dots 0))
 472                 (t
 473                  (setf dots nil)
 474                  (setf (schar dst dst-len) char)
 475                  (incf dst-len)))))
 476       ;; ...finish off
 477       (when (and last-slash (not (zerop last-slash)))
 478         (case dots
 479           (1
 480            ;; We've got  ``foobar/.''
 481            (decf dst-len))
 482           (2
 483            ;; We've got ``foobar/..''
 484            (unless (and (>= last-slash 2)
 485                         (char= (schar dst (1- last-slash)) #\.)
 486                         (char= (schar dst (- last-slash 2)) #\.)
 487                         (or (= last-slash 2)
 488                             (slashp (schar dst (- last-slash 3)))))
 489              (let ((prev-prev-slash
 490                     (position-if #'slashp dst :end last-slash :from-end t)))
 491                (if prev-prev-slash
 492                    (setf dst-len (1+ prev-prev-slash))
 493                    (return-from simplify-win32-namestring
 494                      (coerce ".\\" 'simple-string)))))))))
 495     (cond ((zerop dst-len)
 496            ".\\")
 497           ((= dst-len src-len)
 498            dst)
 499           (t
 500            (subseq dst 0 dst-len)))))