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