type
version)))))
-(defun parse-native-win32-namestring (namestring start end)
+(defun parse-native-win32-namestring (namestring start end as-directory)
(declare (type simple-string namestring)
(type index start end))
(setf namestring (coerce namestring 'simple-string))
collect (if (and (string= piece "..") rest)
:up
piece)))
+ (directory (if (and as-directory
+ (string/= "" (car (last components))))
+ components
+ (butlast components)))
(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))))))
+ (unless as-directory
+ (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
device
- (cons (if absolute :absolute :relative) (butlast components))
+ (cons (if absolute :absolute :relative) directory)
(first name-and-type)
(second name-and-type)
nil)))))
(unparse-win32-directory pathname)
(unparse-win32-file pathname)))
-(defun unparse-native-win32-namestring (pathname)
- (declare (type pathname pathname))
- (let ((device (pathname-device pathname))
- (directory (pathname-directory pathname))
- (name (pathname-name pathname))
- (type (pathname-type pathname)))
+(defun unparse-native-win32-namestring (pathname as-file)
+ (declare (type pathname pathname)
+ ;; Windows doesn't like directory names with trailing slashes.
+ (ignore as-file))
+ (let* ((device (pathname-device pathname))
+ (directory (pathname-directory pathname))
+ (name (pathname-name pathname))
+ (name-present-p (typep name '(not (member nil :unspecific))))
+ (name-string (if name-present-p name ""))
+ (type (pathname-type pathname))
+ (type-present-p (typep type '(not (member nil :unspecific))))
+ (type-string (if type-present-p type "")))
(coerce
(with-output-to-string (s)
(when device
(typecase piece
((member :up) (write-string ".." s))
(string (write-string piece s))
- (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
- (when (or directory name type)
+ (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+ piece)))
+ (when (or directory name)
(write-char #\\ s)))
(when directory
(go :subdir))
:done)
- (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))))
+ (if name-present-p
+ (progn
+ (unless (stringp name-string) ;some kind of wild field
+ (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
+ (write-string name-string s)
+ (when type-present-p
+ (unless (stringp type-string) ;some kind of wild field
+ (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
+ (write-char #\. s)
+ (write-string type-string s)))
+ (when type-present-p ;
+ (error
+ "type component without a name component in NATIVE-NAMESTRING: ~S"
+ type))))
'simple-string)))
;;; FIXME.
(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)