fix some win32 error handling in native io
parent
ac87a60c07
commit
87abad4ebb
|
@ -1,40 +1,29 @@
|
||||||
! Copyright (C) 2004 Mackenzie Straight.
|
! Copyright (C) 2004 Mackenzie Straight.
|
||||||
|
|
||||||
IN: win32-api
|
IN: win32-api
|
||||||
USE: errors
|
USING: alien errors io-internals kernel math parser sequences words ;
|
||||||
USE: kernel
|
|
||||||
USE: io-internals
|
|
||||||
USE: math
|
|
||||||
USE: parser
|
|
||||||
USE: alien
|
|
||||||
USE: words
|
|
||||||
USE: sequences
|
|
||||||
|
|
||||||
: ERROR_SUCCESS 0 ; inline
|
: ERROR_SUCCESS 0 ; inline
|
||||||
: ERROR_HANDLE_EOF 38 ; inline
|
: ERROR_HANDLE_EOF 38 ; inline
|
||||||
: ERROR_IO_PENDING 997 ; inline
|
: ERROR_IO_PENDING 997 ; inline
|
||||||
: WAIT_TIMEOUT 258 ; inline
|
: WAIT_TIMEOUT 258 ; inline
|
||||||
|
|
||||||
: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
|
: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ; inline
|
||||||
: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
|
: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ; inline
|
||||||
: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
|
: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ; inline
|
||||||
: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
|
: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ; inline
|
||||||
: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
|
: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ; inline
|
||||||
: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
|
: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ; inline
|
||||||
: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
|
: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ; inline
|
||||||
|
|
||||||
: MAKELANGID ( primary sub -- lang )
|
: MAKELANGID ( primary sub -- lang )
|
||||||
10 shift bitor ;
|
10 shift bitor ;
|
||||||
|
|
||||||
: LANG_NEUTRAL 0 ;
|
: LANG_NEUTRAL 0 ; inline
|
||||||
: SUBLANG_DEFAULT 1 ;
|
: SUBLANG_DEFAULT 1 ; inline
|
||||||
|
|
||||||
: GetLastError ( -- int )
|
FUNCTION: char* error_message ( DWORD id ) ;
|
||||||
"int" "kernel32" "GetLastError" [ ] alien-invoke ;
|
|
||||||
|
|
||||||
: win32-error-message ( id -- string )
|
|
||||||
"char*" f "error_message" [ "int" ] alien-invoke ;
|
|
||||||
|
|
||||||
: win32-throw-error ( -- )
|
: win32-throw-error ( -- )
|
||||||
GetLastError win32-error-message throw ;
|
GetLastError error_message throw ;
|
||||||
|
|
||||||
|
|
|
@ -16,5 +16,6 @@ IN: io-internals
|
||||||
swap [ schedule-thread-with ] [ drop ] if* ;
|
swap [ schedule-thread-with ] [ drop ] if* ;
|
||||||
|
|
||||||
: init-io ( -- )
|
: init-io ( -- )
|
||||||
win32-init-stdio ;
|
win32-init-stdio
|
||||||
|
init-winsock ;
|
||||||
|
|
||||||
|
|
|
@ -7,23 +7,25 @@ USING: alien errors generic kernel kernel-internals math namespaces
|
||||||
|
|
||||||
TUPLE: win32-server this ;
|
TUPLE: win32-server this ;
|
||||||
TUPLE: win32-client-stream host port ;
|
TUPLE: win32-client-stream host port ;
|
||||||
SYMBOL: winsock
|
|
||||||
SYMBOL: socket
|
SYMBOL: socket
|
||||||
|
|
||||||
: maybe-init-winsock ( -- )
|
: (handle-socket-error)
|
||||||
winsock get [
|
WSAGetLastError [ ERROR_IO_PENDING ERROR_SUCCESS ] member?
|
||||||
HEX: 0202 <wsadata> WSAStartup drop winsock on
|
[ WSAGetLastError error_message throw ] unless ;
|
||||||
] 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 )
|
: 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 )
|
: setup-sockaddr ( port -- sockaddr )
|
||||||
"sockaddr-in" <c-object> swap
|
"sockaddr-in" <c-object> swap
|
||||||
|
@ -32,12 +34,10 @@ SYMBOL: socket
|
||||||
AF_INET over set-sockaddr-in-family ;
|
AF_INET over set-sockaddr-in-family ;
|
||||||
|
|
||||||
: bind-socket ( port socket -- )
|
: bind-socket ( port socket -- )
|
||||||
swap setup-sockaddr "sockaddr-in" c-size wsa-bind zero? [
|
swap setup-sockaddr "sockaddr-in" c-size wsa-bind handle-socket-error!=0/f ;
|
||||||
handle-socket-error
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: listen-socket ( socket -- )
|
: listen-socket ( socket -- )
|
||||||
20 wsa-listen zero? [ handle-socket-error ] unless ;
|
20 wsa-listen handle-socket-error!=0/f ;
|
||||||
|
|
||||||
: sockaddr> ( sockaddr -- port host )
|
: sockaddr> ( sockaddr -- port host )
|
||||||
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
|
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
|
||||||
|
@ -59,7 +59,7 @@ M: win32-client-stream client-stream-port win32-client-stream-port ;
|
||||||
|
|
||||||
C: win32-server ( port -- server )
|
C: win32-server ( port -- server )
|
||||||
swap [
|
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
|
dup add-completion
|
||||||
socket set
|
socket set
|
||||||
dup stream set
|
dup stream set
|
||||||
|
@ -78,7 +78,7 @@ M: win32-server expire ( -- )
|
||||||
|
|
||||||
: client-sockaddr ( host port -- sockaddr )
|
: client-sockaddr ( host port -- sockaddr )
|
||||||
setup-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
|
r> set-sockaddr-in-addr
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
|
@ -90,14 +90,14 @@ IN: io
|
||||||
stream get alloc-io-callback init-overlapped
|
stream get alloc-io-callback init-overlapped
|
||||||
>r >r >r socket get r> r>
|
>r >r >r socket get r> r>
|
||||||
buffer-ptr <alien> 0 32 32 f r> AcceptEx
|
buffer-ptr <alien> 0 32 32 f r> AcceptEx
|
||||||
[ handle-socket-error ] unless stop
|
handle-socket-error!=0/f stop
|
||||||
] callcc1 pending-error drop
|
] callcc1 pending-error drop
|
||||||
swap dup add-completion <win32-stream> <line-reader>
|
swap dup add-completion <win32-stream> <line-reader>
|
||||||
dupd <win32-client-stream> swap buffer-free
|
dupd <win32-client-stream> swap buffer-free
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
||||||
: <client> ( host port -- stream )
|
: <client> ( host port -- stream )
|
||||||
maybe-init-winsock client-sockaddr new-socket
|
client-sockaddr new-socket
|
||||||
[ swap "sockaddr-in" c-size connect drop handle-socket-error ] keep
|
[ swap "sockaddr-in" c-size connect handle-socket-error!=0/f ] keep
|
||||||
dup add-completion <win32-stream> <line-reader> ;
|
dup add-completion <win32-stream> <line-reader> ;
|
||||||
|
|
||||||
|
|
|
@ -9,10 +9,12 @@ USE: arrays
|
||||||
|
|
||||||
: <wsadata> HEX: 190 <byte-array> ;
|
: <wsadata> HEX: 190 <byte-array> ;
|
||||||
|
|
||||||
: AF_INET 2 ;
|
: AF_INET 2 ; inline
|
||||||
: SOCK_STREAM 1 ;
|
: SOCK_STREAM 1 ; inline
|
||||||
: WSA_FLAG_OVERLAPPED 1 ;
|
: WSA_FLAG_OVERLAPPED 1 ; inline
|
||||||
: INADDR_ANY 0 ;
|
: INADDR_ANY 0 ; inline
|
||||||
|
|
||||||
|
: INVALID_SOCKET -1 ; inline
|
||||||
|
|
||||||
BEGIN-STRUCT: sockaddr-in
|
BEGIN-STRUCT: sockaddr-in
|
||||||
FIELD: short family
|
FIELD: short family
|
||||||
|
|
Loading…
Reference in New Issue