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