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