1 ;;;; This file contains Win32 support routines that SBCL needs to
2 ;;;; implement itself, in addition to those that apply to Win32 in
3 ;;;; unix.lisp. In theory, some of these functions might someday be
4 ;;;; useful to the end user.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB!WIN32")
17 ;;; Alien definitions for commonly used Win32 types. Woe unto whoever
18 ;;; tries to untangle this someday for 64-bit Windows.
20 ;;; FIXME: There used to be many more here, which are now groveled,
21 ;;; but groveling HANDLE makes it unsigned, which currently breaks the
22 ;;; build. --NS 2006-06-18
23 (define-alien-type handle int-ptr)
25 (define-alien-type lispbool (boolean 32))
27 (define-alien-type system-string
28 #!-sb-unicode c-string
29 #!+sb-unicode (c-string :external-format :ucs-2))
31 (defconstant default-environment-length 1024)
33 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
35 (defconstant invalid-handle -1)
39 ;;; Retrieve the calling thread's last-error code value. The
40 ;;; last-error code is maintained on a per-thread basis.
41 (define-alien-routine ("GetLastError" get-last-error) dword)
43 ;;; Flag constants for FORMAT-MESSAGE.
44 (defconstant format-message-from-system #x1000)
46 ;;; Format an error message based on a lookup table. See MSDN for the
47 ;;; full meaning of the all options---most are not used when getting
48 ;;; system error codes.
49 (define-alien-routine ("FormatMessageA" format-message) dword
60 ;;; Get the operating system handle for a C file descriptor. Returns
61 ;;; INVALID-HANDLE on failure.
62 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
65 ;;; Read data from a file handle into a buffer. This may be used
66 ;;; synchronously or with "overlapped" (asynchronous) I/O.
67 (define-alien-routine ("ReadFile" read-file) bool
71 (bytes-read (* dword))
74 ;;; Write data from a buffer to a file handle. This may be used
75 ;;; synchronously or with "overlapped" (asynchronous) I/O.
76 (define-alien-routine ("WriteFile" write-file) bool
79 (bytes-to-write dword)
80 (bytes-written (* dword))
83 ;;; Copy data from a named or anonymous pipe into a buffer without
84 ;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and
85 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
86 ;;; Return TRUE on success, FALSE on failure.
87 (define-alien-routine ("PeekNamedPipe" peek-named-pipe) bool
91 (bytes-read (* dword))
92 (bytes-avail (* dword))
93 (bytes-left-this-message (* dword)))
95 ;;; Flush the console input buffer if HANDLE is a console handle.
96 ;;; Returns true on success, false if the handle does not refer to a
98 (define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool
101 ;;; Read data from the console input buffer without removing it,
102 ;;; without blocking. Buffer should be large enough for LENGTH *
103 ;;; INPUT-RECORD-SIZE bytes.
104 (define-alien-routine ("PeekConsoleInputA" peek-console-input) bool
110 ;;; Listen for input on a Windows file handle. Unlike UNIX, there
111 ;;; isn't a unified interface to do this---we have to know what sort
112 ;;; of handle we have. Of course, there's no way to actually
113 ;;; introspect it, so we have to try various things until we find
114 ;;; something that works. Returns true if there could be input
115 ;;; available, or false if there is not.
116 (defun handle-listen (handle)
117 (with-alien ((avail dword)
118 (buf (array char #.input-record-size)))
120 ;; Make use of the fact that console handles are technically no
121 ;; real handles, and unlike those, have these bits set:
122 (= 3 (logand 3 handle))
123 (return-from handle-listen
124 (alien-funcall (extern-alien "win32_tty_listen"
125 (function boolean handle))
127 (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
128 (return-from handle-listen (plusp avail)))
130 (unless (zerop (peek-console-input handle
133 (return-from handle-listen (plusp avail)))
135 ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
136 ;; HANDLE is a socket.
139 ;;; Listen for input on a C runtime file handle. Returns true if
140 ;;; there could be input available, or false if there is not.
141 (defun fd-listen (fd)
142 (let ((handle (get-osfhandle fd)))
144 (handle-listen handle)
147 ;;; Clear all available input from a file handle.
148 (defun handle-clear-input (handle)
149 (flush-console-input-buffer handle)
150 (with-alien ((buf (array char 1024))
153 (unless (handle-listen handle)
155 (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
160 ;;; Clear all available input from a C runtime file handle.
161 (defun fd-clear-input (fd)
162 (let ((handle (get-osfhandle fd)))
164 (handle-clear-input handle))))
166 ;;;; System Functions
169 (define-alien-routine ("Sleep" millisleep) void
170 (milliseconds dword))
173 (defun sb!unix:nanosleep (sec nsec)
174 (let ((*allow-with-interrupts* *interrupts-enabled*))
176 (let ((timer (sb!impl::os-create-wtimer)))
177 (sb!impl::os-set-wtimer timer sec nsec)
179 (do () ((with-local-interrupts
180 (zerop (sb!impl::os-wait-for-wtimer timer)))))
181 (sb!impl::os-close-wtimer timer))))))
185 (defvar *ansi-codepage* nil)
186 (defvar *oem-codepage* nil)
187 (defvar *codepage-to-external-format* (make-hash-table)))
191 (cp '(;;037 IBM EBCDIC - U.S./Canada
192 (437 :CP437) ;; OEM - United States
193 ;;500 IBM EBCDIC - International
194 ;;708 Arabic - ASMO 708
195 ;;709 Arabic - ASMO 449+, BCON V4
196 ;;710 Arabic - Transparent Arabic
197 ;;720 Arabic - Transparent ASMO
198 ;;737 OEM - Greek (formerly 437G)
200 (850 :CP850) ;; OEM - Multilingual Latin I
201 (852 :CP852) ;; OEM - Latin II
202 (855 :CP855) ;; OEM - Cyrillic (primarily Russian)
203 (857 :CP857) ;; OEM - Turkish
204 ;;858 OEM - Multilingual Latin I + Euro symbol
205 (860 :CP860) ;; OEM - Portuguese
206 (861 :CP861) ;; OEM - Icelandic
207 (862 :CP862) ;; OEM - Hebrew
208 (863 :CP863) ;; OEM - Canadian-French
209 (864 :CP864) ;; OEM - Arabic
210 (865 :CP865) ;; OEM - Nordic
211 (866 :CP866) ;; OEM - Russian
212 (869 :CP869) ;; OEM - Modern Greek
213 ;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2)
214 (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
215 ;;875 IBM EBCDIC - Modern Greek
216 (932 :CP932) ;; ANSI/OEM - Japanese, Shift-JIS
217 ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore)
218 ;;949 ANSI/OEM - Korean (Unified Hangul Code)
219 ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
220 ;;1026 IBM EBCDIC - Turkish (Latin-5)
221 ;;1047 IBM EBCDIC - Latin 1/Open System
222 ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol)
223 ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol)
224 ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
225 ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
226 ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol)
227 ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
228 ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol)
229 ;;1147 IBM EBCDIC - France (20297 + Euro symbol)
230 ;;1148 IBM EBCDIC - International (500 + Euro symbol)
231 ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol)
232 (1200 :UCS-2LE) ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
233 (1201 :UCS-2BE) ;; Unicode UCS-2 Big-Endian
234 (1250 :CP1250) ;; ANSI - Central European
235 (1251 :CP1251) ;; ANSI - Cyrillic
236 (1252 :CP1252) ;; ANSI - Latin I
237 (1253 :CP1253) ;; ANSI - Greek
238 (1254 :CP1254) ;; ANSI - Turkish
239 (1255 :CP1255) ;; ANSI - Hebrew
240 (1256 :CP1256) ;; ANSI - Arabic
241 (1257 :CP1257) ;; ANSI - Baltic
242 (1258 :CP1258) ;; ANSI/OEM - Vietnamese
243 ;;1361 Korean (Johab)
245 ;;10001 MAC - Japanese
246 ;;10002 MAC - Traditional Chinese (Big5)
250 ;;10006 MAC - Greek I
251 (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
252 ;;10008 MAC - Simplified Chinese (GB 2312)
253 ;;10010 MAC - Romania
254 ;;10017 MAC - Ukraine
256 ;;10029 MAC - Latin II
257 ;;10079 MAC - Icelandic
258 ;;10081 MAC - Turkish
259 ;;10082 MAC - Croatia
260 ;;12000 Unicode UCS-4 Little-Endian
261 ;;12001 Unicode UCS-4 Big-Endian
264 ;;20002 Eten - Taiwan
265 ;;20003 IBM5550 - Taiwan
266 ;;20004 TeleText - Taiwan
267 ;;20005 Wang - Taiwan
268 ;;20105 IA5 IRV International Alphabet No. 5 (7-bit)
269 ;;20106 IA5 German (7-bit)
270 ;;20107 IA5 Swedish (7-bit)
271 ;;20108 IA5 Norwegian (7-bit)
272 ;;20127 US-ASCII (7-bit)
274 ;;20269 ISO 6937 Non-Spacing Accent
275 ;;20273 IBM EBCDIC - Germany
276 ;;20277 IBM EBCDIC - Denmark/Norway
277 ;;20278 IBM EBCDIC - Finland/Sweden
278 ;;20280 IBM EBCDIC - Italy
279 ;;20284 IBM EBCDIC - Latin America/Spain
280 ;;20285 IBM EBCDIC - United Kingdom
281 ;;20290 IBM EBCDIC - Japanese Katakana Extended
282 ;;20297 IBM EBCDIC - France
283 ;;20420 IBM EBCDIC - Arabic
284 ;;20423 IBM EBCDIC - Greek
285 ;;20424 IBM EBCDIC - Hebrew
286 ;;20833 IBM EBCDIC - Korean Extended
287 ;;20838 IBM EBCDIC - Thai
288 (20866 :KOI8-R) ;; Russian - KOI8-R
289 ;;20871 IBM EBCDIC - Icelandic
290 ;;20880 IBM EBCDIC - Cyrillic (Russian)
291 ;;20905 IBM EBCDIC - Turkish
292 ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
293 ;;20932 JIS X 0208-1990 & 0121-1990
294 ;;20936 Simplified Chinese (GB2312)
295 ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
297 (21866 :KOI8-U) ;; Ukrainian (KOI8-U)
298 (28591 :LATIN-1) ;; ISO 8859-1 Latin I
299 (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe
300 (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3
301 (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic
302 (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic
303 (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic
304 (28597 :ISO-8859-7) ;; ISO 8859-7 Greek
305 (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
306 (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5
307 (28605 :LATIN-9) ;; ISO 8859-15 Latin 9
309 (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
310 ;;50220 ISO 2022 Japanese with no halfwidth Katakana
311 ;;50221 ISO 2022 Japanese with halfwidth Katakana
312 ;;50222 ISO 2022 Japanese JIS X 0201-1989
313 ;;50225 ISO 2022 Korean
314 ;;50227 ISO 2022 Simplified Chinese
315 ;;50229 ISO 2022 Traditional Chinese
316 ;;50930 Japanese (Katakana) Extended
317 ;;50931 US/Canada and Japanese
318 ;;50933 Korean Extended and Korean
319 ;;50935 Simplified Chinese Extended and Simplified Chinese
320 ;;50936 Simplified Chinese
321 ;;50937 US/Canada and Traditional Chinese
322 ;;50939 Japanese (Latin) Extended and Japanese
323 (51932 :EUC-JP) ;; EUC - Japanese
324 ;;51936 EUC - Simplified Chinese
326 ;;51950 EUC - Traditional Chinese
327 ;;52936 HZ-GB2312 Simplified Chinese
328 ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte)
329 ;;57002 ISCII Devanagari
330 ;;57003 ISCII Bengali
333 ;;57006 ISCII Assamese
335 ;;57008 ISCII Kannada
336 ;;57009 ISCII Malayalam
337 ;;57010 ISCII Gujarati
338 ;;57011 ISCII Punjabi
339 ;;65000 Unicode UTF-7
340 (65001 :UTF8))) ;; Unicode UTF-8
341 (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
344 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
345 ;; the console just behave differently?
347 (declaim (ftype (function () keyword) ansi-codepage))
348 (defun ansi-codepage ()
350 (setq *ansi-codepage*
351 (gethash (alien-funcall (extern-alien "GetACP" (function UINT)))
352 *codepage-to-external-format*
355 (declaim (ftype (function () keyword) oem-codepage))
356 (defun oem-codepage ()
359 (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT)))
360 *codepage-to-external-format*
363 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
364 (declaim (ftype (function () keyword) console-input-codepage))
365 (defun console-input-codepage ()
367 (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT)))
368 *codepage-to-external-format*)
371 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
372 (declaim (ftype (function () keyword) console-output-codepage))
373 (defun console-output-codepage ()
375 (gethash (alien-funcall
376 (extern-alien "GetConsoleOutputCP" (function UINT)))
377 *codepage-to-external-format*)
380 (define-alien-routine ("LocalFree" local-free) void
383 (defmacro cast-and-free (value &key (type 'system-string)
384 (free-function 'free-alien))
385 `(prog1 (cast ,value ,type)
386 (,free-function ,value)))
388 (eval-when (:compile-toplevel :load-toplevel :execute)
389 (defmacro with-funcname ((name description) &body body)
391 ((,name (etypecase ,description
392 (string ,description)
393 (cons (destructuring-bind (s &optional c) ,description
395 (if c #!-sb-unicode "A" #!+sb-unicode "W" "")))))))
398 (defmacro make-system-buffer (x)
399 `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
401 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
402 ;;; macros in this file, are only used in this file, and could be
403 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
405 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
406 (with-funcname (sname name)
408 (declare (optimize (sb!c::float-accuracy 0)))
409 (let ((result (alien-funcall
411 (function ,ret-type ,@arg-types))
413 (declare (ignorable result))
416 ;;; This is like SYSCALL, but if it fails, signal an error instead of
417 ;;; returning error codes. Should only be used for syscalls that will
418 ;;; never really get an error.
419 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
420 (with-funcname (sname name)
422 (declare (optimize (sb!c::float-accuracy 0)))
423 (let ((result (alien-funcall
424 (extern-alien ,sname (function bool ,@arg-types))
427 (win32-error ,sname))
430 (defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
431 (with-funcname (sname name)
432 `(with-alien ((,func (function ,ret-type ,@arg-types)
436 (defmacro void-syscall* ((name &rest arg-types) &rest args)
437 `(syscall* (,name ,@arg-types) (values t 0) ,@args))
439 (defun get-last-error-message (err)
440 "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
441 (with-alien ((amsg (* char)))
442 (syscall (("FormatMessage" t)
443 dword dword dword dword dword (* (* char)) dword dword)
444 (cast-and-free amsg :free-function local-free)
445 (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
446 0 err 0 (addr amsg) 0 0)))
448 (defmacro win32-error (func-name &optional err)
449 `(let ((err-code ,(or err `(get-last-error))))
450 (declare (type (unsigned-byte 32) err-code))
451 (error "~%Win32 Error [~A] - ~A~%~A"
454 (get-last-error-message err-code))))
456 (defun get-folder-namestring (csidl)
457 "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
458 (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
459 (syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
460 (concatenate 'string (cast-and-free apath) "\\")
463 (defun get-folder-pathname (csidl)
464 (parse-native-namestring (get-folder-namestring csidl)))
466 (defun sb!unix:posix-getcwd ()
467 (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
468 (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char))
469 (let ((ret (alien-funcall afunc (1+ max_path) apath)))
471 (win32-error "GetCurrentDirectory"))
472 (when (> ret (1+ max_path))
474 (setf apath (make-system-buffer ret))
475 (alien-funcall afunc ret apath))
476 (cast-and-free apath)))))
478 (defun sb!unix:unix-mkdir (name mode)
479 (declare (type sb!unix:unix-pathname name)
480 (type sb!unix:unix-file-mode mode)
482 (void-syscall* (("CreateDirectory" t) system-string dword) name 0))
484 (defun sb!unix:unix-rename (name1 name2)
485 (declare (type sb!unix:unix-pathname name1 name2))
486 (void-syscall* (("MoveFile" t) system-string system-string) name1 name2))
488 (defun sb!unix::posix-getenv (name)
489 (declare (type simple-string name))
490 (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
491 (with-sysfun (afunc ("GetEnvironmentVariable" t)
492 dword system-string (* char) dword)
493 (let ((ret (alien-funcall afunc name aenv default-environment-length)))
494 (when (> ret default-environment-length)
496 (setf aenv (make-system-buffer ret))
497 (alien-funcall afunc name aenv ret))
500 (free-alien aenv))))))
502 ;; GET-CURRENT-PROCESS
503 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
506 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
507 (declaim (inline get-current-process))
508 (define-alien-routine ("GetCurrentProcess" get-current-process) handle)
510 ;;;; Process time information
512 (defconstant 100ns-per-internal-time-unit
513 (/ 10000000 sb!xc:internal-time-units-per-second))
516 ;; The FILETIME structure is a 64-bit value representing the number of
517 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
519 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
520 (define-alien-type FILETIME (sb!alien:unsigned 64))
522 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
524 `(with-alien ((,creation-time filetime)
525 (,exit-time filetime)
526 (,kernel-time filetime)
527 (,user-time filetime))
528 (syscall* (("GetProcessTimes") handle (* filetime) (* filetime)
529 (* filetime) (* filetime))
531 (get-current-process)
532 (addr ,creation-time)
537 (declaim (inline system-internal-real-time))
540 (declare (unsigned-byte epoch))
541 ;; FIXME: For optimization ideas see the unix implementation.
542 (defun reinit-internal-real-time ()
544 epoch (get-internal-real-time)))
545 (defun get-internal-real-time ()
546 (- (with-alien ((system-time filetime))
547 (syscall (("GetSystemTimeAsFileTime") void (* filetime))
548 (values (floor system-time 100ns-per-internal-time-unit))
552 (defun system-internal-run-time ()
553 (with-process-times (creation-time exit-time kernel-time user-time)
554 (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
556 (define-alien-type hword (unsigned 16))
558 (define-alien-type systemtime
567 (millisecond hword)))
569 ;; Obtained with, but the XC can't deal with that -- but
570 ;; it's not like the value is ever going to change...
571 ;; (with-alien ((filetime filetime)
572 ;; (epoch systemtime))
573 ;; (setf (slot epoch 'year) 1970
574 ;; (slot epoch 'month) 1
575 ;; (slot epoch 'day) 1
576 ;; (slot epoch 'hour) 0
577 ;; (slot epoch 'minute) 0
578 ;; (slot epoch 'second) 0
579 ;; (slot epoch 'millisecond) 0)
580 ;; (syscall (("SystemTimeToFileTime" 8) void
581 ;; (* systemtime) (* filetime))
585 (defconstant +unix-epoch-filetime+ 116444736000000000)
588 (declaim (inline get-time-of-day))
589 (defun get-time-of-day ()
590 "Return the number of seconds and microseconds since the beginning of the
591 UNIX epoch: January 1st 1970."
592 (with-alien ((system-time filetime))
593 (syscall (("GetSystemTimeAsFileTime") void (* filetime))
594 (multiple-value-bind (sec 100ns)
595 (floor (- system-time +unix-epoch-filetime+)
596 (* 100ns-per-internal-time-unit
597 internal-time-units-per-second))
598 (values sec (floor 100ns 10)))
599 (addr system-time))))
602 ;; The SetEnvironmentVariable function sets the contents of the specified
603 ;; environment variable for the current process.
605 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
606 (defun setenv (name value)
607 (declare (type simple-string name value))
608 (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
611 (defmacro c-sizeof (s)
612 "translate alien size (in bits) to c-size (in bytes)"
613 `(/ (alien-size ,s) 8))
616 ;; The OSVERSIONINFO data structure contains operating system version
617 ;; information. The information includes major and minor version numbers,
618 ;; a build number, a platform identifier, and descriptive text about
619 ;; the operating system. This structure is used with the GetVersionEx function.
621 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
622 (define-alien-type nil
623 (struct OSVERSIONINFO
624 (dwOSVersionInfoSize dword)
625 (dwMajorVersion dword)
626 (dwMinorVersion dword)
627 (dwBuildNumber dword)
629 (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
631 (defun get-version-ex ()
632 (with-alien ((info (struct OSVERSIONINFO)))
633 (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
634 (syscall* (("GetVersionEx" t) (* (struct OSVERSIONINFO)))
635 (values (slot info 'dwMajorVersion)
636 (slot info 'dwMinorVersion)
637 (slot info 'dwBuildNumber)
638 (slot info 'dwPlatformId)
639 (cast (slot info 'szCSDVersion) system-string))
643 ;; The GetComputerName function retrieves the NetBIOS name of the local
644 ;; computer. This name is established at system startup, when the system
645 ;; reads it from the registry.
647 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
648 (declaim (ftype (function () simple-string) get-computer-name))
649 (defun get-computer-name ()
650 (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
651 (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
652 (with-sysfun (afunc ("GetComputerName" t) bool (* char) (* dword))
653 (when (zerop (alien-funcall afunc aname (addr length)))
654 (let ((err (get-last-error)))
655 (unless (= err ERROR_BUFFER_OVERFLOW)
656 (win32-error "GetComputerName" err))
658 (setf aname (make-system-buffer length))
659 (alien-funcall afunc aname (addr length))))
660 (cast-and-free aname))))
662 (define-alien-routine ("_lseeki64" lseeki64)
665 (position (signed 64))
668 (define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
671 (new-position long-long :out)
674 ;; File mapping support routines
675 (define-alien-routine (#!+sb-unicode "CreateFileMappingW"
676 #!-sb-unicode "CreateFileMappingA"
680 (security-attributes (* t))
682 (maximum-size-high dword)
683 (maximum-size-low dword)
684 (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
686 (define-alien-routine ("MapViewOfFile" map-view-of-file)
688 (file-mapping handle)
689 (desired-access dword)
694 (define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
697 (define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
701 ;; Constants for CreateFile `disposition'.
702 (defconstant file-create-new 1)
703 (defconstant file-create-always 2)
704 (defconstant file-open-existing 3)
705 (defconstant file-open-always 4)
706 (defconstant file-truncate-existing 5)
709 (defconstant access-generic-read #x80000000)
710 (defconstant access-generic-write #x40000000)
711 (defconstant access-generic-execute #x20000000)
712 (defconstant access-generic-all #x10000000)
713 (defconstant access-file-append-data #x4)
716 (defconstant file-share-delete #x04)
717 (defconstant file-share-read #x01)
718 (defconstant file-share-write #x02)
720 ;; CreateFile (the real file-opening workhorse)
721 (define-alien-routine (#!+sb-unicode "CreateFileW"
722 #!-sb-unicode "CreateFileA"
725 (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
726 (desired-access dword)
728 (security-attributes (* t))
729 (creation-disposition dword)
730 (flags-and-attributes dword)
731 (template-file handle))
733 (defconstant file-attribute-readonly #x1)
734 (defconstant file-attribute-hidden #x2)
735 (defconstant file-attribute-system #x4)
736 (defconstant file-attribute-directory #x10)
737 (defconstant file-attribute-archive #x20)
738 (defconstant file-attribute-device #x40)
739 (defconstant file-attribute-normal #x80)
740 (defconstant file-attribute-temporary #x100)
741 (defconstant file-attribute-sparse #x200)
742 (defconstant file-attribute-reparse-point #x400)
743 (defconstant file-attribute-reparse-compressed #x800)
744 (defconstant file-attribute-reparse-offline #x1000)
745 (defconstant file-attribute-not-content-indexed #x2000)
746 (defconstant file-attribute-encrypted #x4000)
748 (defconstant file-flag-overlapped #x40000000)
749 (defconstant file-flag-sequential-scan #x8000000)
751 ;; GetFileAttribute is like a tiny subset of fstat(),
752 ;; enough to distinguish directories from anything else.
753 (define-alien-routine (#!+sb-unicode "GetFileAttributesW"
754 #!-sb-unicode "GetFileAttributesA"
757 (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
759 (define-alien-routine ("CloseHandle" close-handle) bool
762 (define-alien-routine ("_open_osfhandle" open-osfhandle)
767 ;; Intended to be an imitation of sb!unix:unix-open based on
768 ;; CreateFile, as complete as possibly.
769 ;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
771 (defun unixlike-open (path flags mode &optional revertable)
772 (declare (type sb!unix:unix-pathname path)
774 (type sb!unix:unix-file-mode mode)
776 (let* ((disposition-flags
778 (if (zerop (logand sb!unix:o_creat flags)) 0 #b100)
779 (if (zerop (logand sb!unix:o_excl flags)) 0 #b010)
780 (if (zerop (logand sb!unix:o_trunc flags)) 0 #b001)))
782 ;; there are 8 combinations of creat|excl|trunc, some of
783 ;; them are equivalent. Case stmt below maps them to 5
784 ;; dispositions (see CreateFile manual).
785 (case disposition-flags
786 ((#b110 #b111) file-create-new)
787 ((#b001 #b011) file-truncate-existing)
788 ((#b000 #b010) file-open-existing)
789 (#b100 file-open-always)
790 (#b101 file-create-always))))
794 (if revertable #x10000 0)
795 (if (plusp (logand sb!unix:o_append flags))
796 access-file-append-data
798 (ecase (logand 3 flags)
799 (0 FILE_GENERIC_READ)
800 (1 FILE_GENERIC_WRITE)
801 ((2 3) (logior FILE_GENERIC_READ
802 FILE_GENERIC_WRITE))))
803 (logior FILE_SHARE_READ
808 file-attribute-normal
810 file-flag-sequential-scan)
812 (if (eql handle invalid-handle)
814 (let ((error-code (get-last-error)))
816 (#.error_file_not_found
818 ((#.error_already_exists #.error_file_exists)
820 (otherwise (- error-code)))))
822 ;; FIXME: seeking to the end is not enough for real APPEND
823 ;; semantics, but it's better than nothing.
826 ;; On the other hand, the CL spec implies the "better than
827 ;; nothing" seek-once semantics implemented here, and our
828 ;; POSIX backend is incorrect in implementing :APPEND as
829 ;; O_APPEND. Other CL implementations get this right across
832 ;; Of course, it would be nice if we had :IF-EXISTS
833 ;; :ATOMICALLY-APPEND separately as an extension, and in
834 ;; that case, we will have to worry about supporting it
837 ;; I've tested this only very briefly (on XP and Windows 7),
838 ;; but my impression is that WriteFile (without documenting
839 ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
840 ;; offset in our overlapped structure, WriteFile seeks to the
841 ;; end for us. Should we depend on that? How do we communicate
842 ;; our desire to do so to the runtime?
845 (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
846 (let ((fd (open-osfhandle handle (logior sb!unix::o_binary flags))))
848 (values nil (sb!unix::get-errno))
851 (define-alien-routine ("closesocket" close-socket) int (handle handle))
852 (define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
855 (define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
856 (from-process handle)
859 (to-handle handle :out)
864 (defconstant +handle-flag-inherit+ 1)
865 (defconstant +handle-flag-protect-from-close+ 2)
867 (define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
872 (define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
876 (define-alien-routine getsockopt int
880 (dataword int-ptr :in-out)
881 (socklen int :in-out))
883 (defconstant sol_socket #xFFFF)
884 (defconstant so_type #x1008)
886 (defun socket-handle-p (handle)
887 (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
889 (defconstant ebadf 9)
891 ;;; For sockets, CloseHandle first and closesocket() afterwards is
892 ;;; legal: winsock tracks its handles separately (that's why we have
893 ;;; the problem with simple _close in the first place).
895 ;;; ...Seems to be the problem on some OSes, though. We could
896 ;;; duplicate a handle and attempt close-socket on a duplicated one,
897 ;;; but it also have some problems...
899 ;;; For now, we protect socket handle from close with SetHandleInformation,
900 ;;; then call CRT _close() that fails to close a handle but _gets rid of fd_,
901 ;;; and then we close a handle ourserves.
903 (defun unixlike-close (fd)
904 (let ((handle (get-osfhandle fd)))
905 (flet ((close-protection (enable)
906 (set-handle-information handle 2 (if enable 2 0))))
907 (if (= handle invalid-handle)
910 (when (and (socket-handle-p handle) (close-protection t))
911 (shutdown-socket handle 2)
912 (alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
913 (close-protection nil)
914 (close-socket handle))
915 (sb!unix::void-syscall ("_close" int) fd))))))