+;; 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)))))))
+