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-base-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-base-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)
  89   (declare (type simple-string namestring)
  90            (type index start end))
  91   (setf namestring (coerce namestring 'simple-base-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            (name-and-type
 100             (let* ((end (first (last components)))
 101                    (dot (position #\. end :from-end t)))
 102               ;; FIXME: can we get this dot-interpretation knowledge
 103               ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
 104               ;; does slightly more work than that.
 105               (cond
 106                 ((string= end "")
 107                  (list nil nil))
 108                 ((and dot (> dot 0))
 109                  (list (subseq end 0 dot) (subseq end (1+ dot))))
 110                 (t
 111                  (list end nil))))))
 112       (values nil
 113               nil
 114               (cons (if absolute :absolute :relative) (butlast components))
 115               (first name-and-type)
 116               (second name-and-type)
 117               nil))))
 118
 119 (/show0 "filesys.lisp 300")
 120
 121 (defun unparse-unix-host (pathname)
 122   (declare (type pathname pathname)
 123            (ignore pathname))
 124   ;; this host designator needs to be recognized as a physical host in
 125   ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
 126   ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
 127   ;; 2002-05-09
 128   "")
 129
 130 (defun unparse-unix-piece (thing)
 131   (etypecase thing
 132     ((member :wild) "*")
 133     (simple-string
 134      (let* ((srclen (length thing))
 135             (dstlen srclen))
 136        (dotimes (i srclen)
 137          (case (schar thing i)
 138            ((#\* #\? #\[)
 139             (incf dstlen))))
 140        (let ((result (make-string dstlen))
 141              (dst 0))
 142          (dotimes (src srclen)
 143            (let ((char (schar thing src)))
 144              (case char
 145                ((#\* #\? #\[)
 146                 (setf (schar result dst) #\\)
 147                 (incf dst)))
 148              (setf (schar result dst) char)
 149              (incf dst)))
 150          result)))
 151     (pattern
 152      (collect ((strings))
 153        (dolist (piece (pattern-pieces thing))
 154          (etypecase piece
 155            (simple-string
 156             (strings piece))
 157            (symbol
 158             (ecase piece
 159               (:multi-char-wild
 160                (strings "*"))
 161               (:single-char-wild
 162                (strings "?"))))
 163            (cons
 164             (case (car piece)
 165               (:character-set
 166                (strings "[")
 167                (strings (cdr piece))
 168                (strings "]"))
 169               (t
 170                (error "invalid pattern piece: ~S" piece))))))
 171        (apply #'concatenate
 172               'simple-base-string
 173               (strings))))))
 174
 175 (defun unparse-unix-directory-list (directory)
 176   (declare (type list directory))
 177   (collect ((pieces))
 178     (when directory
 179       (ecase (pop directory)
 180         (:absolute
 181          (pieces "/"))
 182         (:relative
 183          ;; nothing special
 184          ))
 185       (dolist (dir directory)
 186         (typecase dir
 187           ((member :up)
 188            (pieces "../"))
 189           ((member :back)
 190            (error ":BACK cannot be represented in namestrings."))
 191           ((member :wild-inferiors)
 192            (pieces "**/"))
 193           ((or simple-string pattern (member :wild))
 194            (pieces (unparse-unix-piece dir))
 195            (pieces "/"))
 196           (t
 197            (error "invalid directory component: ~S" dir)))))
 198     (apply #'concatenate 'simple-base-string (pieces))))
 199
 200 (defun unparse-unix-directory (pathname)
 201   (declare (type pathname pathname))
 202   (unparse-unix-directory-list (%pathname-directory pathname)))
 203
 204 (defun unparse-unix-file (pathname)
 205   (declare (type pathname pathname))
 206   (collect ((strings))
 207     (let* ((name (%pathname-name pathname))
 208            (type (%pathname-type pathname))
 209            (type-supplied (not (or (null type) (eq type :unspecific)))))
 210       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
 211       ;; translating logical pathnames to a filesystem without
 212       ;; versions (like Unix).
 213       (when name
 214         (when (and (null type)
 215                    (typep name 'string)
 216                    (> (length name) 0)
 217                    (position #\. name :start 1))
 218           (error "too many dots in the name: ~S" pathname))
 219         (when (and (typep name 'string)
 220                    (string= name ""))
 221           (error "name is of length 0: ~S" pathname))
 222         (strings (unparse-unix-piece name)))
 223       (when type-supplied
 224         (unless name
 225           (error "cannot specify the type without a file: ~S" pathname))
 226         (when (typep type 'simple-string)
 227           (when (position #\. type)
 228             (error "type component can't have a #\. inside: ~S" pathname)))
 229         (strings ".")
 230         (strings (unparse-unix-piece type))))
 231     (apply #'concatenate 'simple-base-string (strings))))
 232
 233 (/show0 "filesys.lisp 406")
 234
 235 (defun unparse-unix-namestring (pathname)
 236   (declare (type pathname pathname))
 237   (concatenate 'simple-base-string
 238                (unparse-unix-directory pathname)
 239                (unparse-unix-file pathname)))
 240
 241 (defun unparse-native-unix-namestring (pathname)
 242   (declare (type pathname pathname))
 243   (let ((directory (pathname-directory pathname))
 244         (name (pathname-name pathname))
 245         (type (pathname-type pathname)))
 246     (coerce
 247      (with-output-to-string (s)
 248        (ecase (car directory)
 249          (:absolute (write-char #\/ s))
 250          (:relative))
 251        (dolist (piece (cdr directory))
 252          (typecase piece
 253            ((member :up) (write-string ".." s))
 254            (string (write-string piece s))
 255            (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
 256          (write-char #\/ s))
 257        (when name
 258          (unless (stringp name)
 259            (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
 260          (write-string name s)
 261          (when type
 262            (unless (stringp type)
 263              (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
 264            (write-char #\. s)
 265            (write-string type s))))
 266      'simple-base-string)))
 267
 268 (defun unparse-unix-enough (pathname defaults)
 269   (declare (type pathname pathname defaults))
 270   (flet ((lose ()
 271            (error "~S cannot be represented relative to ~S."
 272                   pathname defaults)))
 273     (collect ((strings))
 274       (let* ((pathname-directory (%pathname-directory pathname))
 275              (defaults-directory (%pathname-directory defaults))
 276              (prefix-len (length defaults-directory))
 277              (result-directory
 278               (cond ((null pathname-directory) '(:relative))
 279                     ((eq (car pathname-directory) :relative)
 280                      pathname-directory)
 281                     ((and (> prefix-len 1)
 282                           (>= (length pathname-directory) prefix-len)
 283                           (compare-component (subseq pathname-directory
 284                                                      0 prefix-len)
 285                                              defaults-directory))
 286                      ;; Pathname starts with a prefix of default. So
 287                      ;; just use a relative directory from then on out.
 288                      (cons :relative (nthcdr prefix-len pathname-directory)))
 289                     ((eq (car pathname-directory) :absolute)
 290                      ;; We are an absolute pathname, so we can just use it.
 291                      pathname-directory)
 292                     (t
 293                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
 294         (strings (unparse-unix-directory-list result-directory)))
 295       (let* ((pathname-type (%pathname-type pathname))
 296              (type-needed (and pathname-type
 297                                (not (eq pathname-type :unspecific))))
 298              (pathname-name (%pathname-name pathname))
 299              (name-needed (or type-needed
 300                               (and pathname-name
 301                                    (not (compare-component pathname-name
 302                                                            (%pathname-name
 303                                                             defaults)))))))
 304         (when name-needed
 305           (unless pathname-name (lose))
 306           (when (and (null pathname-type)
 307                      (position #\. pathname-name :start 1))
 308             (error "too many dots in the name: ~S" pathname))
 309           (strings (unparse-unix-piece pathname-name)))
 310         (when type-needed
 311           (when (or (null pathname-type) (eq pathname-type :unspecific))
 312             (lose))
 313           (when (typep pathname-type 'simple-base-string)
 314             (when (position #\. pathname-type)
 315               (error "type component can't have a #\. inside: ~S" pathname)))
 316           (strings ".")
 317           (strings (unparse-unix-piece pathname-type))))
 318       (apply #'concatenate 'simple-string (strings)))))