- 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.
"FLUSH-VIEW-OF-FILE"
"FORMAT-MESSAGE"
"GET-FILE-ATTRIBUTES"
+ "GET-FILE-SIZE-EX"
+ "GET-FILE-TYPE"
"GET-LAST-ERROR"
"GET-OSFHANDLE"
"GET-VERSION-EX"
: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))
(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))
(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
;; ... 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
;; 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)
#!+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)
: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)))))
+
\f
(defun sbcl-homedir-pathname ()
(let ((sbcl-home (posix-getenv "SBCL_HOME")))
(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)
((: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)))
(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)
(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)
: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.
: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)
;;; 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
(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))
;; "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)))
(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
(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)))
(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)
(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
(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.
#!-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
(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)))
#!+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.
(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))))
(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))
;; 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)
;; (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))
(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)"
(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
(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)
(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.
;;; 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)))
(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
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");
projects / sbcl.git / commitdiff