src/code/unix-pathname.lisp

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