(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))
- (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 device, with host and share
+ ;; becoming directory components.
+ (values :unc (+ start 1)))
+ (t
+ (values nil start))))
(values nil start)))
(defun split-at-slashes-and-backslashes (namestr start end)
(declare (type simple-string namestr)
(type index start end))
+ ;; FIXME: There is a fundamental brokenness in using the same
+ ;; character as escape character and directory separator in
+ ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
+ ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
+ ;; (:ABSOLUTE :WILD)! See lp#673625.
(let ((absolute (and (/= start end)
(or (char= (schar namestr start) #\/)
(char= (schar namestr start) #\\)))))
;; 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)
name)))
(when position
(error 'namestring-parse-error
- :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
+ :complaint "can't embed #\\Nul or #\\/ in Windows namestring"
:namestring namestring
:offset position))))
- ;; Now we have everything we want. So return it.
- (values nil ; no host for Win32 namestrings
- device
- (collect ((dirs))
- (dolist (piece pieces)
- (let ((piece-start (car piece))
- (piece-end (cdr piece)))
- (unless (= piece-start piece-end)
- (cond ((string= namestring ".."
- :start1 piece-start
- :end1 piece-end)
- (dirs :up))
- ((string= namestring "**"
- :start1 piece-start
- :end1 piece-end)
- (dirs :wild-inferiors))
- (t
- (dirs (maybe-make-pattern namestring
- piece-start
- piece-end)))))))
- (cond (absolute
- (cons :absolute (dirs)))
- ((dirs)
- (cons :relative (dirs)))
- (t
- nil)))
- name
- type
- version)))))
-(defun parse-native-win32-namestring (namestring start end)
+ (let (home)
+ ;; Deal with ~ and ~user.
+ (when (car pieces)
+ (destructuring-bind (start . end) (car pieces)
+ (when (and (not absolute)
+ (not (eql start end))
+ (string= namestring "~"
+ :start1 start
+ :end1 (1+ start)))
+ (setf absolute t)
+ (if (> end (1+ start))
+ (setf home (list :home (subseq namestring (1+ start) end)))
+ (setf home :home))
+ (pop pieces))))
+
+ ;; Now we have everything we want. So return it.
+ (values nil ; no host for Win32 namestrings
+ device
+ (collect ((dirs))
+ (dolist (piece pieces)
+ (let ((piece-start (car piece))
+ (piece-end (cdr piece)))
+ (unless (= piece-start piece-end)
+ (cond ((string= namestring ".."
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestring "**"
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestring
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (if home
+ (list* :absolute home (dirs))
+ (cons :absolute (dirs))))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version))))))
+
+(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))
(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
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)))))
;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good.
"")
-(defun unparse-win32-device (pathname)
+(defun unparse-win32-device (pathname &optional native)
(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))))))
-
-(defun unparse-win32-directory-list (directory)
- (declare (type list directory))
- (collect ((pieces))
- (when directory
- (ecase (pop directory)
- (:absolute
- (pieces "\\"))
- (:relative
- ;; nothing special
- ))
- (dolist (dir directory)
- (typecase dir
- ((member :up)
- (pieces "..\\"))
- ((member :back)
- (error ":BACK cannot be represented in namestrings."))
- ((member :wild-inferiors)
- (pieces "**\\"))
- ((or simple-string pattern (member :wild))
- (pieces (unparse-unix-piece dir))
- (pieces "\\"))
+ (let ((device (pathname-device pathname))
+ (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)))
+ (error "No printed representation for a relative UNC pathname."))
(t
- (error "invalid directory component: ~S" dir)))))
- (apply #'concatenate 'simple-string (pieces))))
-
-(defun unparse-win32-directory (pathname)
- (declare (type pathname pathname))
- (unparse-win32-directory-list (%pathname-directory pathname)))
+ (if native
+ (concatenate 'simple-string "\\\\" device)
+ (concatenate 'simple-string "//" device))))))
(defun unparse-win32-file (pathname)
(declare (type pathname pathname))
(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)
(declare (type pathname pathname))
(concatenate 'simple-string
(unparse-win32-device pathname)
- (unparse-win32-directory pathname)
+ (unparse-physical-directory pathname)
(unparse-win32-file pathname)))
-(defun unparse-native-win32-namestring (pathname)
+(defun unparse-native-win32-namestring (pathname as-file)
(declare (type pathname pathname))
- (let ((device (pathname-device pathname))
- (directory (pathname-directory pathname))
- (name (pathname-name pathname))
- (type (pathname-type pathname)))
+ (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 ""))
+ (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
- (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 piece in NATIVE-NAMESTRING: ~S" piece))))
- (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))))
+ (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 (native-namestring (user-homedir-pathname))
+ s))
+ ((and (consp next) (eq :home (car next)))
+ (let ((where (user-homedir-pathname (second next))))
+ (if where
+ (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
+ (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)))
+ (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)))
+ (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.
(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)
pathname-directory)
(t
(bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
- (strings (unparse-unix-directory-list result-directory)))
+ (strings (unparse-physical-directory-list result-directory)))
(let* ((pathname-type (%pathname-type pathname))
(type-needed (and pathname-type
(not (eq pathname-type :unspecific))))
(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
+;; 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)))))