- (struct filetime
- (dw-low-datetime dword)
- (dw-high-datetime dword)))
-
-(defun get-process-times ()
- (with-alien ((creation-time (struct filetime))
- (exit-time (struct filetime))
- (kernel-time (struct filetime))
- (user-time (struct filetime)))
- (let ((result (sb!alien:alien-funcall
- (extern-alien
- "GetProcessTimes@20"
- (function bool
- handle
- (* (struct filetime))
- (* (struct filetime))
- (* (struct filetime))
- (* (struct filetime))))
- (get-current-process)
- (addr creation-time)
- (addr exit-time)
- (addr kernel-time)
- (addr user-time))))
- (if (zerop result)
- (win32-error "GetProcessTimes")
- (flet ((filetime-to-100-ns (time)
- (+ (ash (slot time 'dw-high-datetime) 32)
- (slot time 'dw-low-datetime))))
- (values (filetime-to-100-ns creation-time)
- (filetime-to-100-ns exit-time)
- (filetime-to-100-ns kernel-time)
- (filetime-to-100-ns user-time)))))))
+ (struct OSVERSIONINFO
+ (dwOSVersionInfoSize dword)
+ (dwMajorVersion dword)
+ (dwMinorVersion dword)
+ (dwBuildNumber dword)
+ (dwPlatformId dword)
+ (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
+
+(defun get-version-ex ()
+ (with-alien ((info (struct OSVERSIONINFO)))
+ (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
+ (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
+ (values (slot info 'dwMajorVersion)
+ (slot info 'dwMinorVersion)
+ (slot info 'dwBuildNumber)
+ (slot info 'dwPlatformId)
+ (cast (slot info 'szCSDVersion) system-string))
+ (addr info))))
+
+;; GET-COMPUTER-NAME
+;; The GetComputerName function retrieves the NetBIOS name of the local
+;; computer. This name is established at system startup, when the system
+;; reads it from the registry.
+;;
+;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
+(declaim (ftype (function () simple-string) get-computer-name))
+(defun get-computer-name ()
+ (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
+ (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
+ (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
+ (when (zerop (alien-funcall afunc aname (addr length)))
+ (let ((err (get-last-error)))
+ (unless (= err ERROR_BUFFER_OVERFLOW)
+ (win32-error "GetComputerName" err))
+ (free-alien aname)
+ (setf aname (make-system-buffer length))
+ (alien-funcall afunc aname (addr length))))
+ (cast-and-free aname))))
+
+;; File mapping support routines
+(define-alien-routine (#!+sb-unicode "CreateFileMappingW"
+ #!-sb-unicode "CreateFileMappingA"
+ create-file-mapping)
+ handle
+ (handle handle)
+ (security-attributes (* t))
+ (protection dword)
+ (maximum-size-high dword)
+ (maximum-size-low dword)
+ (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+
+(define-alien-routine ("MapViewOfFile" map-view-of-file)
+ system-area-pointer
+ (file-mapping handle)
+ (desired-access dword)
+ (offset-high dword)
+ (offset-low dword)
+ (size dword))
+
+(define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
+ (address (* t)))
+
+(define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
+ (address (* t))
+ (length dword))
+
+;; Constants for CreateFile `disposition'.
+(defconstant file-create-new 1)
+(defconstant file-create-always 2)
+(defconstant file-open-existing 3)
+(defconstant file-open-always 4)
+(defconstant file-truncate-existing 5)
+
+;; access rights
+(defconstant access-generic-read #x80000000)
+(defconstant access-generic-write #x40000000)
+(defconstant access-generic-execute #x20000000)
+(defconstant access-generic-all #x10000000)
+(defconstant access-file-append-data #x4)
+
+;; share modes
+(defconstant file-share-delete #x04)
+(defconstant file-share-read #x01)
+(defconstant file-share-write #x02)
+
+;; CreateFile (the real file-opening workhorse)
+(define-alien-routine (#!+sb-unicode "CreateFileW"
+ #!-sb-unicode "CreateFileA"
+ create-file)
+ handle
+ (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
+ (desired-access dword)
+ (share-mode dword)
+ (security-attributes (* t))
+ (creation-disposition dword)
+ (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)
+
+;; GetFileAttribute is like a tiny subset of fstat(),
+;; enough to distinguish directories from anything else.
+(define-alien-routine (#!+sb-unicode "GetFileAttributesW"
+ #!-sb-unicode "GetFileAttributesA"
+ get-file-attributes)
+ dword
+ (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+
+(define-alien-routine ("CloseHandle" close-handle) bool
+ (handle handle))