;;;; pathname parsing for Unix filesystems ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!IMPL") ;;; Take a string and return a list of cons cells that mark the char ;;; separated subseq. The first value is true if absolute directories ;;; location. (defun split-at-slashes (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (let ((absolute (and (/= start end) (char= (schar namestr start) #\/)))) (when absolute (incf start)) ;; Next, split the remainder into slash-separated chunks. (collect ((pieces)) (loop (let ((slash (position #\/ namestr :start start :end end))) (pieces (cons start (or slash end))) (unless slash (return)) (setf start (1+ slash)))) (values absolute (pieces))))) (defun parse-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) (setf namestring (coerce namestring 'simple-base-string)) (multiple-value-bind (absolute pieces) (split-at-slashes namestring start end) (multiple-value-bind (name type version) (let* ((tail (car (last pieces))) (tail-start (car tail)) (tail-end (cdr tail))) (unless (= tail-start tail-end) (setf pieces (butlast pieces)) (extract-name-type-and-version namestring tail-start tail-end))) (when (stringp name) (let ((position (position-if (lambda (char) (or (char= char (code-char 0)) (char= char #\/))) name))) (when position (error 'namestring-parse-error :complaint "can't embed #\\Nul or #\\/ in Unix namestring" :namestring namestring :offset position)))) ;; Now we have everything we want. So return it. (values nil ; no host for Unix namestrings nil ; no device for Unix namestrings (collect ((dirs)) (dolist (piece pieces) (let ((piece-start (car piece)) (piece-end (cdr piece))) (unless (= piece-start piece-end) (cond ((string= namestring ".." :start1 piece-start :end1 piece-end) (dirs :up)) ((string= namestring "**" :start1 piece-start :end1 piece-end) (dirs :wild-inferiors)) (t (dirs (maybe-make-pattern namestring piece-start piece-end))))))) (cond (absolute (cons :absolute (dirs))) ((dirs) (cons :relative (dirs))) (t nil))) name type version)))) (defun parse-native-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) (setf namestring (coerce namestring 'simple-base-string)) (multiple-value-bind (absolute ranges) (split-at-slashes namestring start end) (let* ((components (loop for ((start . end) . rest) on ranges for piece = (subseq namestring start end) collect (if (and (string= piece "..") rest) :up piece))) (name-and-type (let* ((end (first (last components))) (dot (position #\. end :from-end t))) ;; FIXME: can we get this dot-interpretation knowledge ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION ;; does slightly more work than that. (cond ((string= end "") (list nil nil)) ((and dot (> dot 0)) (list (subseq end 0 dot) (subseq end (1+ dot)))) (t (list end nil)))))) (values nil nil (cons (if absolute :absolute :relative) (butlast components)) (first name-and-type) (second name-and-type) nil)))) (/show0 "filesys.lisp 300") (defun unparse-unix-host (pathname) (declare (type pathname pathname) (ignore pathname)) ;; this host designator needs to be recognized as a physical host in ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, ;; 2002-05-09 "") (defun unparse-unix-piece (thing) (etypecase thing ((member :wild) "*") (simple-string (let* ((srclen (length thing)) (dstlen srclen)) (dotimes (i srclen) (case (schar thing i) ((#\* #\? #\[) (incf dstlen)))) (let ((result (make-string dstlen)) (dst 0)) (dotimes (src srclen) (let ((char (schar thing src))) (case char ((#\* #\? #\[) (setf (schar result dst) #\\) (incf dst))) (setf (schar result dst) char) (incf dst))) result))) (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) (etypecase piece (simple-string (strings piece)) (symbol (ecase piece (:multi-char-wild (strings "*")) (:single-char-wild (strings "?")))) (cons (case (car piece) (:character-set (strings "[") (strings (cdr piece)) (strings "]")) (t (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate 'simple-base-string (strings)))))) (defun unparse-unix-directory-list (directory) (declare (type list directory)) (collect ((pieces)) (when directory (ecase (pop directory) (:absolute (pieces "/")) (:relative ;; nothing special )) (dolist (dir directory) (typecase dir ((member :up) (pieces "../")) ((member :back) (error ":BACK cannot be represented in namestrings.")) ((member :wild-inferiors) (pieces "**/")) ((or simple-string pattern (member :wild)) (pieces (unparse-unix-piece dir)) (pieces "/")) (t (error "invalid directory component: ~S" dir))))) (apply #'concatenate 'simple-base-string (pieces)))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) (unparse-unix-directory-list (%pathname-directory pathname))) (defun unparse-unix-file (pathname) (declare (type pathname pathname)) (collect ((strings)) (let* ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (type-supplied (not (or (null type) (eq type :unspecific))))) ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when ;; translating logical pathnames to a filesystem without ;; versions (like Unix). (when name (when (and (null type) (typep name 'string) (> (length name) 0) (position #\. name :start 1)) (error "too many dots in the name: ~S" pathname)) (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) (strings (unparse-unix-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) (when (typep type 'simple-string) (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece type)))) (apply #'concatenate 'simple-base-string (strings)))) (/show0 "filesys.lisp 406") (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) (concatenate 'simple-base-string (unparse-unix-directory pathname) (unparse-unix-file pathname))) (defun unparse-native-unix-namestring (pathname) (declare (type pathname pathname)) (let ((directory (pathname-directory pathname)) (name (pathname-name pathname)) (type (pathname-type pathname))) (coerce (with-output-to-string (s) (when directory (ecase (car directory) (:absolute (write-char #\/ s)) (:relative))) (dolist (piece (cdr directory)) (typecase piece ((member :up) (write-string ".." s)) (string (write-string piece s)) (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) (write-char #\/ s)) (when name (unless (stringp name) (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) (write-string name s) (when type (unless (stringp type) (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) (write-char #\. s) (write-string type s)))) 'simple-base-string))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) (flet ((lose () (error "~S cannot be represented relative to ~S." pathname defaults))) (collect ((strings)) (let* ((pathname-directory (%pathname-directory pathname)) (defaults-directory (%pathname-directory defaults)) (prefix-len (length defaults-directory)) (result-directory (cond ((null pathname-directory) '(:relative)) ((eq (car pathname-directory) :relative) pathname-directory) ((and (> prefix-len 1) (>= (length pathname-directory) prefix-len) (compare-component (subseq pathname-directory 0 prefix-len) defaults-directory)) ;; Pathname starts with a prefix of default. So ;; just use a relative directory from then on out. (cons :relative (nthcdr prefix-len pathname-directory))) ((eq (car pathname-directory) :absolute) ;; We are an absolute pathname, so we can just use it. pathname-directory) (t (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) (strings (unparse-unix-directory-list result-directory))) (let* ((pathname-type (%pathname-type pathname)) (type-needed (and pathname-type (not (eq pathname-type :unspecific)))) (pathname-name (%pathname-name pathname)) (name-needed (or type-needed (and pathname-name (not (compare-component pathname-name (%pathname-name defaults))))))) (when name-needed (unless pathname-name (lose)) (when (and (null pathname-type) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) (strings (unparse-unix-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) (when (typep pathname-type 'simple-base-string) (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece pathname-type)))) (apply #'concatenate 'simple-string (strings)))))