src/code/win32-pathname.lisp

   1 ;;;; pathname parsing for Win32 filesystems
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defun extract-device (namestr start end)
  15   (declare (type simple-string namestr)
  16            (type index start end))
  17   (if (>= end (+ start 2))
  18       (let ((c0 (char namestr start))
  19             (c1 (char namestr (1+ start))))
  20         (cond ((and (eql c1 #\:) (alpha-char-p c0))
  21                ;; "X:" style, saved as X
  22                (values (string (char namestr start)) (+ start 2)))
  23               ((and (member c0 '(#\/ #\\)) (eql c0 c1))
  24                ;; "//UNC" style, saved as UNC
  25                ;; FIXME: at unparsing time we tell these apart by length,
  26                ;; which seems a bit lossy -- presumably one-letter UNC
  27                ;; hosts can exist as well. That seems a less troublesome
  28                ;; restriction than disallowing UNC hosts whose names match
  29                ;; logical pathname hosts... Time will tell -- both LispWorks
  30                ;; and ACL use the host component for UNC hosts, so maybe
  31                ;; we will end up there as well.
  32                (let ((p (or (position c0 namestr :start (+ start 3) :end end)
  33                             end)))
  34                  (values (subseq namestr (+ start 2) p) p)))
  35               (t
  36                (values nil start))))
  37       (values nil start)))
  38
  39 (defun split-at-slashes-and-backslashes (namestr start end)
  40   (declare (type simple-string namestr)
  41            (type index start end))
  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 Unix namestring"
  84                      :namestring namestring
  85                      :offset position))))
  86         ;; Now we have everything we want. So return it.
  87         (values nil ; no host for Win32 namestrings
  88                 device
  89                 (collect ((dirs))
  90                   (dolist (piece pieces)
  91                     (let ((piece-start (car piece))
  92                           (piece-end (cdr piece)))
  93                       (unless (= piece-start piece-end)
  94                         (cond ((string= namestring ".."
  95                                         :start1 piece-start
  96                                         :end1 piece-end)
  97                                (dirs :up))
  98                               ((string= namestring "**"
  99                                         :start1 piece-start
 100                                         :end1 piece-end)
 101                                (dirs :wild-inferiors))
 102                               (t
 103                                (dirs (maybe-make-pattern namestring
 104                                                          piece-start
 105                                                          piece-end)))))))
 106                   (cond (absolute
 107                          (cons :absolute (dirs)))
 108                         ((dirs)
 109                          (cons :relative (dirs)))
 110                         (t
 111                          nil)))
 112                 name
 113                 type
 114                 version)))))
 115
 116 (defun parse-native-win32-namestring (namestring start end as-directory)
 117   (declare (type simple-string namestring)
 118            (type index start end))
 119   (setf namestring (coerce namestring 'simple-string))
 120   (multiple-value-bind (device new-start)
 121       (extract-device namestring start end)
 122     (multiple-value-bind (absolute ranges)
 123         (split-at-slashes-and-backslashes namestring new-start end)
 124       (let* ((components (loop for ((start . end) . rest) on ranges
 125                                for piece = (subseq namestring start end)
 126                                collect (if (and (string= piece "..") rest)
 127                                            :up
 128                                            piece)))
 129              (directory (if (and as-directory
 130                                  (string/= "" (car (last components))))
 131                             components
 132                             (butlast components)))
 133              (name-and-type
 134               (unless as-directory
 135                 (let* ((end (first (last components)))
 136                        (dot (position #\. end :from-end t)))
 137                   ;; FIXME: can we get this dot-interpretation knowledge
 138                   ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
 139                   ;; does slightly more work than that.
 140                   (cond
 141                     ((string= end "")
 142                      (list nil nil))
 143                     ((and dot (> dot 0))
 144                      (list (subseq end 0 dot) (subseq end (1+ dot))))
 145                     (t
 146                      (list end nil)))))))
 147         (values nil
 148                 device
 149                 (cons (if absolute :absolute :relative) directory)
 150                 (first name-and-type)
 151                 (second name-and-type)
 152                 nil)))))
 153
 154
 155
 156 (defun unparse-win32-host (pathname)
 157   (declare (type pathname pathname)
 158            (ignore pathname))
 159   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
 160   "")
 161
 162 (defun unparse-win32-device (pathname)
 163   (declare (type pathname pathname))
 164   (let ((device (pathname-device pathname))
 165         (directory (pathname-directory pathname)))
 166     (cond ((or (null device) (eq device :unspecific))
 167            "")
 168           ((= 1 (length device))
 169            (concatenate 'simple-string device ":"))
 170           ((and (consp directory) (eq :relative (car directory)))
 171            (error "No printed representation for a relative UNC pathname."))
 172           (t
 173            (concatenate 'simple-string "\\\\" device)))))
 174
 175 (defun unparse-win32-piece (thing)
 176   (etypecase thing
 177     ((member :wild) "*")
 178     (simple-string
 179      (let* ((srclen (length thing))
 180             (dstlen srclen))
 181        (dotimes (i srclen)
 182          (case (schar thing i)
 183            ((#\* #\? #\[)
 184             (incf dstlen))))
 185        (let ((result (make-string dstlen))
 186              (dst 0))
 187          (dotimes (src srclen)
 188            (let ((char (schar thing src)))
 189              (case char
 190                ((#\* #\? #\[)
 191                 (setf (schar result dst) #\\)
 192                 (incf dst)))
 193              (setf (schar result dst) char)
 194              (incf dst)))
 195          result)))
 196     (pattern
 197      (collect ((strings))
 198        (dolist (piece (pattern-pieces thing))
 199          (etypecase piece
 200            (simple-string
 201             (strings piece))
 202            (symbol
 203             (ecase piece
 204               (:multi-char-wild
 205                (strings "*"))
 206               (:single-char-wild
 207                (strings "?"))))
 208            (cons
 209             (case (car piece)
 210               (:character-set
 211                (strings "[")
 212                (strings (cdr piece))
 213                (strings "]"))
 214               (t
 215                (error "invalid pattern piece: ~S" piece))))))
 216        (apply #'concatenate
 217               'simple-string
 218               (strings))))))
 219
 220 (defun unparse-win32-directory-list (directory)
 221   (declare (type list directory))
 222   (collect ((pieces))
 223     (when directory
 224       (ecase (pop directory)
 225         (:absolute
 226          (pieces "\\"))
 227         (:relative
 228          ;; nothing special
 229          ))
 230       (dolist (dir directory)
 231         (typecase dir
 232           ((member :up)
 233            (pieces "..\\"))
 234           ((member :back)
 235            (error ":BACK cannot be represented in namestrings."))
 236           ((member :wild-inferiors)
 237            (pieces "**\\"))
 238           ((or simple-string pattern (member :wild))
 239            (pieces (unparse-unix-piece dir))
 240            (pieces "\\"))
 241           (t
 242            (error "invalid directory component: ~S" dir)))))
 243     (apply #'concatenate 'simple-string (pieces))))
 244
 245 (defun unparse-win32-directory (pathname)
 246   (declare (type pathname pathname))
 247   (unparse-win32-directory-list (%pathname-directory pathname)))
 248
 249 (defun unparse-win32-file (pathname)
 250   (declare (type pathname pathname))
 251   (collect ((strings))
 252     (let* ((name (%pathname-name pathname))
 253            (type (%pathname-type pathname))
 254            (type-supplied (not (or (null type) (eq type :unspecific)))))
 255       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
 256       ;; translating logical pathnames to a filesystem without
 257       ;; versions (like Win32).
 258       (when name
 259         (when (and (null type)
 260                    (typep name 'string)
 261                    (> (length name) 0)
 262                    (position #\. name :start 1))
 263           (error "too many dots in the name: ~S" pathname))
 264         (when (and (typep name 'string)
 265                    (string= name ""))
 266           (error "name is of length 0: ~S" pathname))
 267         (strings (unparse-unix-piece name)))
 268       (when type-supplied
 269         (unless name
 270           (error "cannot specify the type without a file: ~S" pathname))
 271         (when (typep type 'simple-string)
 272           (when (position #\. type)
 273             (error "type component can't have a #\. inside: ~S" pathname)))
 274         (strings ".")
 275         (strings (unparse-unix-piece type))))
 276     (apply #'concatenate 'simple-string (strings))))
 277
 278 (defun unparse-win32-namestring (pathname)
 279   (declare (type pathname pathname))
 280   (concatenate 'simple-string
 281                (unparse-win32-device pathname)
 282                (unparse-win32-directory pathname)
 283                (unparse-win32-file pathname)))
 284
 285 (defun unparse-native-win32-namestring (pathname as-file)
 286   (declare (type pathname pathname)
 287            ;; Windows doesn't like directory names with trailing slashes.
 288            (ignore as-file))
 289   (let* ((device (pathname-device pathname))
 290          (directory (pathname-directory pathname))
 291          (name (pathname-name pathname))
 292          (name-present-p (typep name '(not (member nil :unspecific))))
 293          (name-string (if name-present-p name ""))
 294          (type (pathname-type pathname))
 295          (type-present-p (typep type '(not (member nil :unspecific))))
 296          (type-string (if type-present-p type "")))
 297     (coerce
 298      (with-output-to-string (s)
 299        (when device
 300          (write-string (unparse-win32-device pathname) s))
 301        (tagbody
 302           (when directory
 303             (ecase (pop directory)
 304               (:absolute (write-char #\\ s))
 305               (:relative)))
 306           (unless directory (go :done))
 307         :subdir
 308           (let ((piece (pop directory)))
 309             (typecase piece
 310               ((member :up) (write-string ".." s))
 311               (string (write-string piece s))
 312               (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
 313                         piece)))
 314             (when (or directory name)
 315               (write-char #\\ s)))
 316           (when directory
 317             (go :subdir))
 318         :done)
 319        (if name-present-p
 320            (progn
 321              (unless (stringp name-string) ;some kind of wild field
 322                (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
 323              (write-string name-string s)
 324              (when type-present-p
 325                (unless (stringp type-string) ;some kind of wild field
 326                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
 327                (write-char #\. s)
 328                (write-string type-string s)))
 329            (when type-present-p ;
 330              (error
 331               "type component without a name component in NATIVE-NAMESTRING: ~S"
 332               type))))
 333      'simple-string)))
 334
 335 ;;; FIXME.
 336 (defun unparse-win32-enough (pathname defaults)
 337   (declare (type pathname pathname defaults))
 338   (flet ((lose ()
 339            (error "~S cannot be represented relative to ~S."
 340                   pathname defaults)))
 341     (collect ((strings))
 342       (let* ((pathname-directory (%pathname-directory pathname))
 343              (defaults-directory (%pathname-directory defaults))
 344              (prefix-len (length defaults-directory))
 345              (result-directory
 346               (cond ((null pathname-directory) '(:relative))
 347                     ((eq (car pathname-directory) :relative)
 348                      pathname-directory)
 349                     ((and (> prefix-len 0)
 350                           (>= (length pathname-directory) prefix-len)
 351                           (compare-component (subseq pathname-directory
 352                                                      0 prefix-len)
 353                                              defaults-directory))
 354                      ;; Pathname starts with a prefix of default. So
 355                      ;; just use a relative directory from then on out.
 356                      (cons :relative (nthcdr prefix-len pathname-directory)))
 357                     ((eq (car pathname-directory) :absolute)
 358                      ;; We are an absolute pathname, so we can just use it.
 359                      pathname-directory)
 360                     (t
 361                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
 362         (strings (unparse-unix-directory-list result-directory)))
 363       (let* ((pathname-type (%pathname-type pathname))
 364              (type-needed (and pathname-type
 365                                (not (eq pathname-type :unspecific))))
 366              (pathname-name (%pathname-name pathname))
 367              (name-needed (or type-needed
 368                               (and pathname-name
 369                                    (not (compare-component pathname-name
 370                                                            (%pathname-name
 371                                                             defaults)))))))
 372         (when name-needed
 373           (unless pathname-name (lose))
 374           (when (and (null pathname-type)
 375                      (typep pathname-name 'simple-string)
 376                      (position #\. pathname-name :start 1))
 377             (error "too many dots in the name: ~S" pathname))
 378           (strings (unparse-unix-piece pathname-name)))
 379         (when type-needed
 380           (when (or (null pathname-type) (eq pathname-type :unspecific))
 381             (lose))
 382           (when (typep pathname-type 'simple-string)
 383             (when (position #\. pathname-type)
 384               (error "type component can't have a #\. inside: ~S" pathname)))
 385           (strings ".")
 386           (strings (unparse-unix-piece pathname-type))))
 387       (apply #'concatenate 'simple-string (strings)))))
 388
 389 ;; FIXME: This has been converted rather blindly from the Unix
 390 ;; version, with no reference to any Windows docs what so ever.
 391 (defun simplify-win32-namestring (src)
 392   (declare (type simple-string src))
 393   (let* ((src-len (length src))
 394          (dst (make-string src-len :element-type 'character))
 395          (dst-len 0)
 396          (dots 0)
 397          (last-slash nil))
 398     (flet ((deposit (char)
 399              (setf (schar dst dst-len) char)
 400              (incf dst-len))
 401            (slashp (char)
 402              (find char "\\/")))
 403       (dotimes (src-index src-len)
 404         (let ((char (schar src src-index)))
 405           (cond ((char= char #\.)
 406                  (when dots
 407                    (incf dots))
 408                  (deposit char))
 409                 ((slashp char)
 410                  (case dots
 411                    (0
 412                     ;; either ``/...' or ``...//...'
 413                     (unless last-slash
 414                       (setf last-slash dst-len)
 415                       (deposit char)))
 416                    (1
 417                     ;; either ``./...'' or ``..././...''
 418                     (decf dst-len))
 419                    (2
 420                     ;; We've found ..
 421                     (cond
 422                       ((and last-slash (not (zerop last-slash)))
 423                        ;; There is something before this ..
 424                        (let ((prev-prev-slash
 425                               (position-if #'slashp dst :end last-slash :from-end t)))
 426                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
 427                                         last-slash)
 428                                      (char= (schar dst (- last-slash 2)) #\.)
 429                                      (char= (schar dst (1- last-slash)) #\.))
 430                                 ;; The something before this .. is another ..
 431                                 (deposit char)
 432                                 (setf last-slash dst-len))
 433                                (t
 434                                 ;; The something is some directory or other.
 435                                 (setf dst-len
 436                                       (if prev-prev-slash
 437                                           (1+ prev-prev-slash)
 438                                           0))
 439                                 (setf last-slash prev-prev-slash)))))
 440                       (t
 441                        ;; There is nothing before this .., so we need to keep it
 442                        (setf last-slash dst-len)
 443                        (deposit char))))
 444                    (t
 445                     ;; something other than a dot between slashes
 446                     (setf last-slash dst-len)
 447                     (deposit char)))
 448                  (setf dots 0))
 449                 (t
 450                  (setf dots nil)
 451                  (setf (schar dst dst-len) char)
 452                  (incf dst-len)))))
 453       ;; ...finish off
 454       (when (and last-slash (not (zerop last-slash)))
 455         (case dots
 456           (1
 457            ;; We've got  ``foobar/.''
 458            (decf dst-len))
 459           (2
 460            ;; We've got ``foobar/..''
 461            (unless (and (>= last-slash 2)
 462                         (char= (schar dst (1- last-slash)) #\.)
 463                         (char= (schar dst (- last-slash 2)) #\.)
 464                         (or (= last-slash 2)
 465                             (slashp (schar dst (- last-slash 3)))))
 466              (let ((prev-prev-slash
 467                     (position-if #'slashp dst :end last-slash :from-end t)))
 468                (if prev-prev-slash
 469                    (setf dst-len (1+ prev-prev-slash))
 470                    (return-from simplify-win32-namestring
 471                      (coerce ".\\" 'simple-string)))))))))
 472     (cond ((zerop dst-len)
 473            ".\\")
 474           ((= dst-len src-len)
 475            dst)
 476           (t
 477            (subseq dst 0 dst-len)))))