X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=e91a7b25524425fefbf52f03c5636e405ce9a1e0;hb=de7e68bb937622ca7fe99a1acbf26703b7695cc7;hp=14c5b2fc2b3cbf9d39417f874e779c59c5f99e27;hpb=eb4330788f7b527b7d93a434a6fbb584c0563456;p=sbcl.git diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 14c5b2f..e91a7b2 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -12,7 +12,7 @@ (in-package "SB!IMPL") (defun extract-device (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (if (and (>= end (+ start 2)) (alpha-char-p (char namestr start)) @@ -21,7 +21,7 @@ (values nil start))) (defun split-at-slashes-and-backslashes (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let ((absolute (and (/= start end) (or (char= (schar namestr start) #\/) @@ -31,20 +31,20 @@ ;; 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) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (device new-start) (extract-device namestring start end) (multiple-value-bind (absolute pieces) @@ -97,10 +97,10 @@ 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-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (device new-start) (extract-device namestring start end) (multiple-value-bind (absolute ranges) @@ -110,22 +110,27 @@ 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))))) @@ -187,7 +192,7 @@ (t (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate - 'simple-base-string + 'simple-string (strings)))))) (defun unparse-win32-directory-list (directory) @@ -213,7 +218,7 @@ (pieces "\\")) (t (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-base-string (pieces)))) + (apply #'concatenate 'simple-string (pieces)))) (defun unparse-win32-directory (pathname) (declare (type pathname pathname)) @@ -246,21 +251,29 @@ (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece type)))) - (apply #'concatenate 'simple-base-string (strings)))) + (apply #'concatenate 'simple-string (strings)))) (defun unparse-win32-namestring (pathname) (declare (type pathname pathname)) - (concatenate 'simple-base-string + (concatenate 'simple-string (unparse-win32-device pathname) (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 ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when device @@ -276,22 +289,28 @@ (typecase piece ((member :up) (write-string ".." s)) (string (write-string piece s)) - (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))) + (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) + (when (or directory name) + (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) - (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) - (write-char #\. s) - (write-string type s)))) - 'simple-base-string))) + (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. (defun unparse-win32-enough (pathname defaults) @@ -307,7 +326,7 @@ (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) @@ -333,16 +352,106 @@ (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))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) - (when (typep pathname-type 'simple-base-string) + (when (typep pathname-type 'simple-string) (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (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)))))