;;; 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) #\/))))
(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)
(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
(t
(error "invalid pattern piece: ~S" piece))))))
(apply #'concatenate
- 'simple-base-string
+ 'simple-string
(strings))))))
(defun unparse-unix-directory-list (directory)
(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))
(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)))
(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))
(cond ((null pathname-directory) '(:relative))
((eq (car pathname-directory) :relative)
pathname-directory)
- ((and (> prefix-len 1)
+ ((and (> prefix-len 0)
(>= (length pathname-directory) prefix-len)
(compare-component (subseq pathname-directory
0 prefix-len)
(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)))))
projects / sbcl.git / blobdiff