Fix Windows CE UDP and <file-appender>
Slava Pestov
parent
aee2a65c4f
commit
b002cc1e94
|
|
@ -8,89 +8,16 @@ IN: io.windows.ce
|
|||
|
||||
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
|
||||
|
||||
TUPLE: WSAArgs
|
||||
s
|
||||
lpBuffers
|
||||
dwBufferCount
|
||||
lpNumberOfBytesRet
|
||||
lpFlags
|
||||
lpOverlapped
|
||||
lpCompletionRoutine ;
|
||||
C: <WSAArgs> WSAArgs
|
||||
|
||||
: make-WSAArgs ( port -- <WSARecv> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
1 "DWORD" <c-object> f f f <WSAArgs> ;
|
||||
|
||||
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-capacity ] keep
|
||||
buffer-end
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-read ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
|
||||
! drop
|
||||
! t swap set-port-eof?
|
||||
! ] [
|
||||
! swap n>buffer
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-read ( port port-handle -- )
|
||||
win32-file-handle over buffer-end pick buffer-capacity 0
|
||||
windows.winsock:recv
|
||||
dup windows.winsock:SOCKET_ERROR = [
|
||||
drop port-errored
|
||||
] [
|
||||
dup zero? [
|
||||
drop
|
||||
t swap set-port-eof?
|
||||
] [
|
||||
swap n>buffer
|
||||
] if
|
||||
dup zero?
|
||||
[ drop t swap set-port-eof? ] [ swap n>buffer ] if
|
||||
] if ;
|
||||
|
||||
: setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-length ] keep
|
||||
buffer@
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-write ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
|
||||
! over delegate [ buffer-consume ] keep
|
||||
! buffer-length 0 > [
|
||||
! flush-output
|
||||
! ] [
|
||||
! drop
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-write ( port port-handle -- )
|
||||
win32-file-handle over buffer@ pick buffer-length 0
|
||||
windows.winsock:send
|
||||
|
|
@ -100,8 +27,9 @@ M: win32-socket wince-write ( port port-handle -- )
|
|||
: do-connect ( addrspec -- socket )
|
||||
[ tcp-socket dup ] keep
|
||||
make-sockaddr/size
|
||||
f f f f windows.winsock:WSAConnect zero?
|
||||
[ windows.winsock:winsock-error ] unless ;
|
||||
f f f f
|
||||
windows.winsock:WSAConnect
|
||||
windows.winsock:winsock-error!=0/f ;
|
||||
|
||||
M: windows-ce-io (client) ( addrspec -- duplex-stream )
|
||||
do-connect <win32-socket> dup handle>duplex-stream ;
|
||||
|
|
@ -121,7 +49,8 @@ M: windows-ce-io accept ( server -- client )
|
|||
swap server-port-addr sockaddr-type heap-size
|
||||
dup <byte-array> [
|
||||
swap <int> f 0
|
||||
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
|
||||
windows.winsock:WSAAccept
|
||||
dup windows.winsock:INVALID_SOCKET =
|
||||
[ windows.winsock:winsock-error ] when
|
||||
] keep
|
||||
] keep server-port-addr parse-sockaddr swap
|
||||
|
|
@ -132,39 +61,55 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
|
|||
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
|
||||
] keep <datagram-port> ;
|
||||
|
||||
: packet-size 65536 ; inline
|
||||
|
||||
: receive-buffer ( -- buf )
|
||||
\ receive-buffer get-global expired? [
|
||||
packet-size malloc \ receive-buffer set-global
|
||||
] when
|
||||
\ receive-buffer get-global ;
|
||||
|
||||
: make-WSABUF ( len buf -- ptr )
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep ;
|
||||
|
||||
: receive-WSABUF ( -- buf )
|
||||
packet-size receive-buffer make-WSABUF ;
|
||||
|
||||
: packet-data ( len -- byte-array )
|
||||
receive-buffer swap memory>string >byte-array ;
|
||||
|
||||
packet-size <byte-array> receive-buffer set-global
|
||||
|
||||
M: windows-ce-io receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
[
|
||||
port-handle win32-file-handle
|
||||
"WSABUF" <c-object>
|
||||
default-buffer-size get over windows.winsock:set-WSABUF-len
|
||||
default-buffer-size get <byte-array> over windows.winsock:set-WSABUF-buf
|
||||
[
|
||||
1
|
||||
0 <uint> [
|
||||
0 <uint>
|
||||
64 "char" <c-array> [
|
||||
64 <int>
|
||||
f
|
||||
f
|
||||
windows.winsock:WSARecvFrom zero?
|
||||
[ windows.winsock:winsock-error ] unless
|
||||
] keep
|
||||
] keep *uint
|
||||
] keep
|
||||
] keep
|
||||
! sockaddr count buf datagram
|
||||
>r windows.winsock:WSABUF-buf swap memory>string swap r>
|
||||
datagram-port-addr parse-sockaddr ;
|
||||
receive-WSABUF
|
||||
1
|
||||
0 <uint> [
|
||||
0 <uint>
|
||||
64 "char" <c-array> [
|
||||
64 <int>
|
||||
f
|
||||
f
|
||||
windows.winsock:WSARecvFrom
|
||||
windows.winsock:winsock-error!=0/f
|
||||
] keep
|
||||
] keep *uint packet-data swap
|
||||
] keep datagram-port-addr parse-sockaddr ;
|
||||
|
||||
: send-WSABUF ( byte-array -- ptr )
|
||||
dup length packet-size > [ "UDP packet too long" throw ] when
|
||||
dup length receive-buffer rot pick memcpy
|
||||
receive-buffer make-WSABUF ;
|
||||
|
||||
M: windows-ce-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
port-handle win32-file-handle
|
||||
rot dup length "WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
|
||||
rot send-WSABUF
|
||||
rot make-sockaddr/size
|
||||
>r >r 1 0 <uint> 0 r> r> f f
|
||||
windows.winsock:WSASendTo zero?
|
||||
[ windows.winsock:winsock-error ] unless ;
|
||||
windows.winsock:WSASendTo
|
||||
windows.winsock:winsock-error!=0/f ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.c-types arrays destructors io
|
||||
io.backend io.buffers io.files io.nonblocking io.sockets
|
||||
io.sockets.impl windows.errors strings io.streams.duplex
|
||||
kernel math namespaces sequences windows
|
||||
windows.kernel32 windows.winsock windows.winsock.private ;
|
||||
USE: prettyprint
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.nonblocking io.sockets io.binary
|
||||
io.sockets.impl windows.errors strings io.streams.duplex kernel
|
||||
math namespaces sequences windows windows.kernel32
|
||||
windows.winsock windows.winsock.private ;
|
||||
IN: io.windows
|
||||
|
||||
TUPLE: windows-nt-io ;
|
||||
|
|
@ -67,9 +66,18 @@ M: win32-file close-handle ( handle -- )
|
|||
: (open-append) ( path -- handle )
|
||||
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
|
||||
|
||||
: set-file-pointer ( handle length -- )
|
||||
dupd d>w/w <uint> FILE_BEGIN SetFilePointer
|
||||
INVALID_SET_FILE_POINTER = [
|
||||
CloseHandle "SetFilePointer failed" throw
|
||||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
dup file-length dup
|
||||
[ >r (open-append) r> ] [ drop open-write ] if ;
|
||||
dup file-length dup [
|
||||
>r (open-append) r> 2dup set-file-pointer
|
||||
] [
|
||||
drop open-write
|
||||
] if ;
|
||||
|
||||
TUPLE: FileArgs
|
||||
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
|
||||
|
|
@ -160,13 +168,13 @@ USE: namespaces
|
|||
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
|
||||
|
||||
: listen-on-socket ( socket -- )
|
||||
listen-backlog listen winsock-error!=0/f ;
|
||||
listen-backlog listen winsock-return-check ;
|
||||
|
||||
M: win32-socket stream-close ( stream -- )
|
||||
win32-file-handle closesocket drop ;
|
||||
|
||||
M: windows-io addrinfo-error ( n -- )
|
||||
winsock-error!=0/f ;
|
||||
winsock-return-check ;
|
||||
|
||||
: tcp-socket ( addrspec -- socket )
|
||||
protocol-family SOCK_STREAM open-socket ;
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
|
|||
|
||||
: INVALID_HANDLE_VALUE -1 <alien> ; inline
|
||||
: INVALID_FILE_SIZE HEX: FFFFFFFF ; inline
|
||||
: INVALID_SET_FILE_POINTER HEX: ffffffff ; inline
|
||||
|
||||
: FILE_BEGIN 0 ; inline
|
||||
: FILE_CURRENT 1 ; inline
|
||||
|
|
|
|||
|
|
@ -413,6 +413,11 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
|||
] when ;
|
||||
|
||||
: winsock-error!=0/f ( n/f -- )
|
||||
{ 0 f } member? [
|
||||
winsock-error-string throw
|
||||
] unless ;
|
||||
|
||||
: winsock-return-check ( n/f -- )
|
||||
dup { 0 f } member? [
|
||||
drop
|
||||
] [
|
||||
|
|
@ -433,5 +438,5 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
|||
SOCKET_ERROR = [ winsock-error ] when ;
|
||||
|
||||
: init-winsock ( -- )
|
||||
HEX: 0202 <wsadata> WSAStartup winsock-error!=0/f ;
|
||||
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue