From: David Lichteblau Date: Mon, 26 Nov 2012 13:53:17 +0000 (+0100) Subject: Support long file names on Windows; more CRT function avoidance X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dea1e4258272053e8ccda1bf670d43b429878fe2;p=sbcl.git Support long file names on Windows; more CRT function avoidance - Use native namestrings of the form \\?\ and \\?\UNC\ as required. - UNC pathnames now represented using the keyword :UNC in the device. This aspect of the implementation is user-visible, but considered subject to change. - Update a few final holdouts among the file system routines which were still using CRT functions and replace them with native versions: FILE-LENGTH, QUERY-FILE-SYSTEM, DELETE-FILE, DELETE-DIRECTORY. - Sneakily include a getenv change, technically unrelated. Thanks to Anton Kovalenko. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0a0efe8..8e96d24 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2901,6 +2901,8 @@ SBCL itself" "FLUSH-VIEW-OF-FILE" "FORMAT-MESSAGE" "GET-FILE-ATTRIBUTES" + "GET-FILE-SIZE-EX" + "GET-FILE-TYPE" "GET-LAST-ERROR" "GET-OSFHANDLE" "GET-VERSION-EX" diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index f0893eb..789e962 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2043,6 +2043,7 @@ :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) + #!-win32 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) @@ -2052,7 +2053,21 @@ (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) (if (zerop mode) nil - (truncate size (fd-stream-element-size fd-stream))))) + (truncate size (fd-stream-element-size fd-stream)))) + #!+win32 + (let* ((handle (fd-stream-fd fd-stream)) + (element-size (fd-stream-element-size fd-stream))) + (multiple-value-bind (got native-size) + (sb!win32:get-file-size-ex handle 0) + (if (zerop got) + ;; Might be a block device, in which case we fall back to + ;; a non-atomic workaround: + (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr)) + (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd))) + (when (and here there) + (sb!unix:unix-lseek handle here sb!unix:l_set) + (truncate there element-size))) + (truncate native-size element-size))))) (:file-string-length (etypecase arg1 (character (fd-stream-character-size fd-stream arg1)) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index b14adc8..a0bf261 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -291,27 +291,34 @@ (simple-file-perror note-format pathname errno) (return-from query-file-system nil)))) (let ((filename (native-namestring pathname :as-file t))) + #!+win32 + (case query-for + ((:existence :truename) + (multiple-value-bind (file kind) + (sb!win32::native-probe-file-name filename) + (when (and (not file) kind) + (setf file filename)) + ;; The following OR was an AND, but that breaks files like NUL, + ;; for which GetLongPathName succeeds yet GetFileAttributesEx + ;; fails to return the file kind. --DFL + (if (or file kind) + (values + (parse-native-namestring + file + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory (eq :directory kind))) + (fail "couldn't resolve ~A" filename + (- (sb!win32:get-last-error)))))) + (:write-date + (or (sb!win32::native-file-write-date filename) + (fail "couldn't query write date of ~A" filename + (- (sb!win32:get-last-error)))))) + #!-win32 (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size atime mtime) (sb!unix:unix-stat filename) - (declare (ignore ino nlink gid rdev size atime - #!+win32 uid)) - #!+win32 - ;; On win32, stat regards UNC pathnames and device names as - ;; nonexisting, so we check once more with the native API. - (unless existsp - (setf existsp - (let ((handle (sb!win32:create-file - filename 0 0 nil - sb!win32:file-open-existing - 0 0))) - (when (/= -1 handle) - (setf mode - (or mode - (if (logbitp 4 - (sb!win32:get-file-attributes filename)) - sb!unix:s-ifdir 0))) - (progn (sb!win32:close-handle handle) t))))) + (declare (ignore ino nlink gid rdev size atime)) (if existsp (case query-for (:existence (nth-value @@ -339,9 +346,7 @@ ;; ... but without any trailing slash. :as-directory (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)))) - (:author - #!-win32 - (sb!unix:uid-username uid)) + (:author (sb!unix:uid-username uid)) (:write-date (+ unix-to-universal-time mtime))) (progn ;; SBCL has for many years had a policy that a pathname @@ -351,7 +356,6 @@ ;; we must distinguish cases where the symlink exists ;; from ones where there's a loop in the apparent ;; containing directory. - #!-win32 (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev size atime mtime) (sb!unix:unix-lstat filename) @@ -501,9 +505,12 @@ per standard Unix unlink() behaviour." #!+win32 (when (streamp file) (close file)) - (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) - (unless res - (simple-file-perror "Couldn't delete file ~A" namestring err)))) + (multiple-value-bind (res err) + #!-win32 (sb!unix:unix-unlink namestring) + #!+win32 (or (sb!win32::native-delete-file namestring) + (values nil (- (sb!win32:get-last-error)))) + (unless res + (simple-file-perror "couldn't delete ~A" namestring err)))) t) (defun directorize-pathname (pathname) @@ -556,18 +563,27 @@ exist or if is a file or a symbolic link." :classify-symlinks nil) (delete-dir dir)) (delete-dir (dir) - (let* ((namestring (native-namestring dir :as-file t)) - (res (alien-funcall (extern-alien #!-win32 "rmdir" - #!+win32 "_rmdir" - (function int c-string)) - namestring))) - (if (minusp res) - (simple-file-perror "Couldn't delete directory ~A" - namestring (get-errno)) - dir)))) + (let ((namestring (native-namestring dir :as-file t))) + (multiple-value-bind (res errno) + #!+win32 + (or (sb!win32::native-delete-directory namestring) + (values nil (- (sb!win32:get-last-error)))) + #!-win32 + (values + (not (minusp (alien-funcall + (extern-alien "rmdir" + (function int c-string)) + namestring))) + (get-errno)) + (if res + dir + (simple-file-perror + "Could not delete directory ~A" + namestring errno)))))) (if recursive (recurse physical) (delete-dir physical))))) + (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) @@ -686,7 +702,8 @@ matching filenames." (canonicalize-directory (directory) (let (pieces) (dolist (piece directory) - (if (and pieces (member piece '(:back :up))) + (cond + ((and pieces (member piece '(:back :up))) ;; FIXME: We should really canonicalize when we construct ;; pathnames. This is just wrong. (case (car pieces) @@ -698,8 +715,17 @@ matching filenames." ((:relative :up :back) (push piece pieces)) (t - (pop pieces))) - (push piece pieces))) + (pop pieces)))) + ((equal piece ".") + ;; This case only really matters on Windows, + ;; because on POSIX, our call site (TRUENAME via + ;; QUERY-FILE-SYSTEM) only passes in pathnames from + ;; realpath(3), in which /./ has been removed + ;; already. Windows, however, depends on us to + ;; perform this fixup. -- DFL + ) + (t + (push piece pieces)))) (nreverse pieces)))) (let ((name (simplify (pathname-name pathname))) (type (simplify (pathname-type pathname))) @@ -728,6 +754,10 @@ matching filenames." (macrolet ((,iterator () `(funcall ,',one-iter))) ,@body))) + #!+win32 + (sb!win32::native-call-with-directory-iterator + #'iterate ,namestring ,errorp) + #!-win32 (call-with-native-directory-iterator #'iterate ,namestring ,errorp)))) (defun call-with-native-directory-iterator (function namestring errorp) @@ -792,9 +822,7 @@ Experimental: interface subject to change." (let* ((fun (%coerce-callable-to-fun function)) (as-files (eq :as-files directories)) (physical (physicalize-pathname directory)) - ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows - ;; network shares. - (realname (sb!unix:unix-realpath (native-namestring physical :as-file t))) + (realname (query-file-system physical :existence nil)) (canonical (if realname (parse-native-namestring realname (pathname-host physical) @@ -809,34 +837,39 @@ Experimental: interface subject to change." :as-directory (and dirp (not as-files))) physical)))) (with-native-directory-iterator (next dirname :errorp errorp) - (loop for name = (next) - while name - do (let* ((full (concatenate 'string dirname name)) - (kind (native-file-kind full))) - (when kind - (case kind - (:directory - (when directories - (map-it name t))) - (:symlink - (if classify-symlinks - (let* ((tmpname (merge-pathnames - (parse-native-namestring - name nil physical :as-directory nil) - physical)) - (truename (query-file-system tmpname :truename nil))) - (if (or (not truename) - (or (pathname-name truename) (pathname-type truename))) - (when files - (funcall fun tmpname)) - (when directories - (map-it name t)))) - (when files - (map-it name nil)))) - (t - ;; Anything else parses as a file. - (when files - (map-it name nil))))))))))) + (loop + ;; provision for FindFirstFileExW-based iterator that should be used + ;; on Windows: file kind is known instantly there, so we'll have it + ;; returned by (next) soon. + (multiple-value-bind (name kind) (next) + (unless (or name kind) (return)) + (unless kind + (setf kind (native-file-kind + (concatenate 'string dirname name)))) + (when kind + (case kind + (:directory + (when directories + (map-it name t))) + (:symlink + (if classify-symlinks + (let* ((tmpname (merge-pathnames + (parse-native-namestring + name nil physical :as-directory nil) + physical)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (map-it name t)))) + (when files + (map-it name nil)))) + (t + ;; Anything else parses as a file. + (when files + (map-it name nil))))))))))) ;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION ;;; with all DIRECTORIES that match the directory portion of PATHSPEC. @@ -1137,15 +1170,15 @@ Experimental: interface subject to change." :format-control "bad place for a wild pathname" :pathname pathspec)) (let* ((dir (pathname-directory pathname)) - ;; *d-p-d* can have name and type components which would prevent - ;; PROBE-FILE below from working (*default-pathname-defaults* - (make-pathname :directory dir :device (pathname-device pathname)))) - (loop for i from 1 upto (length dir) + (make-pathname :directory dir :device (pathname-device pathname))) + (dev (pathname-device pathname))) + (loop for i from (case dev (:unc 3) (otherwise 2)) + upto (length dir) do (let* ((newpath (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) + :device dev :directory (subseq dir 0 i))) (probed (probe-file newpath))) (unless (directory-pathname-p probed) diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index bd0471f..deb6343 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -75,7 +75,7 @@ ;;; all pathname components (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (def!type pathname-component-tokens () - '(member nil :unspecific :wild))) + '(member nil :unspecific :wild :unc))) (sb!xc:defstruct (pathname (:conc-name %pathname-) (:constructor %make-pathname (host diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 766c068..5cfa995 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -11,6 +11,9 @@ (in-package "SB!IMPL") +(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 +24,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 +136,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 +193,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,12 +249,25 @@ (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) @@ -259,22 +279,23 @@ (let ((where (user-homedir-namestring (second next)))) (if where (write-string where s) - (error "User homedir unknown for: ~S" (second next))))) + (error "User homedir unknown for: ~S" + (second next))))) (next (push next directory))) (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 @@ -288,7 +309,19 @@ (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. diff --git a/src/code/win32.lisp b/src/code/win32.lisp index a01ac36..3bdbf58 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -28,12 +28,46 @@ #!-sb-unicode c-string #!+sb-unicode (c-string :external-format :ucs-2)) +(define-alien-type tchar #!-sb-unicode char + #!+sb-unicode (unsigned 16)) + (defconstant default-environment-length 1024) ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast ;;; to a pointer. (defconstant invalid-handle -1) +(defconstant file-attribute-readonly #x1) +(defconstant file-attribute-hidden #x2) +(defconstant file-attribute-system #x4) +(defconstant file-attribute-directory #x10) +(defconstant file-attribute-archive #x20) +(defconstant file-attribute-device #x40) +(defconstant file-attribute-normal #x80) +(defconstant file-attribute-temporary #x100) +(defconstant file-attribute-sparse #x200) +(defconstant file-attribute-reparse-point #x400) +(defconstant file-attribute-reparse-compressed #x800) +(defconstant file-attribute-reparse-offline #x1000) +(defconstant file-attribute-not-content-indexed #x2000) +(defconstant file-attribute-encrypted #x4000) + +(defconstant file-flag-overlapped #x40000000) +(defconstant file-flag-sequential-scan #x8000000) + +;; Possible results of GetFileType. +(defconstant file-type-disk 1) +(defconstant file-type-char 2) +(defconstant file-type-pipe 3) +(defconstant file-type-remote 4) +(defconstant file-type-unknown 0) + +(defconstant invalid-file-attributes (mod -1 (ash 1 32))) + +;;;; File Type Introspection by handle +(define-alien-routine ("GetFileType" get-file-type) dword + (handle handle)) + ;;;; Error Handling ;;; Retrieve the calling thread's last-error code value. The @@ -428,6 +462,17 @@ (defmacro make-system-buffer (x) `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x)) +(defmacro with-handle ((var initform + &key (close-operator 'close-handle)) + &body body) + `(without-interrupts + (block nil + (let ((,var ,initform)) + (unwind-protect + (with-local-interrupts + ,@body) + (,close-operator ,var)))))) + (define-alien-type pathname-buffer (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0))) @@ -435,6 +480,9 @@ #!+sb-unicode (array char 65536) #!-sb-unicode pathname-buffer) +(defmacro decode-system-string (alien) + `(cast (cast ,alien (* char)) system-string)) + ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other ;;; macros in this file, are only used in this file, and could be ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. @@ -475,12 +523,16 @@ (defun get-last-error-message (err) "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp" - (with-alien ((amsg (* char))) - (syscall (("FormatMessage" t) - dword dword dword dword dword (* (* char)) dword dword) - (cast-and-free amsg :free-function local-free) - (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM) - 0 err 0 (addr amsg) 0 0))) + (let ((message + (with-alien ((amsg (* char))) + (syscall (("FormatMessage" t) + dword dword dword dword dword (* (* char)) dword dword) + (cast-and-free amsg :free-function local-free) + (logior FORMAT_MESSAGE_ALLOCATE_BUFFER + FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_MAX_WIDTH_MASK) + 0 err 0 (addr amsg) 0 0)))) + (and message (string-right-trim '(#\Space) message)))) (defmacro win32-error (func-name &optional err) `(let ((err-code ,(or err `(get-last-error)))) @@ -492,35 +544,39 @@ (defun get-folder-namestring (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" - (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) + (with-alien ((apath pathname-buffer)) (syscall (("SHGetFolderPath" t) int handle int handle dword (* char)) - (concatenate 'string (cast-and-free apath) "\\") - 0 csidl 0 0 apath))) + (concatenate 'string (decode-system-string apath) "\\") + 0 csidl 0 0 (cast apath (* char))))) (defun get-folder-pathname (csidl) (parse-native-namestring (get-folder-namestring csidl))) (defun sb!unix:posix-getcwd () - (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) + (with-alien ((apath pathname-buffer)) (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char)) - (let ((ret (alien-funcall afunc (1+ max_path) apath))) + (let ((ret (alien-funcall afunc (1+ max_path) (cast apath (* char))))) (when (zerop ret) (win32-error "GetCurrentDirectory")) - (when (> ret (1+ max_path)) - (free-alien apath) - (setf apath (make-system-buffer ret)) - (alien-funcall afunc ret apath)) - (cast-and-free apath))))) + (if (> ret (1+ max_path)) + (with-alien ((apath (* char) (make-system-buffer ret))) + (alien-funcall afunc ret apath) + (cast-and-free apath)) + (decode-system-string apath)))))) (defun sb!unix:unix-mkdir (name mode) (declare (type sb!unix:unix-pathname name) (type sb!unix:unix-file-mode mode) (ignore mode)) - (void-syscall* (("CreateDirectory" t) system-string dword) name 0)) + (syscall (("CreateDirectory" t) lispbool system-string (* t)) + (values result (if result 0 (- (get-last-error)))) + name nil)) (defun sb!unix:unix-rename (name1 name2) (declare (type sb!unix:unix-pathname name1 name2)) - (void-syscall* (("MoveFile" t) system-string system-string) name1 name2)) + (syscall (("MoveFile" t) lispbool system-string system-string) + (values result (if result 0 (- (get-last-error)))) + name1 name2)) (defun sb!unix::posix-getenv (name) (declare (type simple-string name)) @@ -556,6 +612,15 @@ ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp? (define-alien-type FILETIME (sb!alien:unsigned 64)) +;; FILETIME definition above is almost correct (on little-endian systems), +;; except for the wrong alignment if used in another structure: the real +;; definition is a struct of two dwords. +;; Let's define FILETIME-MEMBER for that purpose; it will be useful with +;; GetFileAttributesEx and FindFirstFileExW. + +(define-alien-type FILETIME-MEMBER + (struct nil (low dword) (high dword))) + (defmacro with-process-times ((creation-time exit-time kernel-time user-time) &body forms) `(with-alien ((,creation-time filetime) @@ -620,6 +685,9 @@ ;; (addr epoch) ;; (addr filetime))) (defconstant +unix-epoch-filetime+ 116444736000000000) +(defconstant +filetime-unit+ (* 100ns-per-internal-time-unit + internal-time-units-per-second)) +(defconstant +common-lisp-epoch-filetime-seconds+ 9435484800) #!-sb-fluid (declaim (inline get-time-of-day)) @@ -635,15 +703,134 @@ UNIX epoch: January 1st 1970." (values sec (floor 100ns 10))) (addr system-time)))) +;; Data for FindFirstFileExW and GetFileAttributesEx +(define-alien-type find-data + (struct nil + (attributes dword) + (ctime filetime-member) + (atime filetime-member) + (mtime filetime-member) + (size-low dword) + (size-high dword) + (reserved0 dword) + (reserved1 dword) + (long-name (array tchar #.max_path)) + (short-name (array tchar 14)))) + +(define-alien-type file-attributes + (struct nil + (attributes dword) + (ctime filetime-member) + (atime filetime-member) + (mtime filetime-member) + (size-low dword) + (size-high dword))) + +(define-alien-routine ("FindClose" find-close) lispbool + (handle handle)) + +(defun attribute-file-kind (dword) + (if (logtest file-attribute-directory dword) + :directory :file)) + +(defun native-file-write-date (native-namestring) + "Return file write date, represented as CL universal time." + (with-alien ((file-attributes file-attributes)) + (syscall (("GetFileAttributesEx" t) lispbool + system-string int file-attributes) + (and result + (- (floor (deref (cast (slot file-attributes 'mtime) + (* filetime))) + +filetime-unit+) + +common-lisp-epoch-filetime-seconds+)) + native-namestring 0 file-attributes))) + +(defun native-probe-file-name (native-namestring) + "Return truename \(using GetLongPathName\) as primary value, +File kind as secondary. + +Unless kind is false, null truename shouldn't be interpreted as error or file +absense." + (with-alien ((file-attributes file-attributes) + (buffer long-pathname-buffer)) + (syscall (("GetFileAttributesEx" t) lispbool + system-string int file-attributes) + (values + (syscall (("GetLongPathName" t) dword + system-string long-pathname-buffer dword) + (and (plusp result) (decode-system-string buffer)) + native-namestring buffer 32768) + (and result + (attribute-file-kind + (slot file-attributes 'attributes)))) + native-namestring 0 file-attributes))) + +(defun native-delete-file (native-namestring) + (syscall (("DeleteFile" t) lispbool system-string) + result native-namestring)) + +(defun native-delete-directory (native-namestring) + (syscall (("RemoveDirectory" t) lispbool system-string) + result native-namestring)) + +(defun native-call-with-directory-iterator (function namestring errorp) + (declare (type (or null string) namestring) + (function function)) + (when namestring + (with-alien ((find-data find-data)) + (with-handle (handle (syscall (("FindFirstFile" t) handle + system-string find-data) + (if (eql result invalid-handle) + (if errorp + (win32-error "FindFirstFile") + (return)) + result) + (concatenate 'string + namestring "*.*") + find-data) + :close-operator find-close) + (let ((more t)) + (dx-flet ((one-iter () + (tagbody + :next + (when more + (let ((name (decode-system-string + (slot find-data 'long-name))) + (attributes (slot find-data 'attributes))) + (setf more + (syscall (("FindNextFile" t) lispbool + handle find-data) result + handle find-data)) + (cond ((equal name ".") (go :next)) + ((equal name "..") (go :next)) + (t + (return-from one-iter + (values name + (attribute-file-kind + attributes)))))))))) + (funcall function #'one-iter))))))) + ;; SETENV ;; The SetEnvironmentVariable function sets the contents of the specified ;; environment variable for the current process. ;; ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp (defun setenv (name value) - (declare (type simple-string name value)) - (void-syscall* (("SetEnvironmentVariable" t) system-string system-string) - name value)) + (declare (type (or null simple-string) value)) + (if value + (void-syscall* (("SetEnvironmentVariable" t) system-string system-string) + name value) + (void-syscall* (("SetEnvironmentVariable" t) system-string int-ptr) + name 0))) + +;; Let SETENV be an accessor for POSIX-GETENV. +;; +;; DFL: Merged this function because it seems useful to me. But +;; shouldn't we then define it on actual POSIX, too? +(defun (setf sb!unix::posix-getenv) (new-value name) + (if (setenv name new-value) + new-value + (posix-getenv name))) (defmacro c-sizeof (s) "translate alien size (in bits) to c-size (in bytes)" @@ -719,7 +906,7 @@ UNIX epoch: January 1st 1970." (protection dword) (maximum-size-high dword) (maximum-size-low dword) - (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))) + (name system-string)) (define-alien-routine ("MapViewOfFile" map-view-of-file) system-area-pointer @@ -749,13 +936,14 @@ UNIX epoch: January 1st 1970." (defconstant access-generic-execute #x20000000) (defconstant access-generic-all #x10000000) (defconstant access-file-append-data #x4) +(defconstant access-delete #x00010000) ;; share modes (defconstant file-share-delete #x04) (defconstant file-share-read #x01) (defconstant file-share-write #x02) -;; CreateFile (the real file-opening workhorse) +;; CreateFile (the real file-opening workhorse). (define-alien-routine (#!+sb-unicode "CreateFileW" #!-sb-unicode "CreateFileA" create-file) @@ -768,36 +956,10 @@ UNIX epoch: January 1st 1970." (flags-and-attributes dword) (template-file handle)) -(defconstant file-attribute-readonly #x1) -(defconstant file-attribute-hidden #x2) -(defconstant file-attribute-system #x4) -(defconstant file-attribute-directory #x10) -(defconstant file-attribute-archive #x20) -(defconstant file-attribute-device #x40) -(defconstant file-attribute-normal #x80) -(defconstant file-attribute-temporary #x100) -(defconstant file-attribute-sparse #x200) -(defconstant file-attribute-reparse-point #x400) -(defconstant file-attribute-reparse-compressed #x800) -(defconstant file-attribute-reparse-offline #x1000) -(defconstant file-attribute-not-content-indexed #x2000) -(defconstant file-attribute-encrypted #x4000) - -(defconstant file-flag-overlapped #x40000000) -(defconstant file-flag-sequential-scan #x8000000) - -;; Possible results of GetFileType. -(defconstant file-type-disk 1) -(defconstant file-type-char 2) -(defconstant file-type-pipe 3) -(defconstant file-type-remote 4) -(defconstant file-type-unknown 0) - -(defconstant invalid-file-attributes (mod -1 (ash 1 32))) - -;;;; File Type Introspection by handle -(define-alien-routine ("GetFileType" get-file-type) dword - (handle handle)) +;; GetFileSizeEx doesn't work with block devices :[ +(define-alien-routine ("GetFileSizeEx" get-file-size-ex) + bool + (handle handle) (file-size (signed 64) :in-out)) ;; GetFileAttribute is like a tiny subset of fstat(), ;; enough to distinguish directories from anything else. diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 997aa8e..618de2b 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -61,7 +61,7 @@ ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions (sb!xc:deftype pathname-host () '(or sb!impl::host null)) (sb!xc:deftype pathname-device () - '(or simple-string (member nil :unspecific))) + '(or simple-string (member nil :unspecific :unc))) (sb!xc:deftype pathname-directory () 'list) (sb!xc:deftype pathname-name () '(or simple-string sb!impl::pattern (member nil :unspecific :wild))) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index e05e8db..04720a7 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -597,4 +597,25 @@ (let ((*default-pathname-defaults* #p"/tmp/foo")) (ensure-directories-exist "/"))) +(with-test (:name :long-file-name :skipped-on '(not :win32)) + (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory" + "use-the-7zip-file-manager")) + (base (truename + (directory-namestring (or *load-pathname* *compile-pathname*)))) + (shallow (make-pathname :directory `(:relative ,(car x)))) + (shallow (merge-pathnames shallow base)) + (deep (make-pathname + :directory `(:relative ,@(loop repeat 10 appending x)))) + (deep (merge-pathnames deep base)) + (native (sb-ext:native-namestring deep))) + (assert (> (length native) 260)) + (assert (eql 3 (mismatch "\\\\?" native))) + (assert (not (probe-file shallow))) + (unwind-protect + (progn + (ensure-directories-exist deep) + (assert (probe-file deep))) + (sb-ext:delete-directory shallow :recursive t)) + (assert (not (probe-file shallow))))) + ;;;; success diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 125f884..e1e0166 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -186,8 +186,9 @@ main(int argc, char *argv[]) printf(";;; FormatMessage\n"); - defconstant ("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER); - defconstant ("FORMAT_MESSAGE_FROM_SYSTEM", FORMAT_MESSAGE_FROM_SYSTEM); + defconstant("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER); + defconstant("FORMAT_MESSAGE_FROM_SYSTEM", FORMAT_MESSAGE_FROM_SYSTEM); + defconstant("FORMAT_MESSAGE_MAX_WIDTH_MASK", FORMAT_MESSAGE_MAX_WIDTH_MASK); printf(";;; Errors\n");