0.9.13.30
[sbcl.git] / src / code / win32.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!WIN32")
16
17 ;;; Alien definitions for commonly used Win32 types.  Woe unto whoever
18 ;;; tries to untangle this someday for 64-bit Windows.
19 (define-alien-type int-ptr long)
20 (define-alien-type handle int-ptr)
21 (define-alien-type dword unsigned-long)
22 (define-alien-type bool int)
23 (define-alien-type UINT unsigned-int)
24 (define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16)
25                          #!-sb-unicode char)
26
27 (defconstant default-environment-length 1024)
28
29 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
30 ;;; to a pointer.
31 (defconstant invalid-handle -1)
32
33 ;;;; Error Handling
34
35 ;;; Retrieve the calling thread's last-error code value.  The
36 ;;; last-error code is maintained on a per-thread basis.
37 (define-alien-routine ("GetLastError@0" get-last-error) dword)
38
39 ;;; Flag constants for FORMAT-MESSAGE.
40 (defconstant format-message-from-system #x1000)
41
42 ;;; Format an error message based on a lookup table.  See MSDN for the
43 ;;; full meaning of the all options---most are not used when getting
44 ;;; system error codes.
45 (define-alien-routine ("FormatMessageA@28" format-message) dword
46   (flags dword)
47   (source (* t))
48   (message-id dword)
49   (language-id dword)
50   (buffer c-string)
51   (size dword)
52   (arguments (* t)))
53
54 ;;;; File Handles
55
56 ;;; Get the operating system handle for a C file descriptor.  Returns
57 ;;; INVALID-HANDLE on failure.
58 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
59   (fd int))
60
61 ;;; Read data from a file handle into a buffer.  This may be used
62 ;;; synchronously or with "overlapped" (asynchronous) I/O.
63 (define-alien-routine ("ReadFile@20" read-file) bool
64   (file handle)
65   (buffer (* t))
66   (bytes-to-read dword)
67   (bytes-read (* dword))
68   (overlapped (* t)))
69
70 ;;; Write data from a buffer to a file handle.  This may be used
71 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
72 (define-alien-routine ("WriteFile@20" write-file) bool
73   (file handle)
74   (buffer (* t))
75   (bytes-to-write dword)
76   (bytes-written (* dword))
77   (overlapped (* t)))
78
79 ;;; Copy data from a named or anonymous pipe into a buffer without
80 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
81 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
82 ;;; Return TRUE on success, FALSE on failure.
83 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
84   (pipe handle)
85   (buffer (* t))
86   (buffer-size dword)
87   (bytes-read (* dword))
88   (bytes-avail (* dword))
89   (bytes-left-this-message (* dword)))
90
91 ;;; Flush the console input buffer if HANDLE is a console handle.
92 ;;; Returns true on success, false if the handle does not refer to a
93 ;;; console.
94 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
95   (handle handle))
96
97 ;;; Read data from the console input buffer without removing it,
98 ;;; without blocking.  Buffer should be large enough for LENGTH *
99 ;;; INPUT-RECORD-SIZE bytes.
100 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
101   (handle handle)
102   (buffer (* t))
103   (length dword)
104   (nevents (* dword)))
105
106 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
107 ;;; isn't a unified interface to do this---we have to know what sort
108 ;;; of handle we have.  Of course, there's no way to actually
109 ;;; introspect it, so we have to try various things until we find
110 ;;; something that works.  Returns true if there could be input
111 ;;; available, or false if there is not.
112 (defun handle-listen (handle)
113   (with-alien ((avail dword)
114                (buf (array char #.input-record-size)))
115     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
116       (return-from handle-listen (plusp avail)))
117
118     (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail)))
119       (return-from handle-listen (plusp avail)))
120
121     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
122     ;; HANDLE is a socket.
123     t))
124
125 ;;; Listen for input on a C runtime file handle.  Returns true if
126 ;;; there could be input available, or false if there is not.
127 (defun fd-listen (fd)
128   (let ((handle (get-osfhandle fd)))
129     (if handle
130         (handle-listen handle)
131         t)))
132
133 ;;; Clear all available input from a file handle.
134 (defun handle-clear-input (handle)
135   (flush-console-input-buffer handle)
136   (with-alien ((buf (array char 1024))
137                (count dword))
138     (loop
139      (unless (handle-listen handle)
140        (return))
141      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
142        (return))
143      (when (< count 1024)
144        (return)))))
145
146 ;;; Clear all available input from a C runtime file handle.
147 (defun fd-clear-input (fd)
148   (let ((handle (get-osfhandle fd)))
149     (when handle
150       (handle-clear-input handle))))
151
152 ;;;; System Functions
153
154 ;;; Sleep for MILLISECONDS milliseconds.
155 (define-alien-routine ("Sleep@4" millisleep) void
156   (milliseconds dword))
157
158 #!+sb-unicode (defvar *ANSI-CODEPAGE* nil)
159 #!+sb-unicode (defvar *OEM-CODEPAGE* nil)
160
161 #!+sb-unicode
162 (defparameter *codepage-to-external-format* (make-hash-table))
163
164 #!+sb-unicode
165 (dolist (cp
166   '(;;037       IBM EBCDIC - U.S./Canada
167     (437 :CP437) ;; OEM - United States
168     ;;500       IBM EBCDIC - International
169     ;;708       Arabic - ASMO 708
170     ;;709       Arabic - ASMO 449+, BCON V4
171     ;;710       Arabic - Transparent Arabic
172     ;;720       Arabic - Transparent ASMO
173     ;;737       OEM - Greek (formerly 437G)
174     ;;775       OEM - Baltic
175     (850 :CP850) ;; OEM - Multilingual Latin I
176     (852 :CP852) ;; OEM - Latin II
177     (855 :CP855) ;; OEM - Cyrillic (primarily Russian)
178     (857 :CP857) ;; OEM - Turkish
179     ;;858       OEM - Multilingual Latin I + Euro symbol
180     (860 :CP860) ;; OEM - Portuguese
181     (861 :CP861) ;; OEM - Icelandic
182     (862 :CP862) ;; OEM - Hebrew
183     (863 :CP863) ;; OEM - Canadian-French
184     (864 :CP864) ;; OEM - Arabic
185     (865 :CP865) ;; OEM - Nordic
186     (866 :CP866) ;; OEM - Russian
187     (869 :CP869) ;; OEM - Modern Greek
188     ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
189     (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
190     ;;875       IBM EBCDIC - Modern Greek
191     ;;932       ANSI/OEM - Japanese, Shift-JIS
192     ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
193     ;;949       ANSI/OEM - Korean (Unified Hangul Code)
194     ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
195     ;;1026      IBM EBCDIC - Turkish (Latin-5)
196     ;;1047      IBM EBCDIC - Latin 1/Open System
197     ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
198     ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
199     ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
200     ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
201     ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
202     ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
203     ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
204     ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
205     ;;1148      IBM EBCDIC - International (500 + Euro symbol)
206     ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
207     ;;1200      Unicode UCS-2 Little-Endian (BMP of ISO 10646)
208     ;;1201      Unicode UCS-2 Big-Endian
209     (1250 :CP1250) ;; ANSI - Central European
210     (1251 :CP1251) ;; ANSI - Cyrillic
211     (1252 :CP1252) ;; ANSI - Latin I
212     (1253 :CP1253) ;; ANSI - Greek
213     (1254 :CP1254) ;; ANSI - Turkish
214     (1255 :CP1255) ;; ANSI - Hebrew
215     (1256 :CP1256) ;; ANSI - Arabic
216     (1257 :CP1257) ;; ANSI - Baltic
217     (1258 :CP1258) ;; ANSI/OEM - Vietnamese
218     ;;1361      Korean (Johab)
219     ;;10000 MAC - Roman
220     ;;10001     MAC - Japanese
221     ;;10002     MAC - Traditional Chinese (Big5)
222     ;;10003     MAC - Korean
223     ;;10004     MAC - Arabic
224     ;;10005     MAC - Hebrew
225     ;;10006     MAC - Greek I
226     (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
227     ;;10008     MAC - Simplified Chinese (GB 2312)
228     ;;10010     MAC - Romania
229     ;;10017     MAC - Ukraine
230     ;;10021     MAC - Thai
231     ;;10029     MAC - Latin II
232     ;;10079     MAC - Icelandic
233     ;;10081     MAC - Turkish
234     ;;10082     MAC - Croatia
235     ;;12000     Unicode UCS-4 Little-Endian
236     ;;12001     Unicode UCS-4 Big-Endian
237     ;;20000     CNS - Taiwan
238     ;;20001     TCA - Taiwan
239     ;;20002     Eten - Taiwan
240     ;;20003     IBM5550 - Taiwan
241     ;;20004     TeleText - Taiwan
242     ;;20005     Wang - Taiwan
243     ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
244     ;;20106     IA5 German (7-bit)
245     ;;20107     IA5 Swedish (7-bit)
246     ;;20108     IA5 Norwegian (7-bit)
247     ;;20127     US-ASCII (7-bit)
248     ;;20261     T.61
249     ;;20269     ISO 6937 Non-Spacing Accent
250     ;;20273     IBM EBCDIC - Germany
251     ;;20277     IBM EBCDIC - Denmark/Norway
252     ;;20278     IBM EBCDIC - Finland/Sweden
253     ;;20280     IBM EBCDIC - Italy
254     ;;20284     IBM EBCDIC - Latin America/Spain
255     ;;20285     IBM EBCDIC - United Kingdom
256     ;;20290     IBM EBCDIC - Japanese Katakana Extended
257     ;;20297     IBM EBCDIC - France
258     ;;20420     IBM EBCDIC - Arabic
259     ;;20423     IBM EBCDIC - Greek
260     ;;20424     IBM EBCDIC - Hebrew
261     ;;20833     IBM EBCDIC - Korean Extended
262     ;;20838     IBM EBCDIC - Thai
263     (20866 :KOI8-R) ;; Russian - KOI8-R
264     ;;20871     IBM EBCDIC - Icelandic
265     ;;20880     IBM EBCDIC - Cyrillic (Russian)
266     ;;20905     IBM EBCDIC - Turkish
267     ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
268     ;;20932     JIS X 0208-1990 & 0121-1990
269     ;;20936     Simplified Chinese (GB2312)
270     ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
271     ;;21027     (deprecated)
272     (21866 :KOI8-U) ;; Ukrainian (KOI8-U)
273     (28591 :LATIN-1) ;; ISO 8859-1 Latin I
274     (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe
275     (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3
276     (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic
277     (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic
278     (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic
279     (28597 :ISO-8859-7) ;; ISO 8859-7 Greek
280     (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
281     (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5
282     (28605 :LATIN-9) ;; ISO 8859-15 Latin 9
283     ;;29001     Europa 3
284     (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
285     ;;50220     ISO 2022 Japanese with no halfwidth Katakana
286     ;;50221     ISO 2022 Japanese with halfwidth Katakana
287     ;;50222     ISO 2022 Japanese JIS X 0201-1989
288     ;;50225     ISO 2022 Korean
289     ;;50227     ISO 2022 Simplified Chinese
290     ;;50229     ISO 2022 Traditional Chinese
291     ;;50930     Japanese (Katakana) Extended
292     ;;50931     US/Canada and Japanese
293     ;;50933     Korean Extended and Korean
294     ;;50935     Simplified Chinese Extended and Simplified Chinese
295     ;;50936     Simplified Chinese
296     ;;50937     US/Canada and Traditional Chinese
297     ;;50939     Japanese (Latin) Extended and Japanese
298     (51932 :EUC-JP) ;; EUC - Japanese
299     ;;51936     EUC - Simplified Chinese
300     ;;51949     EUC - Korean
301     ;;51950     EUC - Traditional Chinese
302     ;;52936     HZ-GB2312 Simplified Chinese
303     ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
304     ;;57002     ISCII Devanagari
305     ;;57003     ISCII Bengali
306     ;;57004     ISCII Tamil
307     ;;57005     ISCII Telugu
308     ;;57006     ISCII Assamese
309     ;;57007     ISCII Oriya
310     ;;57008     ISCII Kannada
311     ;;57009     ISCII Malayalam
312     ;;57010     ISCII Gujarati
313     ;;57011     ISCII Punjabi
314     ;;65000     Unicode UTF-7
315     (65001 :UTF8))) ;; Unicode UTF-8
316   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
317
318 #!+sb-unicode
319 (declaim (ftype (function () keyword) ansi-codepage))
320 #!+sb-unicode
321 (defun ansi-codepage ()
322   (or *ANSI-CODEPAGE*
323       (setq *ANSI-CODEPAGE*
324         (or
325           (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
326                    *codepage-to-external-format*)
327           :LATIN-1))))
328
329 #!+sb-unicode
330 (declaim (ftype (function () keyword) oem-codepage))
331 #!+sb-unicode
332 (defun oem-codepage ()
333   (or *OEM-CODEPAGE*
334       (setq *OEM-CODEPAGE*
335         (or
336           (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
337                    *codepage-to-external-format*)
338           :LATIN-1))))
339
340 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
341 (declaim (ftype (function () keyword) console-input-codepage))
342 (defun console-input-codepage ()
343   (or #!+sb-unicode
344       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
345                *codepage-to-external-format*)
346       :LATIN-1))
347
348 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
349 (declaim (ftype (function () keyword) console-output-codepage))
350 (defun console-output-codepage ()
351   (or #!+sb-unicode
352       (gethash (alien-funcall (extern-alien "GetConsoleOutputCP@0" (function UINT)))
353                *codepage-to-external-format*)
354       :LATIN-1))
355
356 ;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string
357 ;;;; :external-format :ucs2), except that we do not have an
358 ;;;; implementation of ucs2 yet.
359 (defmacro ucs2->string (astr &optional size)
360   #!-sb-unicode
361   (declare (ignore size))
362   #!-sb-unicode
363   `(cast ,astr c-string)
364   #!+sb-unicode
365   (let ((str-len (or size `(do ((i 0 (1+ i))) ((zerop (deref ,astr i)) i)))))
366     `(let* ((l ,str-len)
367             (s (make-string l)))
368       (dotimes (i l) (setf (aref s i) (code-char (deref ,astr i))))
369       s)))
370
371 (defmacro ucs2->string&free (astr &optional size)
372   `(prog1 (ucs2->string ,astr ,size) (free-alien ,astr)))
373
374 (define-alien-routine ("LocalFree@4" local-free) void
375   (lptr (* t)))
376
377 (defun get-last-error-message (err)
378   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
379   (with-alien ((amsg (* tchar)))
380     (let ((nchars
381             (alien-funcall
382               (extern-alien #!+sb-unicode "FormatMessageW@28"
383                             #!-sb-unicode "FormatMessageA@28"
384                             (function dword
385                                       dword dword dword dword (* (* tchar)) dword dword))
386               (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
387               0 err 0 (addr amsg) 0 0)))
388       (prog1 (ucs2->string amsg nchars)
389         (local-free amsg)))))
390
391 (defmacro win32-error (func-name)
392   `(let ((err-code (sb!win32::get-last-error)))
393      (error "~%Win32 Error [~A] - ~A~%~A"
394             ,func-name
395             err-code
396             (sb!win32::get-last-error-message err-code))))
397
398 (defun get-folder-path (CSIDL)
399   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
400   (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH))))
401     (alien-funcall
402       (extern-alien #!-sb-unicode "SHGetFolderPathA@20"
403                     #!+sb-unicode "SHGetFolderPathW@20"
404                     (function int handle int handle dword (* tchar)))
405       0 CSIDL 0 0 apath)
406     (concatenate 'string (ucs2->string&free apath) "\\")))
407
408 (defun sb!unix:posix-getcwd ()
409   (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH)))
410                (afunc (function dword dword (* tchar))
411                       :extern #!-sb-unicode "GetCurrentDirectoryA@8"
412                               #!+sb-unicode "GetCurrentDirectoryW@8"))
413     (let ((ret (alien-funcall afunc (1+ MAX_PATH) apath)))
414       (when (zerop ret)
415         (win32-error "GetCurrentDirectory"))
416       (when (> ret (1+ MAX_PATH))
417         (free-alien apath)
418         (setf apath (make-alien tchar ret))
419         (alien-funcall afunc ret apath))
420       (ucs2->string&free apath ret))))
421
422 (defun sb!unix:unix-mkdir (name mode)
423   (declare (type sb!unix:unix-pathname name)
424            (type sb!unix:unix-file-mode mode)
425            (ignore mode))
426   (let ((name-length (length name)))
427     (with-alien ((apath (* tchar) (make-alien tchar (1+ name-length))))
428       (dotimes (i name-length) (setf (deref apath i) (char-code (aref name i))))
429       (setf (deref apath name-length) 0)
430       (when
431         (zerop (alien-funcall
432                  (extern-alien #!-sb-unicode "CreateDirectoryA@8"
433                                #!+sb-unicode "CreateDirectoryW@8"
434                                (function bool (* tchar) dword))
435                  apath 0))
436         (win32-error "CreateDirectory"))
437       (values t 0))))
438
439 (defun sb!unix:unix-rename (name1 name2)
440   (declare (type sb!unix:unix-pathname name1 name2))
441   (let ((name-length1 (length name1))
442         (name-length2 (length name2)))
443     (with-alien ((apath1 (* tchar) (make-alien tchar (1+ name-length1)))
444                  (apath2 (* tchar) (make-alien tchar (1+ name-length2))))
445       (dotimes (i name-length1) (setf (deref apath1 i) (char-code (aref name1 i))))
446       (setf (deref apath1 name-length1) 0)
447       (dotimes (i name-length2) (setf (deref apath2 i) (char-code (aref name2 i))))
448       (setf (deref apath2 name-length2) 0)
449       (when
450         (zerop (alien-funcall
451                  (extern-alien #!-sb-unicode "MoveFileA@8"
452                                #!+sb-unicode "MoveFileW@8"
453                                (function bool (* tchar) (* tchar)))
454                  apath1 apath2))
455         (win32-error "MoveFile"))
456       (values t 0))))
457
458
459 (defun sb!unix::posix-getenv (name)
460   (declare (type simple-string name))
461   (let ((name-length (length name)))
462     (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length)))
463                  (aenv (* tchar) (make-alien tchar default-environment-length))
464                  (afunc (function dword (* tchar) (* tchar) dword)
465                         :extern #!-sb-unicode "GetEnvironmentVariableA@12"
466                         #!+sb-unicode "GetEnvironmentVariableW@12"))
467                 (dotimes (i name-length) (setf (deref aname i) (char-code (aref name i))))
468                 (setf (deref aname name-length) 0)
469                 (let ((ret (alien-funcall afunc aname aenv default-environment-length)))
470                   (when (> ret default-environment-length)
471                     (free-alien aenv)
472                     (setf aenv (make-alien tchar ret))
473                     (alien-funcall afunc aname aenv ret))
474                   (if (> ret 0)
475                       (ucs2->string&free aenv ret)
476                     nil)))))