;; Next, split the remainder into slash-separated chunks.
(collect ((pieces))
(loop
- (let ((slash (position-if (lambda (c)
- (or (char= c #\/)
- (char= c #\\)))
- namestr :start start :end end)))
- (pieces (cons start (or slash end)))
- (unless slash
- (return))
- (setf start (1+ slash))))
+ (let ((slash (position-if (lambda (c)
+ (or (char= c #\/)
+ (char= c #\\)))
+ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
(values absolute (pieces)))))
(defun parse-win32-namestring (namestring start end)
(typecase piece
((member :up) (write-string ".." s))
(string (write-string piece s))
- (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))))
+ (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+ (when (or directory name type)
+ (write-char #\\ s)))
(when directory
- (write-char #\\ s)
(go :subdir))
:done)
(when name
(unless (stringp name)
(error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
- (write-char #\\ s)
(write-string name s)
(when type
(unless (stringp type)
(when name-needed
(unless pathname-name (lose))
(when (and (null pathname-type)
- (typep pathname-name 'simple-base-string)
+ (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)))
(strings ".")
(strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
+
+;; FIXME: This has been converted rather blindly from the Unix
+;; version, with no reference to any Windows docs what so ever.
+(defun simplify-win32-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))
+ (flet ((deposit (char)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))
+ (slashp (char)
+ (find char "\\/")))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((slashp 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-if #'slashp 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)))))
+ ;; ...finish off
+ (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)
+ (slashp (schar dst (- last-slash 3)))))
+ (let ((prev-prev-slash
+ (position-if #'slashp dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from simplify-win32-namestring
+ (coerce ".\\" 'simple-string)))))))))
+ (cond ((zerop dst-len)
+ ".\\")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))