(defun extract-device (namestr start end)
(declare (type simple-string namestr)
(type index start end))
- (if (and (>= end (+ start 2))
- (alpha-char-p (char namestr start))
- (eql (char namestr (1+ start)) #\:))
- (values (string (char namestr start)) (+ start 2))
+ (if (>= end (+ start 2))
+ (let ((c0 (char namestr start))
+ (c1 (char namestr (1+ start))))
+ (cond ((and (eql c1 #\:) (alpha-char-p c0))
+ ;; "X:" style, saved as X
+ (values (string (char namestr start)) (+ start 2)))
+ ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3)))
+ ;; "//UNC" style, saved as UNC
+ ;; FIXME: at unparsing time we tell these apart by length,
+ ;; which seems a bit lossy -- presumably one-letter UNC
+ ;; hosts can exist as well. That seems a less troublesome
+ ;; restriction than disallowing UNC hosts whose names match
+ ;; logical pathname hosts... Time will tell -- both LispWorks
+ ;; and ACL use the host component for UNC hosts, so maybe
+ ;; we will end up there as well.
+ (let ((p (or (position c0 namestr :start (+ start 3) :end end)
+ end)))
+ (values (subseq namestr (+ start 2) p) p)))
+ (t
+ (values nil start))))
(values nil start)))
(defun split-at-slashes-and-backslashes (namestr start end)
(defun unparse-win32-device (pathname)
(declare (type pathname pathname))
- (let ((device (pathname-device pathname)))
- (if (or (null device) (eq device :unspecific))
- ""
- (concatenate 'simple-string (string device) ":"))))
-
-(defun unparse-win32-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-string
- (strings))))))
+ (let ((device (pathname-device pathname))
+ (directory (pathname-directory pathname)))
+ (cond ((or (null device) (eq device :unspecific))
+ "")
+ ((and (= 1 (length device)) (alpha-char-p (char device 0)))
+ (concatenate 'simple-string device ":"))
+ ((and (consp directory) (eq :relative (car directory)))
+ (error "No printed representation for a relative UNC pathname."))
+ (t
+ (concatenate 'simple-string "\\\\" device)))))
(defun unparse-win32-directory-list (directory)
(declare (type list directory))
((member :wild-inferiors)
(pieces "**\\"))
((or simple-string pattern (member :wild))
- (pieces (unparse-unix-piece dir))
+ (pieces (unparse-physical-piece dir))
(pieces "\\"))
(t
(error "invalid directory component: ~S" dir)))))
(when (and (typep name 'string)
(string= name ""))
(error "name is of length 0: ~S" pathname))
- (strings (unparse-unix-piece name)))
+ (strings (unparse-physical-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
- (strings (unparse-unix-piece type))))
+ (strings (unparse-physical-piece type))))
(apply #'concatenate 'simple-string (strings))))
(defun unparse-win32-namestring (pathname)
(unparse-win32-file 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))
+ (declare (type pathname pathname))
(let* ((device (pathname-device pathname))
(directory (pathname-directory pathname))
(name (pathname-name pathname))
(type (pathname-type pathname))
(type-present-p (typep type '(not (member nil :unspecific))))
(type-string (if type-present-p type "")))
+ (when name-present-p
+ (setf as-file nil))
(coerce
(with-output-to-string (s)
(when device
- (write-string device s)
- (write-char #\: s))
- (tagbody
- (when directory
- (ecase (pop directory)
- (:absolute (write-char #\\ s))
- (:relative)))
- (unless directory (go :done))
- :subdir
- (let ((piece (pop directory)))
- (typecase piece
- ((member :up) (write-string ".." s))
- (string (write-string piece s))
- (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
- piece)))
- (when (or directory name)
- (write-char #\\ s)))
- (when directory
- (go :subdir))
- :done)
+ (write-string (unparse-win32-device pathname) s))
+ (when directory
+ (ecase (car directory)
+ (:absolute (write-char #\\ s))
+ (:relative)))
+ (loop for (piece . subdirs) on (cdr directory)
+ do (typecase piece
+ ((member :up) (write-string ".." s))
+ (string (write-string piece s))
+ (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+ piece)))
+ if (or subdirs (stringp name))
+ do (write-char #\\ s)
+ else
+ do (unless as-file
+ (write-char #\\ s)))
(if name-present-p
(progn
(unless (stringp name-string) ;some kind of wild field
(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 (unparse-physical-piece pathname-name)))
(when type-needed
(when (or (null pathname-type) (eq pathname-type :unspecific))
(lose))
(when (position #\. pathname-type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
- (strings (unparse-unix-piece pathname-type))))
+ (strings (unparse-physical-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
;; FIXME: This has been converted rather blindly from the Unix
projects / sbcl.git / blobdiff