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 (def!struct (unix-host
  15              (:make-load-form-fun make-host-load-form)
  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-physical-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                   (cond (absolute
 112                          (if home
 113                              (list* :absolute home (dirs))
 114                              (cons :absolute (dirs))))
 115                         ((dirs)
 116                          (cons :relative (dirs)))
 117                         (t
 118                          nil)))
 119                 name
 120                 type
 121                 version)))))
 122
 123 (defun parse-native-unix-namestring (namestring start end as-directory)
 124   (declare (type simple-string namestring)
 125            (type index start end))
 126   (setf namestring (coerce namestring 'simple-string))
 127   (multiple-value-bind (absolute ranges)
 128       (split-at-slashes namestring start end)
 129     (let* ((components (loop for ((start . end) . rest) on ranges
 130                              for piece = (subseq namestring start end)
 131                              collect (if (and (string= piece "..") rest)
 132                                          :up
 133                                          piece)))
 134            (directory (if (and as-directory
 135                                (string/= "" (car (last components))))
 136                           components
 137                           (butlast components)))
 138            (name-and-type
 139             (unless as-directory
 140               (let* ((end (first (last components)))
 141                      (dot (position #\. end :from-end t)))
 142                 ;; FIXME: can we get this dot-interpretation knowledge
 143                 ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
 144                 ;; does slightly more work than that.
 145                 (cond
 146                   ((string= end "")
 147                    (list nil nil))
 148                   ((and dot (> dot 0))
 149                    (list (subseq end 0 dot) (subseq end (1+ dot))))
 150                   (t
 151                    (list end nil)))))))
 152       (values nil
 153               nil
 154               (cons (if absolute :absolute :relative) directory)
 155               (first name-and-type)
 156               (second name-and-type)
 157               nil))))
 158
 159 (/show0 "filesys.lisp 300")
 160
 161 (defun unparse-unix-host (pathname)
 162   (declare (type pathname pathname)
 163            (ignore pathname))
 164   ;; this host designator needs to be recognized as a physical host in
 165   ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
 166   ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
 167   ;; 2002-05-09
 168   "")
 169
 170 (defun unparse-unix-file (pathname)
 171   (declare (type pathname pathname))
 172   (collect ((strings))
 173     (let* ((name (%pathname-name pathname))
 174            (type (%pathname-type pathname))
 175            (type-supplied (not (or (null type) (eq type :unspecific)))))
 176       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
 177       ;; translating logical pathnames to a filesystem without
 178       ;; versions (like Unix).
 179       (when name
 180         (when (and (null type)
 181                    (typep name 'string)
 182                    (> (length name) 0)
 183                    (position #\. name :start 1))
 184           (error "too many dots in the name: ~S" pathname))
 185         (when (and (typep name 'string)
 186                    (string= name ""))
 187           (error "name is of length 0: ~S" pathname))
 188         (strings (unparse-physical-piece name)))
 189       (when type-supplied
 190         (unless name
 191           (error "cannot specify the type without a file: ~S" pathname))
 192         (when (typep type 'simple-string)
 193           (when (position #\. type)
 194             (error "type component can't have a #\. inside: ~S" pathname)))
 195         (strings ".")
 196         (strings (unparse-physical-piece type))))
 197     (apply #'concatenate 'simple-string (strings))))
 198
 199 (/show0 "filesys.lisp 406")
 200
 201 (defun unparse-unix-namestring (pathname)
 202   (declare (type pathname pathname))
 203   (concatenate 'simple-string
 204                (unparse-physical-directory pathname)
 205                (unparse-unix-file pathname)))
 206
 207 (defun unparse-native-unix-namestring (pathname as-file)
 208   (declare (type pathname pathname))
 209   (let* ((directory (pathname-directory pathname))
 210          (name (pathname-name pathname))
 211          (name-present-p (typep name '(not (member nil :unspecific))))
 212          (name-string (if name-present-p name ""))
 213          (type (pathname-type pathname))
 214          (type-present-p (typep type '(not (member nil :unspecific))))
 215          (type-string (if type-present-p type "")))
 216     (when name-present-p
 217       (setf as-file nil))
 218     (coerce
 219      (with-output-to-string (s)
 220        (when directory
 221          (ecase (pop directory)
 222            (:absolute
 223             (let ((next (pop directory)))
 224               (cond ((eq :home next)
 225                      (write-string (user-homedir-namestring) s))
 226                     ((and (consp next) (eq :home (car next)))
 227                      (let ((where (user-homedir-namestring (second next))))
 228                        (if where
 229                            (write-string where s)
 230                            (error "User homedir unknown for: ~S" (second next)))))
 231                     (next
 232                      (push next directory)))
 233               (write-char #\/ s)))
 234            (:relative)))
 235        (loop for (piece . subdirs) on directory
 236           do (typecase piece
 237                ((member :up)
 238                 (write-string ".." s))
 239                (string
 240                 (write-string piece s))
 241                (t
 242                 (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
 243                        piece)))
 244           if (or subdirs (stringp name))
 245           do (write-char #\/ s)
 246           else
 247           do (unless as-file
 248                (write-char #\/ s)))
 249        (if name-present-p
 250            (progn
 251              (unless (stringp name-string) ;some kind of wild field
 252                (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
 253              (write-string name-string s)
 254              (when type-present-p
 255                (unless (stringp type-string) ;some kind of wild field
 256                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
 257                (write-char #\. s)
 258                (write-string type-string s)))
 259            (when type-present-p ; type without a name
 260              (error
 261               "type component without a name component in NATIVE-NAMESTRING: ~S"
 262               type))))
 263      'simple-string)))
 264
 265 (defun unparse-unix-enough (pathname defaults)
 266   (declare (type pathname pathname defaults))
 267   (flet ((lose ()
 268            (error "~S cannot be represented relative to ~S."
 269                   pathname defaults)))
 270     (collect ((strings))
 271       (let* ((pathname-directory (%pathname-directory pathname))
 272              (defaults-directory (%pathname-directory defaults))
 273              (prefix-len (length defaults-directory))
 274              (result-directory
 275               (cond ((null pathname-directory) '(:relative))
 276                     ((eq (car pathname-directory) :relative)
 277                      pathname-directory)
 278                     ((and (> prefix-len 0)
 279                           (>= (length pathname-directory) prefix-len)
 280                           (compare-component (subseq pathname-directory
 281                                                      0 prefix-len)
 282                                              defaults-directory))
 283                      ;; Pathname starts with a prefix of default. So
 284                      ;; just use a relative directory from then on out.
 285                      (cons :relative (nthcdr prefix-len pathname-directory)))
 286                     ((eq (car pathname-directory) :absolute)
 287                      ;; We are an absolute pathname, so we can just use it.
 288                      pathname-directory)
 289                     (t
 290                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
 291         (strings (unparse-physical-directory-list result-directory)))
 292       (let* ((pathname-type (%pathname-type pathname))
 293              (type-needed (and pathname-type
 294                                (not (eq pathname-type :unspecific))))
 295              (pathname-name (%pathname-name pathname))
 296              (name-needed (or type-needed
 297                               (and pathname-name
 298                                    (not (compare-component pathname-name
 299                                                            (%pathname-name
 300                                                             defaults)))))))
 301         (when name-needed
 302           (unless pathname-name (lose))
 303           (when (and (null pathname-type)
 304                      (typep pathname-name 'simple-string)
 305                      (position #\. pathname-name :start 1))
 306             (error "too many dots in the name: ~S" pathname))
 307           (strings (unparse-physical-piece pathname-name)))
 308         (when type-needed
 309           (when (or (null pathname-type) (eq pathname-type :unspecific))
 310             (lose))
 311           (when (typep pathname-type 'simple-string)
 312             (when (position #\. pathname-type)
 313               (error "type component can't have a #\. inside: ~S" pathname)))
 314           (strings ".")
 315           (strings (unparse-physical-piece pathname-type))))
 316       (apply #'concatenate 'simple-string (strings)))))
 317
 318 (defun simplify-unix-namestring (src)
 319   (declare (type simple-string src))
 320   (let* ((src-len (length src))
 321          (dst (make-string src-len :element-type 'character))
 322          (dst-len 0)
 323          (dots 0)
 324          (last-slash nil))
 325     (macrolet ((deposit (char)
 326                  `(progn
 327                     (setf (schar dst dst-len) ,char)
 328                     (incf dst-len))))
 329       (dotimes (src-index src-len)
 330         (let ((char (schar src src-index)))
 331           (cond ((char= char #\.)
 332                  (when dots
 333                    (incf dots))
 334                  (deposit char))
 335                 ((char= char #\/)
 336                  (case dots
 337                    (0
 338                     ;; either ``/...' or ``...//...'
 339                     (unless last-slash
 340                       (setf last-slash dst-len)
 341                       (deposit char)))
 342                    (1
 343                     ;; either ``./...'' or ``..././...''
 344                     (decf dst-len))
 345                    (2
 346                     ;; We've found ..
 347                     (cond
 348                       ((and last-slash (not (zerop last-slash)))
 349                        ;; There is something before this ..
 350                        (let ((prev-prev-slash
 351                               (position #\/ dst :end last-slash :from-end t)))
 352                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
 353                                         last-slash)
 354                                      (char= (schar dst (- last-slash 2)) #\.)
 355                                      (char= (schar dst (1- last-slash)) #\.))
 356                                 ;; The something before this .. is another ..
 357                                 (deposit char)
 358                                 (setf last-slash dst-len))
 359                                (t
 360                                 ;; The something is some directory or other.
 361                                 (setf dst-len
 362                                       (if prev-prev-slash
 363                                           (1+ prev-prev-slash)
 364                                           0))
 365                                 (setf last-slash prev-prev-slash)))))
 366                       (t
 367                        ;; There is nothing before this .., so we need to keep it
 368                        (setf last-slash dst-len)
 369                        (deposit char))))
 370                    (t
 371                     ;; something other than a dot between slashes
 372                     (setf last-slash dst-len)
 373                     (deposit char)))
 374                  (setf dots 0))
 375                 (t
 376                  (setf dots nil)
 377                  (setf (schar dst dst-len) char)
 378                  (incf dst-len))))))
 379     (when (and last-slash (not (zerop last-slash)))
 380       (case dots
 381         (1
 382          ;; We've got  ``foobar/.''
 383          (decf dst-len))
 384         (2
 385          ;; We've got ``foobar/..''
 386          (unless (and (>= last-slash 2)
 387                       (char= (schar dst (1- last-slash)) #\.)
 388                       (char= (schar dst (- last-slash 2)) #\.)
 389                       (or (= last-slash 2)
 390                           (char= (schar dst (- last-slash 3)) #\/)))
 391            (let ((prev-prev-slash
 392                   (position #\/ dst :end last-slash :from-end t)))
 393              (if prev-prev-slash
 394                  (setf dst-len (1+ prev-prev-slash))
 395                  (return-from simplify-unix-namestring
 396                    (coerce "./" 'simple-string))))))))
 397     (cond ((zerop dst-len)
 398            "./")
 399           ((= dst-len src-len)
 400            dst)
 401           (t
 402            (subseq dst 0 dst-len)))))