- (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)))))))
+ (with-alien ((creation-time filetime)
+ (exit-time filetime)
+ (kernel-time filetime)
+ (user-time filetime))
+ (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
+ (* filetime) (* filetime))
+ (values creation-time
+ exit-time
+ kernel-time
+ user-time)
+ (get-current-process)
+ (addr creation-time)
+ (addr exit-time)
+ (addr kernel-time)
+ (addr user-time))))
+
+;; 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" 8 t) system-string system-string)
+ name value))
+
+(defmacro c-sizeof (s)
+ "translate alien size (in bits) to c-size (in bytes)"
+ `(/ (alien-size ,s) 8))
+
+;; OSVERSIONINFO
+;; The OSVERSIONINFO data structure contains operating system version
+;; information. The information includes major and minor version numbers,
+;; a build number, a platform identifier, and descriptive text about
+;; the operating system. This structure is used with the GetVersionEx function.
+;;
+;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
+(define-alien-type nil
+ (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-alien char (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-alien char length))
+ (alien-funcall afunc aname (addr length))))
+ (cast-and-free aname))))