! Copyright (C) 2004 Mackenzie Straight.
IN: win32-api
-USE: errors
-USE: kernel
-USE: io-internals
-USE: math
-USE: parser
-USE: alien
-USE: words
-USE: sequences
+USING: alien errors io-internals kernel math parser sequences words ;
: ERROR_SUCCESS 0 ; inline
: ERROR_HANDLE_EOF 38 ; inline
: ERROR_IO_PENDING 997 ; inline
: WAIT_TIMEOUT 258 ; inline
-: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
-: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
-: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
-: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
-: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
-: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
-: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
+: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ; inline
+: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ; inline
+: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ; inline
+: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ; inline
+: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ; inline
+: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ; inline
+: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ; inline
: MAKELANGID ( primary sub -- lang )
10 shift bitor ;
-: LANG_NEUTRAL 0 ;
-: SUBLANG_DEFAULT 1 ;
+: LANG_NEUTRAL 0 ; inline
+: SUBLANG_DEFAULT 1 ; inline
-: GetLastError ( -- int )
- "int" "kernel32" "GetLastError" [ ] alien-invoke ;
-
-: win32-error-message ( id -- string )
- "char*" f "error_message" [ "int" ] alien-invoke ;
+FUNCTION: char* error_message ( DWORD id ) ;
: win32-throw-error ( -- )
- GetLastError win32-error-message throw ;
+ GetLastError error_message throw ;
TUPLE: win32-server this ;
TUPLE: win32-client-stream host port ;
-SYMBOL: winsock
SYMBOL: socket
-: maybe-init-winsock ( -- )
- winsock get [
- HEX: 0202 <wsadata> WSAStartup drop winsock on
- ] unless ;
+: (handle-socket-error)
+ WSAGetLastError [ ERROR_IO_PENDING ERROR_SUCCESS ] member?
+ [ WSAGetLastError error_message throw ] unless ;
+
+: handle-socket-error!=0/f ( int -- )
+ [ 0 f ] member? [ (handle-socket-error) ] unless ;
+
+: handle-socket-error=0/f ( int -- )
+ [ 0 f ] member? [ (handle-socket-error) ] when ;
+
+: init-winsock ( -- )
+ HEX: 0202 <wsadata> WSAStartup handle-socket-error!=0/f ;
-: handle-socket-error ( -- )
- WSAGetLastError [
- ERROR_IO_PENDING ERROR_SUCCESS
- ] member? [
- WSAGetLastError win32-error-message throw
- ] unless ;
: new-socket ( -- socket )
- AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED WSASocket ;
+ AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED
+ WSASocket dup INVALID_SOCKET = [ (handle-socket-error) ] when ;
: setup-sockaddr ( port -- sockaddr )
"sockaddr-in" <c-object> swap
AF_INET over set-sockaddr-in-family ;
: bind-socket ( port socket -- )
- swap setup-sockaddr "sockaddr-in" c-size wsa-bind zero? [
- handle-socket-error
- ] unless ;
+ swap setup-sockaddr "sockaddr-in" c-size wsa-bind handle-socket-error!=0/f ;
: listen-socket ( socket -- )
- 20 wsa-listen zero? [ handle-socket-error ] unless ;
+ 20 wsa-listen handle-socket-error!=0/f ;
: sockaddr> ( sockaddr -- port host )
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
C: win32-server ( port -- server )
swap [
- maybe-init-winsock new-socket swap over bind-socket dup listen-socket
+ new-socket swap over bind-socket dup listen-socket
dup add-completion
socket set
dup stream set
: client-sockaddr ( host port -- sockaddr )
setup-sockaddr [
- >r gethostbyname handle-socket-error hostent-addr
+ >r gethostbyname dup handle-socket-error=0/f hostent-addr
r> set-sockaddr-in-addr
] keep ;
stream get alloc-io-callback init-overlapped
>r >r >r socket get r> r>
buffer-ptr <alien> 0 32 32 f r> AcceptEx
- [ handle-socket-error ] unless stop
+ handle-socket-error!=0/f stop
] callcc1 pending-error drop
swap dup add-completion <win32-stream> <line-reader>
dupd <win32-client-stream> swap buffer-free
] bind ;
: <client> ( host port -- stream )
- maybe-init-winsock client-sockaddr new-socket
- [ swap "sockaddr-in" c-size connect drop handle-socket-error ] keep
+ client-sockaddr new-socket
+ [ swap "sockaddr-in" c-size connect handle-socket-error!=0/f ] keep
dup add-completion <win32-stream> <line-reader> ;