+ (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" 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" 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))))
+
+(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
+ (handle handle)
+ (offset long-long)
+ (new-position long-long :out)
+ (whence dword))
+
+(defun lseeki64 (handle offset whence)
+ (multiple-value-bind (moved to-place)
+ (set-file-pointer-ex handle offset whence)
+ (if moved
+ (values to-place 0)
+ (values -1 (- (get-last-error))))))
+
+;; 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 system-string))
+
+(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)
+(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).
+(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))
+
+;; 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.
+(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))
+
+(define-alien-routine ("_open_osfhandle" real-open-osfhandle)
+ int
+ (handle handle)
+ (flags int))
+
+;; Intended to be an imitation of sb!unix:unix-open based on
+;; CreateFile, as complete as possibly.
+;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
+
+(defun unixlike-open (path flags mode &optional revertable)
+ (declare (type sb!unix:unix-pathname path)
+ (type fixnum flags)
+ (type sb!unix:unix-file-mode mode)
+ (ignorable mode))
+ (let* ((disposition-flags
+ (logior
+ (if (zerop (logand sb!unix:o_creat flags)) 0 #b100)
+ (if (zerop (logand sb!unix:o_excl flags)) 0 #b010)
+ (if (zerop (logand sb!unix:o_trunc flags)) 0 #b001)))
+ (create-disposition
+ ;; there are 8 combinations of creat|excl|trunc, some of
+ ;; them are equivalent. Case stmt below maps them to 5
+ ;; dispositions (see CreateFile manual).
+ (case disposition-flags
+ ((#b110 #b111) file-create-new)
+ ((#b001 #b011) file-truncate-existing)
+ ((#b000 #b010) file-open-existing)
+ (#b100 file-open-always)
+ (#b101 file-create-always))))
+ (let ((handle
+ (create-file path
+ (logior
+ (if revertable #x10000 0)
+ (if (plusp (logand sb!unix:o_append flags))
+ access-file-append-data
+ 0)
+ (ecase (logand 3 flags)
+ (0 FILE_GENERIC_READ)
+ (1 FILE_GENERIC_WRITE)
+ ((2 3) (logior FILE_GENERIC_READ
+ FILE_GENERIC_WRITE))))
+ (logior FILE_SHARE_READ
+ FILE_SHARE_WRITE)
+ nil
+ create-disposition
+ (logior
+ file-attribute-normal
+ file-flag-overlapped
+ file-flag-sequential-scan)
+ 0)))
+ (if (eql handle invalid-handle)
+ (values nil
+ (let ((error-code (get-last-error)))
+ (case error-code
+ (#.error_file_not_found
+ sb!unix:enoent)
+ ((#.error_already_exists #.error_file_exists)
+ sb!unix:eexist)
+ (otherwise (- error-code)))))
+ (progn
+ ;; FIXME: seeking to the end is not enough for real APPEND
+ ;; semantics, but it's better than nothing.
+ ;; -- AK
+ ;;
+ ;; On the other hand, the CL spec implies the "better than
+ ;; nothing" seek-once semantics implemented here, and our
+ ;; POSIX backend is incorrect in implementing :APPEND as
+ ;; O_APPEND. Other CL implementations get this right across
+ ;; platforms.
+ ;;
+ ;; Of course, it would be nice if we had :IF-EXISTS
+ ;; :ATOMICALLY-APPEND separately as an extension, and in
+ ;; that case, we will have to worry about supporting it
+ ;; here after all.
+ ;;
+ ;; I've tested this only very briefly (on XP and Windows 7),
+ ;; but my impression is that WriteFile (without documenting
+ ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
+ ;; offset in our overlapped structure, WriteFile seeks to the
+ ;; end for us. Should we depend on that? How do we communicate
+ ;; our desire to do so to the runtime?
+ ;; -- DFL
+ ;;
+ (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
+ (values handle 0))))))
+
+(define-alien-routine ("closesocket" close-socket) int (handle handle))
+(define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
+ (how int))
+
+(define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
+ (from-process handle)
+ (from-handle handle)
+ (to-process handle)
+ (to-handle handle :out)
+ (access dword)
+ (inheritp lispbool)
+ (options dword))
+
+(defconstant +handle-flag-inherit+ 1)
+(defconstant +handle-flag-protect-from-close+ 2)
+
+(define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
+ (handle handle)
+ (mask dword)
+ (flags dword))
+
+(define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
+ (handle handle)
+ (flags dword :out))
+
+(define-alien-routine getsockopt int
+ (handle handle)
+ (level int)
+ (opname int)
+ (dataword int-ptr :in-out)
+ (socklen int :in-out))
+
+(defconstant sol_socket #xFFFF)
+(defconstant so_type #x1008)
+
+(defun socket-handle-p (handle)
+ (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
+
+(defconstant ebadf 9)
+
+;;; For sockets, CloseHandle first and closesocket() afterwards is
+;;; legal: winsock tracks its handles separately (that's why we have
+;;; the problem with simple _close in the first place).
+;;;
+;;; ...Seems to be the problem on some OSes, though. We could
+;;; duplicate a handle and attempt close-socket on a duplicated one,
+;;; but it also have some problems...
+
+(defun unixlike-close (fd)
+ (if (or (zerop (close-socket fd))
+ (close-handle fd))
+ t (values nil ebadf)))
+
+(defconstant +std-input-handle+ -10)
+(defconstant +std-output-handle+ -11)
+(defconstant +std-error-handle+ -12)
+
+(defun get-std-handle-or-null (identity)
+ (let ((handle (alien-funcall
+ (extern-alien "GetStdHandle" (function handle dword))
+ (logand (1- (ash 1 (alien-size dword))) identity))))
+ (and (/= handle invalid-handle)
+ (not (zerop handle))
+ handle)))
+
+(defun get-std-handles ()
+ (values (get-std-handle-or-null +std-input-handle+)
+ (get-std-handle-or-null +std-output-handle+)
+ (get-std-handle-or-null +std-error-handle+)))
+
+(defconstant +duplicate-same-access+ 2)
+
+(defun duplicate-and-unwrap-fd (fd &key inheritp)
+ (let ((me (get-current-process)))
+ (multiple-value-bind (duplicated handle)
+ (duplicate-handle me (real-get-osfhandle fd)
+ me 0 inheritp +duplicate-same-access+)
+ (if duplicated
+ (prog1 handle (real-crt-close fd))
+ (win32-error 'duplicate-and-unwrap-fd)))))
+
+(define-alien-routine ("CreatePipe" create-pipe) lispbool
+ (read-pipe handle :out)
+ (write-pipe handle :out)
+ (security-attributes (* t))
+ (buffer-size dword))
+
+(defun windows-pipe ()
+ (multiple-value-bind (created read-handle write-handle)
+ (create-pipe nil 256)
+ (if created (values read-handle write-handle)
+ (win32-error 'create-pipe))))
+
+(defun windows-isatty (handle)
+ (if (= file-type-char (get-file-type handle))
+ 1 0))
+
+(defun inheritable-handle-p (handle)
+ (multiple-value-bind (got flags)
+ (get-handle-information handle)
+ (if got (plusp (logand flags +handle-flag-inherit+))
+ (win32-error 'inheritable-handle-p))))
+
+(defun (setf inheritable-handle-p) (allow handle)
+ (if (set-handle-information handle
+ +handle-flag-inherit+
+ (if allow +handle-flag-inherit+ 0))
+ allow
+ (win32-error '(setf inheritable-handle-p))))
+
+(defun sb!unix:unix-dup (fd)
+ (let ((me (get-current-process)))
+ (multiple-value-bind (duplicated handle)
+ (duplicate-handle me fd me 0 t +duplicate-same-access+)
+ (if duplicated
+ (values handle 0)
+ (values nil (- (get-last-error)))))))
+
+(defun call-with-crt-fd (thunk handle &optional (flags 0))
+ (multiple-value-bind (duplicate errno)
+ (sb!unix:unix-dup handle)
+ (if duplicate
+ (let ((fd (real-open-osfhandle duplicate flags)))
+ (unwind-protect (funcall thunk fd)
+ (real-crt-close fd)))
+ (values nil errno))))
+
+;;; random seeding
+
+(define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool
+ (handle handle)
+ (length dword)
+ (buffer (* t)))
+
+(define-alien-routine (#!-sb-unicode "CryptAcquireContextA"
+ #!+sb-unicode "CryptAcquireContextW"
+ %crypt-acquire-context) lispbool
+ (handle handle :out)
+ (container system-string)
+ (provider system-string)
+ (provider-type dword)
+ (flags dword))
+
+(define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool
+ (handle handle)
+ (flags dword))
+
+(defun crypt-gen-random (length)
+ (multiple-value-bind (ok context)
+ (%crypt-acquire-context nil nil prov-rsa-full
+ (logior crypt-verifycontext crypt-silent))
+ (unless ok
+ (return-from crypt-gen-random (values nil (get-last-error))))
+ (unwind-protect
+ (let ((data (make-array length :element-type '(unsigned-byte 8))))
+ (with-pinned-objects (data)
+ (if (%crypt-gen-random context length (vector-sap data))
+ data
+ (values nil (get-last-error)))))
+ (unless (%crypt-release-context context 0)
+ (win32-error '%crypt-release-context)))))