X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix-pathname.lisp;h=b4c4d593739eb7bab839d0dfd2ecac86a1728ed8;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=302fce069a586b591e71155773d8bb9cf9e53bf4;hpb=85487ad136765c62450eb42a906c085932217cda;p=sbcl.git diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index 302fce0..b4c4d59 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -15,7 +15,7 @@ ;;; separated subseq. The first value is true if absolute directories ;;; location. (defun split-at-slashes (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let ((absolute (and (/= start end) (char= (schar namestr start) #\/)))) @@ -34,7 +34,7 @@ (defun parse-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (absolute pieces) (split-at-slashes namestring start end) (multiple-value-bind (name type version) @@ -88,7 +88,7 @@ (defun parse-native-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (absolute ranges) (split-at-slashes namestring start end) (let* ((components (loop for ((start . end) . rest) on ranges @@ -169,7 +169,7 @@ (t (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate - 'simple-base-string + 'simple-string (strings)))))) (defun unparse-unix-directory-list (directory) @@ -195,7 +195,7 @@ (pieces "/")) (t (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-base-string (pieces)))) + (apply #'concatenate 'simple-string (pieces)))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) @@ -228,13 +228,13 @@ (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece type)))) - (apply #'concatenate 'simple-base-string (strings)))) + (apply #'concatenate 'simple-string (strings)))) (/show0 "filesys.lisp 406") (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) - (concatenate 'simple-base-string + (concatenate 'simple-string (unparse-unix-directory pathname) (unparse-unix-file pathname))) @@ -264,7 +264,7 @@ (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) (write-char #\. s) (write-string type s)))) - 'simple-base-string))) + 'simple-string))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) @@ -305,15 +305,102 @@ (when name-needed (unless pathname-name (lose)) (when (and (null pathname-type) + (typep pathname-name 'simple-string) (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 (typep pathname-type 'simple-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))))) + +(defun simplify-unix-namestring (src) + (declare (type simple-string src)) + (let* ((src-len (length src)) + (dst (make-string src-len :element-type 'character)) + (dst-len 0) + (dots 0) + (last-slash nil)) + (macrolet ((deposit (char) + `(progn + (setf (schar dst dst-len) ,char) + (incf dst-len)))) + (dotimes (src-index src-len) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((char= char #\/) + (case dots + (0 + ;; either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some directory or other. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; something other than a dot between slashes + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len)))))) + (when (and last-slash (not (zerop last-slash))) + (case dots + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (char= (schar dst (- last-slash 3)) #\/))) + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from simplify-unix-namestring + (coerce "./" 'simple-string)))))))) + (cond ((zerop dst-len) + "./") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len)))))