X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fwin32-pathname.lisp;h=72bb09d2ad27e32d43257d77d1c4efa4cf5f1ba7;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=766c0682ea8058ba3e5e6ac44ef511f9fc153c94;hpb=fe4b3e4b1501dabe0ca212926532506e325c84c0;p=sbcl.git diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 766c068..72bb09d 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -11,6 +11,27 @@ (in-package "SB!IMPL") +(def!struct (win32-host + (:make-load-form-fun make-host-load-form) + (:include host + (parse #'parse-win32-namestring) + (parse-native #'parse-native-win32-namestring) + (unparse #'unparse-win32-namestring) + (unparse-native #'unparse-native-win32-namestring) + (unparse-host #'unparse-win32-host) + (unparse-directory #'unparse-physical-directory) + (unparse-file #'unparse-win32-file) + (unparse-enough #'unparse-win32-enough) + (unparse-directory-separator "\\") + (simplify-namestring #'simplify-win32-namestring) + (customary-case :lower)))) + +(defvar *physical-host* (make-win32-host)) + +;;; +(define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\")) +(define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC")) + (defun extract-device (namestr start end) (declare (type simple-string namestr) (type index start end)) @@ -21,17 +42,9 @@ ;; "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))) + ;; "//UNC" style, saved as :UNC device, with host and share + ;; becoming directory components. + (values :unc (+ start 1))) (t (values nil start)))) (values nil start))) @@ -141,7 +154,17 @@ (type index start end)) (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (device new-start) - (extract-device namestring start end) + (cond ((= (length +unc-file-name-prefix+) + (mismatch +unc-file-name-prefix+ namestring + :start2 start)) + (values :unc (+ start (length +unc-file-name-prefix+)))) + ((= (length +long-file-name-prefix+) + (mismatch +long-file-name-prefix+ namestring + :start2 start)) + (extract-device namestring + (+ start (length +long-file-name-prefix+)) + end)) + (t (extract-device namestring start end))) (multiple-value-bind (absolute ranges) (split-at-slashes-and-backslashes namestring new-start end) (let* ((components (loop for ((start . end) . rest) on ranges @@ -188,6 +211,8 @@ (directory (pathname-directory pathname))) (cond ((or (null device) (eq device :unspecific)) "") + ((eq device :unc) + (if native "\\" "/")) ((and (= 1 (length device)) (alpha-char-p (char device 0))) (concatenate 'simple-string device ":")) ((and (consp directory) (eq :relative (car directory))) @@ -242,39 +267,62 @@ (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 ""))) + (type-string (if type-present-p type "")) + (absolutep (and device (eql :absolute (car directory))))) (when name-present-p (setf as-file nil)) + (when (and absolutep (member :up directory)) + ;; employ merge-pathnames to parse :BACKs into which we turn :UPs + (setf directory + (pathname-directory + (merge-pathnames + (make-pathname :defaults pathname :directory '(:relative)) + (make-pathname :defaults pathname + :directory (substitute :back :up directory)))))) (coerce (with-output-to-string (s) - (when device + (when absolutep + (write-string (case device + (:unc +unc-file-name-prefix+) + (otherwise +long-file-name-prefix+)) s)) + (when (or (not absolutep) (not (member device '(:unc nil)))) (write-string (unparse-win32-device pathname t) s)) (when directory (ecase (pop directory) (:absolute (let ((next (pop directory))) + ;; Don't use USER-HOMEDIR-NAMESTRING, since + ;; it can be specified as C:/User/user + ;; and (native-namestring (user-homedir-pathname)) + ;; will be not equal to it, because it's parsed first. (cond ((eq :home next) - (write-string (user-homedir-namestring) s)) + (write-string (native-namestring (user-homedir-pathname)) + s)) ((and (consp next) (eq :home (car next))) - (let ((where (user-homedir-namestring (second next)))) + (let ((where (user-homedir-pathname (second next)))) (if where - (write-string where s) - (error "User homedir unknown for: ~S" (second next))))) + (write-string (native-namestring where) s) + (error "User homedir unknown for: ~S" + (second next))))) + ;; namestring of user-homedir-pathname already has + ;; // at the end (next - (push next directory))) - (write-char #\\ s))) + (write-char #\\ s) + (push next directory)) + (t + (write-char #\\ s))))) (:relative))) (loop for (piece . subdirs) on 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))) + 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 @@ -285,10 +333,22 @@ (error "ungood type component in NATIVE-NAMESTRING: ~S" type)) (write-char #\. s) (write-string type-string s))) - (when type-present-p ; + (when type-present-p (error "type component without a name component in NATIVE-NAMESTRING: ~S" - type)))) + type))) + (when absolutep + (let ((string (get-output-stream-string s))) + (return-from unparse-native-win32-namestring + (cond ((< (- 260 12) (length string)) + ;; KLUDGE: account for additional length of 8.3 name to make + ;; directories always accessible + (coerce string 'simple-string)) + ((eq :unc device) + (replace + (subseq string (1- (length +unc-file-name-prefix+))) + "\\")) + (t (subseq string (length +long-file-name-prefix+)))))))) 'simple-string))) ;;; FIXME.