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