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 (define-alien-type tchar
#!-sb-unicode char
32 #!+sb-unicode
(unsigned 16))
34 (defconstant default-environment-length
1024)
36 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
38 (defconstant invalid-handle -
1)
40 (defconstant file-attribute-readonly
#x1
)
41 (defconstant file-attribute-hidden
#x2
)
42 (defconstant file-attribute-system
#x4
)
43 (defconstant file-attribute-directory
#x10
)
44 (defconstant file-attribute-archive
#x20
)
45 (defconstant file-attribute-device
#x40
)
46 (defconstant file-attribute-normal
#x80
)
47 (defconstant file-attribute-temporary
#x100
)
48 (defconstant file-attribute-sparse
#x200
)
49 (defconstant file-attribute-reparse-point
#x400
)
50 (defconstant file-attribute-reparse-compressed
#x800
)
51 (defconstant file-attribute-reparse-offline
#x1000
)
52 (defconstant file-attribute-not-content-indexed
#x2000
)
53 (defconstant file-attribute-encrypted
#x4000
)
55 (defconstant file-flag-overlapped
#x40000000
)
56 (defconstant file-flag-sequential-scan
#x8000000
)
58 ;; Possible results of GetFileType.
59 (defconstant file-type-disk
1)
60 (defconstant file-type-char
2)
61 (defconstant file-type-pipe
3)
62 (defconstant file-type-remote
4)
63 (defconstant file-type-unknown
0)
65 (defconstant invalid-file-attributes
(mod -
1 (ash 1 32)))
67 ;;;; File Type Introspection by handle
68 (define-alien-routine ("GetFileType" get-file-type
) dword
73 ;;; Retrieve the calling thread's last-error code value. The
74 ;;; last-error code is maintained on a per-thread basis.
75 (define-alien-routine ("GetLastError" get-last-error
) dword
)
77 ;;; Get the operating system handle for a C file descriptor. Returns
78 ;;; INVALID-HANDLE on failure.
79 (define-alien-routine ("_get_osfhandle" get-osfhandle
) handle
82 (define-alien-routine ("_close" crt-close
) int
85 ;;; Read data from a file handle into a buffer. This may be used
86 ;;; synchronously or with "overlapped" (asynchronous) I/O.
87 (define-alien-routine ("ReadFile" read-file
) bool
91 (bytes-read (* dword
))
94 ;;; Write data from a buffer to a file handle. This may be used
95 ;;; synchronously or with "overlapped" (asynchronous) I/O.
96 (define-alien-routine ("WriteFile" write-file
) bool
99 (bytes-to-write dword
)
100 (bytes-written (* dword
))
103 ;;; Copy data from a named or anonymous pipe into a buffer without
104 ;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and
105 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
106 ;;; Return TRUE on success, FALSE on failure.
107 (define-alien-routine ("PeekNamedPipe" peek-named-pipe
) bool
111 (bytes-read (* dword
))
112 (bytes-avail (* dword
))
113 (bytes-left-this-message (* dword
)))
115 ;;; Flush the console input buffer if HANDLE is a console handle.
116 ;;; Returns true on success, false if the handle does not refer to a
118 (define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer
) bool
121 ;;; Read data from the console input buffer without removing it,
122 ;;; without blocking. Buffer should be large enough for LENGTH *
123 ;;; INPUT-RECORD-SIZE bytes.
124 (define-alien-routine ("PeekConsoleInputA" peek-console-input
) bool
130 (define-alien-routine "socket_input_available" int
133 (define-alien-routine "console_handle_p" boolean
136 ;;; Listen for input on a Windows file handle. Unlike UNIX, there
137 ;;; isn't a unified interface to do this---we have to know what sort
138 ;;; of handle we have. Of course, there's no way to actually
139 ;;; introspect it, so we have to try various things until we find
140 ;;; something that works. Returns true if there could be input
141 ;;; available, or false if there is not.
142 (defun handle-listen (handle)
143 (cond ((console-handle-p handle
)
144 (alien-funcall (extern-alien "win32_tty_listen"
145 (function boolean handle
))
148 (with-alien ((avail dword
))
150 (unless (zerop (peek-named-pipe handle nil
0 nil
(addr avail
) nil
))
151 (return-from handle-listen
(plusp avail
))))
152 (let ((res (socket-input-available handle
)))
154 (return-from handle-listen
(= res
1))))
157 ;;; Clear all available input from a file handle.
158 (defun handle-clear-input (handle)
159 (flush-console-input-buffer handle
)
160 (with-alien ((buf (array char
1024))
163 (unless (handle-listen handle
)
165 (when (zerop (read-file handle
(cast buf
(* t
)) 1024 (addr count
) nil
))
170 ;;;; System Functions
173 (define-alien-routine ("Sleep" millisleep
) void
174 (milliseconds dword
))
177 (defun sb!unix
:nanosleep
(sec nsec
)
178 (let ((*allow-with-interrupts
* *interrupts-enabled
*))
180 (let ((timer (sb!impl
::os-create-wtimer
)))
181 (sb!impl
::os-set-wtimer timer sec nsec
)
183 (do () ((with-local-interrupts
184 (zerop (sb!impl
::os-wait-for-wtimer timer
)))))
185 (sb!impl
::os-close-wtimer timer
))))))
187 (define-alien-routine ("win32_wait_object_or_signal" wait-object-or-signal
)
193 (defvar *ansi-codepage
* nil
)
194 (defvar *oem-codepage
* nil
)
195 (defvar *codepage-to-external-format
* (make-hash-table)))
199 (cp '(;;037 IBM EBCDIC - U.S./Canada
200 (437 :CP437
) ;; OEM - United States
201 ;;500 IBM EBCDIC - International
202 ;;708 Arabic - ASMO 708
203 ;;709 Arabic - ASMO 449+, BCON V4
204 ;;710 Arabic - Transparent Arabic
205 ;;720 Arabic - Transparent ASMO
206 ;;737 OEM - Greek (formerly 437G)
208 (850 :CP850
) ;; OEM - Multilingual Latin I
209 (852 :CP852
) ;; OEM - Latin II
210 (855 :CP855
) ;; OEM - Cyrillic (primarily Russian)
211 (857 :CP857
) ;; OEM - Turkish
212 ;;858 OEM - Multilingual Latin I + Euro symbol
213 (860 :CP860
) ;; OEM - Portuguese
214 (861 :CP861
) ;; OEM - Icelandic
215 (862 :CP862
) ;; OEM - Hebrew
216 (863 :CP863
) ;; OEM - Canadian-French
217 (864 :CP864
) ;; OEM - Arabic
218 (865 :CP865
) ;; OEM - Nordic
219 (866 :CP866
) ;; OEM - Russian
220 (869 :CP869
) ;; OEM - Modern Greek
221 ;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2)
222 (874 :CP874
) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
223 ;;875 IBM EBCDIC - Modern Greek
224 (932 :CP932
) ;; ANSI/OEM - Japanese, Shift-JIS
225 ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore)
226 ;;949 ANSI/OEM - Korean (Unified Hangul Code)
227 ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
228 ;;1026 IBM EBCDIC - Turkish (Latin-5)
229 ;;1047 IBM EBCDIC - Latin 1/Open System
230 ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol)
231 ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol)
232 ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
233 ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
234 ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol)
235 ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
236 ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol)
237 ;;1147 IBM EBCDIC - France (20297 + Euro symbol)
238 ;;1148 IBM EBCDIC - International (500 + Euro symbol)
239 ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol)
240 (1200 :UCS-2LE
) ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
241 (1201 :UCS-2BE
) ;; Unicode UCS-2 Big-Endian
242 (1250 :CP1250
) ;; ANSI - Central European
243 (1251 :CP1251
) ;; ANSI - Cyrillic
244 (1252 :CP1252
) ;; ANSI - Latin I
245 (1253 :CP1253
) ;; ANSI - Greek
246 (1254 :CP1254
) ;; ANSI - Turkish
247 (1255 :CP1255
) ;; ANSI - Hebrew
248 (1256 :CP1256
) ;; ANSI - Arabic
249 (1257 :CP1257
) ;; ANSI - Baltic
250 (1258 :CP1258
) ;; ANSI/OEM - Vietnamese
251 ;;1361 Korean (Johab)
253 ;;10001 MAC - Japanese
254 ;;10002 MAC - Traditional Chinese (Big5)
258 ;;10006 MAC - Greek I
259 (10007 :X-MAC-CYRILLIC
) ;; MAC - Cyrillic
260 ;;10008 MAC - Simplified Chinese (GB 2312)
261 ;;10010 MAC - Romania
262 ;;10017 MAC - Ukraine
264 ;;10029 MAC - Latin II
265 ;;10079 MAC - Icelandic
266 ;;10081 MAC - Turkish
267 ;;10082 MAC - Croatia
268 ;;12000 Unicode UCS-4 Little-Endian
269 ;;12001 Unicode UCS-4 Big-Endian
272 ;;20002 Eten - Taiwan
273 ;;20003 IBM5550 - Taiwan
274 ;;20004 TeleText - Taiwan
275 ;;20005 Wang - Taiwan
276 ;;20105 IA5 IRV International Alphabet No. 5 (7-bit)
277 ;;20106 IA5 German (7-bit)
278 ;;20107 IA5 Swedish (7-bit)
279 ;;20108 IA5 Norwegian (7-bit)
280 ;;20127 US-ASCII (7-bit)
282 ;;20269 ISO 6937 Non-Spacing Accent
283 ;;20273 IBM EBCDIC - Germany
284 ;;20277 IBM EBCDIC - Denmark/Norway
285 ;;20278 IBM EBCDIC - Finland/Sweden
286 ;;20280 IBM EBCDIC - Italy
287 ;;20284 IBM EBCDIC - Latin America/Spain
288 ;;20285 IBM EBCDIC - United Kingdom
289 ;;20290 IBM EBCDIC - Japanese Katakana Extended
290 ;;20297 IBM EBCDIC - France
291 ;;20420 IBM EBCDIC - Arabic
292 ;;20423 IBM EBCDIC - Greek
293 ;;20424 IBM EBCDIC - Hebrew
294 ;;20833 IBM EBCDIC - Korean Extended
295 ;;20838 IBM EBCDIC - Thai
296 (20866 :KOI8-R
) ;; Russian - KOI8-R
297 ;;20871 IBM EBCDIC - Icelandic
298 ;;20880 IBM EBCDIC - Cyrillic (Russian)
299 ;;20905 IBM EBCDIC - Turkish
300 ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
301 ;;20932 JIS X 0208-1990 & 0121-1990
302 ;;20936 Simplified Chinese (GB2312)
303 ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
305 (21866 :KOI8-U
) ;; Ukrainian (KOI8-U)
306 (28591 :LATIN-1
) ;; ISO 8859-1 Latin I
307 (28592 :ISO-8859-2
) ;; ISO 8859-2 Central Europe
308 (28593 :ISO-8859-3
) ;; ISO 8859-3 Latin 3
309 (28594 :ISO-8859-4
) ;; ISO 8859-4 Baltic
310 (28595 :ISO-8859-5
) ;; ISO 8859-5 Cyrillic
311 (28596 :ISO-8859-6
) ;; ISO 8859-6 Arabic
312 (28597 :ISO-8859-7
) ;; ISO 8859-7 Greek
313 (28598 :ISO-8859-8
) ;; ISO 8859-8 Hebrew
314 (28599 :ISO-8859-9
) ;; ISO 8859-9 Latin 5
315 (28605 :LATIN-9
) ;; ISO 8859-15 Latin 9
317 (38598 :ISO-8859-8
) ;; ISO 8859-8 Hebrew
318 ;;50220 ISO 2022 Japanese with no halfwidth Katakana
319 ;;50221 ISO 2022 Japanese with halfwidth Katakana
320 ;;50222 ISO 2022 Japanese JIS X 0201-1989
321 ;;50225 ISO 2022 Korean
322 ;;50227 ISO 2022 Simplified Chinese
323 ;;50229 ISO 2022 Traditional Chinese
324 ;;50930 Japanese (Katakana) Extended
325 ;;50931 US/Canada and Japanese
326 ;;50933 Korean Extended and Korean
327 ;;50935 Simplified Chinese Extended and Simplified Chinese
328 ;;50936 Simplified Chinese
329 ;;50937 US/Canada and Traditional Chinese
330 ;;50939 Japanese (Latin) Extended and Japanese
331 (51932 :EUC-JP
) ;; EUC - Japanese
332 ;;51936 EUC - Simplified Chinese
334 ;;51950 EUC - Traditional Chinese
335 ;;52936 HZ-GB2312 Simplified Chinese
336 ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte)
337 ;;57002 ISCII Devanagari
338 ;;57003 ISCII Bengali
341 ;;57006 ISCII Assamese
343 ;;57008 ISCII Kannada
344 ;;57009 ISCII Malayalam
345 ;;57010 ISCII Gujarati
346 ;;57011 ISCII Punjabi
347 ;;65000 Unicode UTF-7
348 (65001 :UTF8
))) ;; Unicode UTF-8
349 (setf (gethash (car cp
) *codepage-to-external-format
*) (cadr cp
)))
352 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
353 ;; the console just behave differently?
355 (declaim (ftype (function () keyword
) ansi-codepage
))
356 (defun ansi-codepage ()
358 (setq *ansi-codepage
*
359 (gethash (alien-funcall (extern-alien "GetACP" (function UINT
)))
360 *codepage-to-external-format
*
363 (declaim (ftype (function () keyword
) oem-codepage
))
364 (defun oem-codepage ()
367 (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT
)))
368 *codepage-to-external-format
*
371 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
372 (declaim (ftype (function () keyword
) console-input-codepage
))
373 (defun console-input-codepage ()
375 (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT
)))
376 *codepage-to-external-format
*)
379 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
380 (declaim (ftype (function () keyword
) console-output-codepage
))
381 (defun console-output-codepage ()
383 (gethash (alien-funcall
384 (extern-alien "GetConsoleOutputCP" (function UINT
)))
385 *codepage-to-external-format
*)
388 (define-alien-routine ("LocalFree" local-free
) void
391 (defmacro cast-and-free
(value &key
(type 'system-string
)
392 (free-function 'free-alien
))
393 `(prog1 (cast ,value
,type
)
394 (,free-function
,value
)))
396 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
397 (defmacro with-funcname
((name description
) &body body
)
399 ((,name
(etypecase ,description
400 (string ,description
)
401 (cons (destructuring-bind (s &optional c
) ,description
403 (if c
#!-sb-unicode
"A" #!+sb-unicode
"W" "")))))))
406 (defmacro make-system-buffer
(x)
407 `(make-alien char
#!+sb-unicode
(ash ,x
1) #!-sb-unicode
,x
))
409 (defmacro with-handle
((var initform
410 &key
(close-operator 'close-handle
))
414 (let ((,var
,initform
))
416 (with-local-interrupts
418 (,close-operator
,var
))))))
420 (define-alien-type pathname-buffer
421 (array char
#.
(ash (1+ max_path
) #!+sb-unicode
1 #!-sb-unicode
0)))
423 (define-alien-type long-pathname-buffer
424 #!+sb-unicode
(array char
65536)
425 #!-sb-unicode pathname-buffer
)
427 (defmacro decode-system-string
(alien)
428 `(cast (cast ,alien
(* char
)) system-string
))
430 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
431 ;;; macros in this file, are only used in this file, and could be
432 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
434 (defmacro syscall
((name ret-type
&rest arg-types
) success-form
&rest args
)
435 (with-funcname (sname name
)
437 (declare (optimize (sb!c
::float-accuracy
0)))
438 (let ((result (alien-funcall
440 (function ,ret-type
,@arg-types
))
442 (declare (ignorable result
))
445 ;;; This is like SYSCALL, but if it fails, signal an error instead of
446 ;;; returning error codes. Should only be used for syscalls that will
447 ;;; never really get an error.
448 (defmacro syscall
* ((name &rest arg-types
) success-form
&rest args
)
449 (with-funcname (sname name
)
451 (declare (optimize (sb!c
::float-accuracy
0)))
452 (let ((result (alien-funcall
453 (extern-alien ,sname
(function bool
,@arg-types
))
456 (win32-error ,sname
))
459 (defmacro with-sysfun
((func name ret-type
&rest arg-types
) &body body
)
460 (with-funcname (sname name
)
461 `(with-alien ((,func
(function ,ret-type
,@arg-types
)
465 (defmacro void-syscall
* ((name &rest arg-types
) &rest args
)
466 `(syscall* (,name
,@arg-types
) (values t
0) ,@args
))
468 (defun format-system-message (err)
469 "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
471 (with-alien ((amsg (* char
)))
472 (syscall (("FormatMessage" t
)
473 dword dword dword dword dword
(* (* char
)) dword dword
)
474 (cast-and-free amsg
:free-function local-free
)
475 (logior format-message-allocate-buffer
476 format-message-from-system
477 format-message-max-width-mask
478 format-message-ignore-inserts
)
479 0 err
0 (addr amsg
) 0 0))))
480 (and message
(string-right-trim '(#\Space
) message
))))
482 (defmacro win32-error
(func-name &optional err
)
483 `(let ((err-code ,(or err
`(get-last-error))))
484 (declare (type (unsigned-byte 32) err-code
))
485 (error "~%Win32 Error [~A] - ~A~%~A"
488 (format-system-message err-code
))))
490 (defun get-folder-namestring (csidl)
491 "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
492 (with-alien ((apath pathname-buffer
))
493 (syscall (("SHGetFolderPath" t
) int handle int handle dword
(* char
))
494 (concatenate 'string
(decode-system-string apath
) "\\")
495 0 csidl
0 0 (cast apath
(* char
)))))
497 (defun get-folder-pathname (csidl)
498 (parse-native-namestring (get-folder-namestring csidl
)))
500 (defun sb!unix
:posix-getcwd
()
501 (with-alien ((apath pathname-buffer
))
502 (with-sysfun (afunc ("GetCurrentDirectory" t
) dword dword
(* char
))
503 (let ((ret (alien-funcall afunc
(1+ max_path
) (cast apath
(* char
)))))
505 (win32-error "GetCurrentDirectory"))
506 (if (> ret
(1+ max_path
))
507 (with-alien ((apath (* char
) (make-system-buffer ret
)))
508 (alien-funcall afunc ret apath
)
509 (cast-and-free apath
))
510 (decode-system-string apath
))))))
512 (defun sb!unix
:unix-mkdir
(name mode
)
513 (declare (type sb
!unix
:unix-pathname name
)
514 (type sb
!unix
:unix-file-mode mode
)
516 (syscall (("CreateDirectory" t
) lispbool system-string
(* t
))
517 (values result
(if result
0 (get-last-error)))
520 (defun sb!unix
:unix-rename
(name1 name2
)
521 (declare (type sb
!unix
:unix-pathname name1 name2
))
522 (syscall (("MoveFile" t
) lispbool system-string system-string
)
523 (values result
(if result
0 (get-last-error)))
526 (defun sb!unix
::posix-getenv
(name)
527 (declare (type simple-string name
))
528 (with-alien ((aenv (* char
) (make-system-buffer default-environment-length
)))
529 (with-sysfun (afunc ("GetEnvironmentVariable" t
)
530 dword system-string
(* char
) dword
)
531 (let ((ret (alien-funcall afunc name aenv default-environment-length
)))
532 (when (> ret default-environment-length
)
534 (setf aenv
(make-system-buffer ret
))
535 (alien-funcall afunc name aenv ret
))
538 (free-alien aenv
))))))
540 ;; GET-CURRENT-PROCESS
541 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
544 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
545 (declaim (inline get-current-process
))
546 (define-alien-routine ("GetCurrentProcess" get-current-process
) handle
)
548 ;;;; Process time information
550 (defconstant 100ns-per-internal-time-unit
551 (/ 10000000 sb
!xc
:internal-time-units-per-second
))
554 ;; The FILETIME structure is a 64-bit value representing the number of
555 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
557 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
558 (define-alien-type FILETIME
(unsigned 64))
560 ;; FILETIME definition above is almost correct (on little-endian systems),
561 ;; except for the wrong alignment if used in another structure: the real
562 ;; definition is a struct of two dwords.
563 ;; Let's define FILETIME-MEMBER for that purpose; it will be useful with
564 ;; GetFileAttributesEx and FindFirstFileExW.
566 (define-alien-type FILETIME-MEMBER
567 (struct nil
(low dword
) (high dword
)))
569 (defmacro with-process-times
((creation-time exit-time kernel-time user-time
)
571 `(with-alien ((,creation-time filetime
)
572 (,exit-time filetime
)
573 (,kernel-time filetime
)
574 (,user-time filetime
))
575 (syscall* (("GetProcessTimes") handle
(* filetime
) (* filetime
)
576 (* filetime
) (* filetime
))
578 (get-current-process)
579 (addr ,creation-time
)
584 (declaim (inline system-internal-real-time
))
587 (declare (unsigned-byte epoch
))
588 ;; FIXME: For optimization ideas see the unix implementation.
589 (defun reinit-internal-real-time ()
591 epoch
(get-internal-real-time)))
592 (defun get-internal-real-time ()
593 (- (with-alien ((system-time filetime
))
594 (syscall (("GetSystemTimeAsFileTime") void
(* filetime
))
595 (values (floor system-time
100ns-per-internal-time-unit
))
599 (defun system-internal-run-time ()
600 (with-process-times (creation-time exit-time kernel-time user-time
)
601 (values (floor (+ user-time kernel-time
) 100ns-per-internal-time-unit
))))
603 (define-alien-type hword
(unsigned 16))
605 (define-alien-type systemtime
614 (millisecond hword
)))
616 ;; Obtained with, but the XC can't deal with that -- but
617 ;; it's not like the value is ever going to change...
618 ;; (with-alien ((filetime filetime)
619 ;; (epoch systemtime))
620 ;; (setf (slot epoch 'year) 1970
621 ;; (slot epoch 'month) 1
622 ;; (slot epoch 'day) 1
623 ;; (slot epoch 'hour) 0
624 ;; (slot epoch 'minute) 0
625 ;; (slot epoch 'second) 0
626 ;; (slot epoch 'millisecond) 0)
627 ;; (syscall (("SystemTimeToFileTime" 8) void
628 ;; (* systemtime) (* filetime))
632 (defconstant +unix-epoch-filetime
+ 116444736000000000)
633 (defconstant +filetime-unit
+ (* 100ns-per-internal-time-unit
634 internal-time-units-per-second
))
635 (defconstant +common-lisp-epoch-filetime-seconds
+ 9435484800)
638 (declaim (inline get-time-of-day
))
639 (defun get-time-of-day ()
640 "Return the number of seconds and microseconds since the beginning of the
641 UNIX epoch: January 1st 1970."
642 (with-alien ((system-time filetime
))
643 (syscall (("GetSystemTimeAsFileTime") void
(* filetime
))
644 (multiple-value-bind (sec 100ns
)
645 (floor (- system-time
+unix-epoch-filetime
+)
646 (* 100ns-per-internal-time-unit
647 internal-time-units-per-second
))
648 (values sec
(floor 100ns
10)))
649 (addr system-time
))))
651 ;; Data for FindFirstFileExW and GetFileAttributesEx
652 (define-alien-type find-data
655 (ctime filetime-member
)
656 (atime filetime-member
)
657 (mtime filetime-member
)
662 (long-name (array tchar
#.max_path
))
663 (short-name (array tchar
14))))
665 (define-alien-type file-attributes
668 (ctime filetime-member
)
669 (atime filetime-member
)
670 (mtime filetime-member
)
674 (define-alien-routine ("FindClose" find-close
) lispbool
677 (defun attribute-file-kind (dword)
678 (if (logtest file-attribute-directory dword
)
681 (defun native-file-write-date (native-namestring)
682 "Return file write date, represented as CL universal time."
683 (with-alien ((file-attributes file-attributes
))
684 (syscall (("GetFileAttributesEx" t
) lispbool
685 system-string int file-attributes
)
687 (- (floor (deref (cast (slot file-attributes
'mtime
)
690 +common-lisp-epoch-filetime-seconds
+))
691 native-namestring
0 file-attributes
)))
693 (defun native-probe-file-name (native-namestring)
694 "Return truename \(using GetLongPathName\) as primary value,
695 File kind as secondary.
697 Unless kind is false, null truename shouldn't be interpreted as error or file
699 (with-alien ((file-attributes file-attributes
)
700 (buffer long-pathname-buffer
))
701 (syscall (("GetFileAttributesEx" t
) lispbool
702 system-string int file-attributes
)
704 (syscall (("GetLongPathName" t
) dword
705 system-string long-pathname-buffer dword
)
706 (and (plusp result
) (decode-system-string buffer
))
707 native-namestring buffer
32768)
710 (slot file-attributes
'attributes
))))
711 native-namestring
0 file-attributes
)))
713 (defun native-delete-file (native-namestring)
714 (syscall (("DeleteFile" t
) lispbool system-string
)
715 result native-namestring
))
717 (defun native-delete-directory (native-namestring)
718 (syscall (("RemoveDirectory" t
) lispbool system-string
)
719 result native-namestring
))
721 (defun native-call-with-directory-iterator (function namestring errorp
)
722 (declare (type (or null string
) namestring
)
725 (with-alien ((find-data find-data
))
726 (with-handle (handle (syscall (("FindFirstFile" t
) handle
727 system-string find-data
)
728 (if (eql result invalid-handle
)
730 (win32-error "FindFirstFile")
736 :close-operator find-close
)
738 (dx-flet ((one-iter ()
742 (let ((name (decode-system-string
743 (slot find-data
'long-name
)))
744 (attributes (slot find-data
'attributes
)))
746 (syscall (("FindNextFile" t
) lispbool
747 handle find-data
) result
749 (cond ((equal name
".") (go :next
))
750 ((equal name
"..") (go :next
))
752 (return-from one-iter
756 (funcall function
#'one-iter
)))))))
759 ;; The SetEnvironmentVariable function sets the contents of the specified
760 ;; environment variable for the current process.
762 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
763 (defun setenv (name value
)
764 (declare (type (or null simple-string
) value
))
766 (void-syscall* (("SetEnvironmentVariable" t
) system-string system-string
)
768 (void-syscall* (("SetEnvironmentVariable" t
) system-string int-ptr
)
771 ;; Let SETENV be an accessor for POSIX-GETENV.
773 ;; DFL: Merged this function because it seems useful to me. But
774 ;; shouldn't we then define it on actual POSIX, too?
775 (defun (setf sb
!unix
::posix-getenv
) (new-value name
)
776 (if (setenv name new-value
)
778 (posix-getenv name
)))
780 (defmacro c-sizeof
(s)
781 "translate alien size (in bits) to c-size (in bytes)"
782 `(/ (alien-size ,s
) 8))
785 ;; The OSVERSIONINFO data structure contains operating system version
786 ;; information. The information includes major and minor version numbers,
787 ;; a build number, a platform identifier, and descriptive text about
788 ;; the operating system. This structure is used with the GetVersionEx function.
790 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
791 (define-alien-type nil
792 (struct OSVERSIONINFO
793 (dwOSVersionInfoSize dword
)
794 (dwMajorVersion dword
)
795 (dwMinorVersion dword
)
796 (dwBuildNumber dword
)
798 (szCSDVersion (array char
#!-sb-unicode
128 #!+sb-unicode
256))))
800 (defun get-version-ex ()
801 (with-alien ((info (struct OSVERSIONINFO
)))
802 (setf (slot info
'dwOSVersionInfoSize
) (c-sizeof (struct OSVERSIONINFO
)))
803 (syscall* (("GetVersionEx" t
) (* (struct OSVERSIONINFO
)))
804 (values (slot info
'dwMajorVersion
)
805 (slot info
'dwMinorVersion
)
806 (slot info
'dwBuildNumber
)
807 (slot info
'dwPlatformId
)
808 (cast (slot info
'szCSDVersion
) system-string
))
812 ;; The GetComputerName function retrieves the NetBIOS name of the local
813 ;; computer. This name is established at system startup, when the system
814 ;; reads it from the registry.
816 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
817 (declaim (ftype (function () simple-string
) get-computer-name
))
818 (defun get-computer-name ()
819 (with-alien ((aname (* char
) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH
)))
820 (length dword
(1+ MAX_COMPUTERNAME_LENGTH
)))
821 (with-sysfun (afunc ("GetComputerName" t
) bool
(* char
) (* dword
))
822 (when (zerop (alien-funcall afunc aname
(addr length
)))
823 (let ((err (get-last-error)))
824 (unless (= err ERROR_BUFFER_OVERFLOW
)
825 (win32-error "GetComputerName" err
))
827 (setf aname
(make-system-buffer length
))
828 (alien-funcall afunc aname
(addr length
))))
829 (cast-and-free aname
))))
831 (define-alien-routine ("SetFilePointerEx" set-file-pointer-ex
) lispbool
834 (new-position long-long
:out
)
837 (defun lseeki64 (handle offset whence
)
838 (multiple-value-bind (moved to-place
)
839 (set-file-pointer-ex handle offset whence
)
842 (values -
1 (get-last-error)))))
844 ;; File mapping support routines
845 (define-alien-routine (#!+sb-unicode
"CreateFileMappingW"
846 #!-sb-unicode
"CreateFileMappingA"
850 (security-attributes (* t
))
852 (maximum-size-high dword
)
853 (maximum-size-low dword
)
854 (name system-string
))
856 (define-alien-routine ("MapViewOfFile" map-view-of-file
)
858 (file-mapping handle
)
859 (desired-access dword
)
864 (define-alien-routine ("UnmapViewOfFile" unmap-view-of-file
) bool
867 (define-alien-routine ("FlushViewOfFile" flush-view-of-file
) bool
871 ;; Constants for CreateFile `disposition'.
872 (defconstant file-create-new
1)
873 (defconstant file-create-always
2)
874 (defconstant file-open-existing
3)
875 (defconstant file-open-always
4)
876 (defconstant file-truncate-existing
5)
879 (defconstant access-generic-read
#x80000000
)
880 (defconstant access-generic-write
#x40000000
)
881 (defconstant access-generic-execute
#x20000000
)
882 (defconstant access-generic-all
#x10000000
)
883 (defconstant access-file-append-data
#x4
)
884 (defconstant access-delete
#x00010000
)
887 (defconstant file-share-delete
#x04
)
888 (defconstant file-share-read
#x01
)
889 (defconstant file-share-write
#x02
)
891 ;; CreateFile (the real file-opening workhorse).
892 (define-alien-routine (#!+sb-unicode
"CreateFileW"
893 #!-sb-unicode
"CreateFileA"
896 (name (c-string #!+sb-unicode
#!+sb-unicode
:external-format
:ucs-2
))
897 (desired-access dword
)
899 (security-attributes (* t
))
900 (creation-disposition dword
)
901 (flags-and-attributes dword
)
902 (template-file handle
))
904 ;; GetFileSizeEx doesn't work with block devices :[
905 (define-alien-routine ("GetFileSizeEx" get-file-size-ex
)
907 (handle handle
) (file-size (signed 64) :in-out
))
909 ;; GetFileAttribute is like a tiny subset of fstat(),
910 ;; enough to distinguish directories from anything else.
911 (define-alien-routine (#!+sb-unicode
"GetFileAttributesW"
912 #!-sb-unicode
"GetFileAttributesA"
915 (name (c-string #!+sb-unicode
#!+sb-unicode
:external-format
:ucs-2
)))
917 (define-alien-routine ("CloseHandle" close-handle
) bool
920 (define-alien-routine ("_open_osfhandle" open-osfhandle
)
925 ;; Intended to be an imitation of sb!unix:unix-open based on
926 ;; CreateFile, as complete as possibly.
927 ;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
929 (defun unixlike-open (path flags
&key revertable
931 (declare (type sb
!unix
:unix-pathname path
)
933 (let* ((disposition-flags
935 (if (logtest sb
!unix
:o_creat flags
) #b100
0)
936 (if (logtest sb
!unix
:o_excl flags
) #b010
0)
937 (if (logtest sb
!unix
:o_trunc flags
) #b001
0)))
939 ;; there are 8 combinations of creat|excl|trunc, some of
940 ;; them are equivalent. Case stmt below maps them to 5
941 ;; dispositions (see CreateFile manual).
942 (case disposition-flags
943 ((#b110
#b111
) file-create-new
)
944 ((#b001
#b011
) file-truncate-existing
)
945 ((#b000
#b010
) file-open-existing
)
946 (#b100 file-open-always
)
947 (#b101 file-create-always
))))
951 (if revertable
#x10000
0)
952 (if (logtest sb
!unix
:o_append flags
)
953 access-file-append-data
955 (ecase (logand 3 flags
)
956 (0 FILE_GENERIC_READ
)
957 (1 FILE_GENERIC_WRITE
)
958 ((2 3) (logior FILE_GENERIC_READ
959 FILE_GENERIC_WRITE
))))
960 (logior FILE_SHARE_READ
966 file-attribute-normal
)
968 (cond ((eql handle invalid-handle
)
969 (values nil
(get-last-error)))
971 ;; FIXME: seeking to the end is not enough for real APPEND
972 ;; semantics, but it's better than nothing.
975 ;; On the other hand, the CL spec implies the "better than
976 ;; nothing" seek-once semantics implemented here, and our
977 ;; POSIX backend is incorrect in implementing :APPEND as
978 ;; O_APPEND. Other CL implementations get this right across
981 ;; Of course, it would be nice if we had :IF-EXISTS
982 ;; :ATOMICALLY-APPEND separately as an extension, and in
983 ;; that case, we will have to worry about supporting it
986 ;; I've tested this only very briefly (on XP and Windows 7),
987 ;; but my impression is that WriteFile (without documenting
988 ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
989 ;; offset in our overlapped structure, WriteFile seeks to the
990 ;; end for us. Should we depend on that? How do we communicate
991 ;; our desire to do so to the runtime?
994 (set-file-pointer-ex handle
0 (if (logtest sb
!unix
::o_append flags
) 2 0))
995 (values handle
0))))))
997 (define-alien-routine ("closesocket" close-socket
) int
(handle handle
))
998 (define-alien-routine ("shutdown" shutdown-socket
) int
(handle handle
)
1001 (define-alien-routine ("DuplicateHandle" duplicate-handle
) lispbool
1002 (from-process handle
)
1003 (from-handle handle
)
1005 (to-handle handle
:out
)
1010 (defconstant +handle-flag-inherit
+ 1)
1011 (defconstant +handle-flag-protect-from-close
+ 2)
1013 (define-alien-routine ("SetHandleInformation" set-handle-information
) lispbool
1018 (define-alien-routine ("GetHandleInformation" get-handle-information
) lispbool
1022 (define-alien-routine getsockopt int
1026 (dataword int-ptr
:in-out
)
1027 (socklen int
:in-out
))
1029 (defconstant sol_socket
#xFFFF
)
1030 (defconstant so_type
#x1008
)
1032 (defun socket-handle-p (handle)
1033 (zerop (getsockopt handle sol_socket so_type
0 (alien-size int
:bytes
))))
1035 (defconstant ebadf
9)
1037 ;;; For sockets, CloseHandle first and closesocket() afterwards is
1038 ;;; legal: winsock tracks its handles separately (that's why we have
1039 ;;; the problem with simple _close in the first place).
1041 ;;; ...Seems to be the problem on some OSes, though. We could
1042 ;;; duplicate a handle and attempt close-socket on a duplicated one,
1043 ;;; but it also have some problems...
1045 (defun unixlike-close (fd)
1046 (if (or (zerop (close-socket fd
))
1048 t
(values nil ebadf
)))
1050 (defconstant +std-input-handle
+ -
10)
1051 (defconstant +std-output-handle
+ -
11)
1052 (defconstant +std-error-handle
+ -
12)
1054 (defun get-std-handle-or-null (identity)
1055 (let ((handle (alien-funcall
1056 (extern-alien "GetStdHandle" (function handle dword
))
1057 (logand (1- (ash 1 (alien-size dword
))) identity
))))
1058 (and (/= handle invalid-handle
)
1059 (not (zerop handle
))
1060 ;;When a gui process is launched in windows (subsystem WINDOWS)
1061 ;;it inherits the parent process' handles, which may very well be
1062 ;;invalid unless properly orchestrated by the parent process.
1063 ;;Win32 io will fail on these handles and there is no meaningful
1064 ;;way to make use of them.
1065 ;;So we can call GetFileType to verify the validity of the std handle
1066 ;;which returns FILE_TYPE_UNKNOWN if the handle is invalid
1067 ;;Technically it also returns FILE_TYPE_UNKNOWN if the function fails
1068 ;;but I can't think of a reason we'd care, nor what to do about it
1069 (not (zerop (get-file-type handle
)))
1072 (defun get-std-handles ()
1073 (values (get-std-handle-or-null +std-input-handle
+)
1074 (get-std-handle-or-null +std-output-handle
+)
1075 (get-std-handle-or-null +std-error-handle
+)))
1077 (defconstant +duplicate-same-access
+ 2)
1079 (defun duplicate-and-unwrap-fd (fd &key inheritp
)
1080 (let ((me (get-current-process)))
1081 (multiple-value-bind (duplicated handle
)
1082 (duplicate-handle me
(get-osfhandle fd
)
1083 me
0 inheritp
+duplicate-same-access
+)
1085 (prog1 handle
(crt-close fd
))
1086 (win32-error 'duplicate-and-unwrap-fd
)))))
1088 (define-alien-routine ("CreatePipe" create-pipe
) lispbool
1089 (read-pipe handle
:out
)
1090 (write-pipe handle
:out
)
1091 (security-attributes (* t
))
1092 (buffer-size dword
))
1094 (defun windows-pipe ()
1095 (multiple-value-bind (created read-handle write-handle
)
1096 (create-pipe nil
256)
1097 (if created
(values read-handle write-handle
)
1098 (win32-error 'create-pipe
))))
1100 (defun windows-isatty (handle)
1101 (if (= file-type-char
(get-file-type handle
))
1104 (defun inheritable-handle-p (handle)
1105 (multiple-value-bind (got flags
)
1106 (get-handle-information handle
)
1107 (if got
(plusp (logand flags
+handle-flag-inherit
+))
1108 (win32-error 'inheritable-handle-p
))))
1110 (defun (setf inheritable-handle-p
) (allow handle
)
1111 (if (set-handle-information handle
1112 +handle-flag-inherit
+
1113 (if allow
+handle-flag-inherit
+ 0))
1115 (win32-error '(setf inheritable-handle-p
))))
1117 (defun sb!unix
:unix-dup
(fd)
1118 (let ((me (get-current-process)))
1119 (multiple-value-bind (duplicated handle
)
1120 (duplicate-handle me fd me
0 t
+duplicate-same-access
+)
1123 (values nil
(get-last-error))))))
1125 (defun call-with-crt-fd (thunk handle
&optional
(flags 0))
1126 (multiple-value-bind (duplicate errno
)
1127 (sb!unix
:unix-dup handle
)
1129 (let ((fd (open-osfhandle duplicate flags
)))
1130 (unwind-protect (funcall thunk fd
)
1132 (values nil errno
))))
1136 (define-alien-routine ("CryptGenRandom" %crypt-gen-random
) lispbool
1141 (define-alien-routine (#!-sb-unicode
"CryptAcquireContextA"
1142 #!+sb-unicode
"CryptAcquireContextW"
1143 %crypt-acquire-context
) lispbool
1144 (handle handle
:out
)
1145 (container system-string
)
1146 (provider system-string
)
1147 (provider-type dword
)
1150 (define-alien-routine ("CryptReleaseContext" %crypt-release-context
) lispbool
1154 (defun crypt-gen-random (length)
1155 (multiple-value-bind (ok context
)
1156 (%crypt-acquire-context nil nil prov-rsa-full
1157 (logior crypt-verifycontext crypt-silent
))
1159 (return-from crypt-gen-random
(values nil
(get-last-error))))
1161 (let ((data (make-array length
:element-type
'(unsigned-byte 8))))
1162 (with-pinned-objects (data)
1163 (if (%crypt-gen-random context length
(vector-sap data
))
1165 (values nil
(get-last-error)))))
1166 (unless (%crypt-release-context context
0)
1167 (win32-error '%crypt-release-context
)))))