X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=8edaedae0dc9b1092f9ba8f6c1d6473c11ce6b08;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=f904d6e96e61fd2f26f95706f6011044274f60a6;hpb=2529c316d05494f2bcdeccf98c3a6298ecd08d7d;p=sbcl.git diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index f904d6e..8edaeda 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -14,10 +14,26 @@ (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)) + ;; "//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) @@ -145,55 +161,16 @@ (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)) @@ -214,7 +191,7 @@ ((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))))) @@ -242,7 +219,7 @@ (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)) @@ -250,7 +227,7 @@ (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) @@ -275,25 +252,22 @@ (coerce (with-output-to-string (s) (when device - (write-string device s) - (write-char #\: s)) - (tagbody - (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 (not as-file)) - (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 @@ -353,7 +327,7 @@ (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)) @@ -361,7 +335,7 @@ (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