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