-! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alien alien.c-types alien.data classes.struct\r
-combinators destructors io.backend io.files.windows io.ports\r
-io.sockets io.sockets.icmp io.sockets.private kernel libc locals\r
-math sequences system windows.errors windows.handles\r
-windows.kernel32 windows.types windows.winsock ;\r
-FROM: namespaces => get ;\r
-IN: io.sockets.windows\r
-\r
-: set-socket-option ( handle level opt -- )\r
- [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;\r
-\r
-: set-ioctl-socket ( handle cmd arg -- )\r
- [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;\r
-\r
-M: windows addrinfo-error-string ( n -- string )\r
- n>win32-error-string ;\r
-\r
-M: windows sockaddr-of-family ( alien af -- addrspec )\r
- {\r
- { AF_INET [ sockaddr-in memory>struct ] }\r
- { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
- [ 2drop f ]\r
- } case ;\r
-\r
-M: windows addrspec-of-family ( af -- addrspec )\r
- {\r
- { AF_INET [ T{ ipv4 } ] }\r
- { AF_INET6 [ T{ ipv6 } ] }\r
- [ drop f ]\r
- } case ;\r
-\r
-HOOK: WSASocket-flags io-backend ( -- DWORD )\r
-\r
-TUPLE: win32-socket < win32-file ;\r
-\r
-: <win32-socket> ( handle -- win32-socket )\r
- win32-socket new-win32-handle ;\r
-\r
-M: win32-socket dispose* ( stream -- )\r
- handle>> closesocket socket-error* ;\r
-\r
-: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;\r
-\r
-: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose add-completion ;\r
-\r
-: open-socket ( addrspec type -- win32-socket )\r
- [ drop protocol-family ] [ swap protocol ] 2bi\r
- f 0 WSASocket-flags WSASocket\r
- dup socket-error\r
- opened-socket ;\r
-\r
-M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size int <ref>\r
- [ getsockname socket-error ] 2keep drop ;\r
-\r
-M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size int <ref>\r
- [ getpeername socket-error ] 2keep drop ;\r
-\r
-: bind-socket ( win32-socket sockaddr len -- )\r
- [ handle>> ] 2dip bind socket-error ;\r
-\r
-M: object ((client)) ( addrspec -- handle )\r
- [ SOCK_STREAM open-socket ] keep\r
- [\r
- bind-local-address get\r
- [ nip make-sockaddr/size ]\r
- [ unspecific-sockaddr/size ] if* bind-socket\r
- ] [ drop ] 2bi ;\r
-\r
-: server-socket ( addrspec type -- fd )\r
- [ open-socket ] [ drop ] 2bi\r
- [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-! http://support.microsoft.com/kb/127144\r
-! NOTE: Possibly tweak this because of SYN flood attacks\r
-: listen-backlog ( -- n ) 0x7fffffff ; inline\r
-\r
-M: object (server) ( addrspec -- handle )\r
- [\r
- SOCK_STREAM server-socket\r
- dup handle>> listen-backlog listen winsock-return-check\r
- ] with-destructors ;\r
-\r
-M: windows (datagram) ( addrspec -- handle )\r
- [ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows (raw) ( addrspec -- handle )\r
- [ SOCK_RAW server-socket ] with-destructors ;\r
-\r
-M: windows (broadcast) ( datagram -- datagram )\r
- dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;\r
-\r
-: malloc-int ( n -- alien )\r
- int <ref> malloc-byte-array ; inline\r
-\r
-M: windows WSASocket-flags ( -- DWORD )\r
- WSA_FLAG_OVERLAPPED ; inline\r
-\r
-: get-ConnectEx-ptr ( socket -- void* )\r
- SIO_GET_EXTENSION_FUNCTION_POINTER\r
- WSAID_CONNECTEX\r
- GUID heap-size\r
- { void* }\r
- [\r
- void* heap-size\r
- 0 DWORD <ref>\r
- f\r
- f\r
- WSAIoctl SOCKET_ERROR = [\r
- maybe-winsock-exception throw\r
- ] when\r
- ] with-out-parameters ;\r
-\r
-TUPLE: ConnectEx-args port\r
- s name namelen lpSendBuffer dwSendDataLength\r
- lpdwBytesSent lpOverlapped ptr ;\r
-\r
-: wait-for-socket ( args -- count )\r
- [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline\r
-\r
-: <ConnectEx-args> ( sockaddr size -- ConnectEx )\r
- ConnectEx-args new\r
- swap >>namelen\r
- swap >>name\r
- f >>lpSendBuffer\r
- 0 >>dwSendDataLength\r
- f >>lpdwBytesSent\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-ConnectEx ( ConnectEx -- )\r
- {\r
- [ s>> ]\r
- [ name>> ]\r
- [ namelen>> ]\r
- [ lpSendBuffer>> ]\r
- [ dwSendDataLength>> ]\r
- [ lpdwBytesSent>> ]\r
- [ lpOverlapped>> ]\r
- [ ptr>> ]\r
- } cleave\r
- int\r
- { SOCKET void* int PVOID DWORD LPDWORD void* }\r
- stdcall alien-indirect drop\r
- winsock-error ; inline\r
-\r
-M: object establish-connection ( client-out remote -- )\r
- make-sockaddr/size <ConnectEx-args>\r
- swap >>port\r
- dup port>> handle>> handle>> >>s\r
- dup s>> get-ConnectEx-ptr >>ptr\r
- dup call-ConnectEx\r
- wait-for-socket drop ;\r
-\r
-TUPLE: AcceptEx-args port\r
- sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength\r
- dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;\r
-\r
-: init-accept-buffer ( addr AcceptEx -- )\r
- swap sockaddr-size 16 +\r
- [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi\r
- dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer\r
- drop ; inline\r
-\r
-: <AcceptEx-args> ( server addr -- AcceptEx )\r
- AcceptEx-args new\r
- 2dup init-accept-buffer\r
- swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket\r
- over handle>> handle>> >>sListenSocket\r
- swap >>port\r
- 0 >>dwReceiveDataLength\r
- f >>lpdwBytesReceived\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-! AcceptEx return value is useless\r
-: call-AcceptEx ( AcceptEx -- )\r
- {\r
- [ sListenSocket>> ]\r
- [ sAcceptSocket>> ]\r
- [ lpOutputBuffer>> ]\r
- [ dwReceiveDataLength>> ]\r
- [ dwLocalAddressLength>> ]\r
- [ dwRemoteAddressLength>> ]\r
- [ lpdwBytesReceived>> ]\r
- [ lpOverlapped>> ]\r
- } cleave AcceptEx drop winsock-error ; inline\r
-\r
-: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
- f void* <ref> 0 int <ref> f void* <ref>\r
- [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
-\r
-: extract-remote-address ( AcceptEx -- sockaddr )\r
- [\r
- {\r
- [ lpOutputBuffer>> ]\r
- [ dwReceiveDataLength>> ]\r
- [ dwLocalAddressLength>> ]\r
- [ dwRemoteAddressLength>> ]\r
- } cleave\r
- (extract-remote-address)\r
- ] [ port>> addr>> protocol-family ] bi\r
- sockaddr-of-family ; inline\r
-\r
-M: object (accept) ( server addr -- handle sockaddr )\r
- [\r
- <AcceptEx-args>\r
- {\r
- [ call-AcceptEx ]\r
- [ wait-for-socket drop ]\r
- [ sAcceptSocket>> <win32-socket> ]\r
- [ extract-remote-address ]\r
- } cleave\r
- ] with-destructors ;\r
-\r
-TUPLE: WSARecvFrom-args port\r
- s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
- lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
-\r
-:: make-receive-buffer ( n buf -- buf' WSABUF )\r
- buf >c-ptr pinned-alien?\r
- [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'\r
- buf'\r
- WSABUF malloc-struct &free\r
- n >>len\r
- buf' >>buf ; inline\r
-\r
-:: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )\r
- n buf make-receive-buffer :> ( buf' wsaBuf )\r
- buf buf'\r
- WSARecvFrom-args new\r
- datagram >>port\r
- datagram handle>> handle>> >>s\r
- datagram addr>> sockaddr-size\r
- [ malloc &free >>lpFrom ]\r
- [ malloc-int &free >>lpFromLen ] bi\r
- wsaBuf >>lpBuffers\r
- 1 >>dwBufferCount\r
- 0 malloc-int &free >>lpFlags\r
- 0 malloc-int &free >>lpNumberOfBytesRecvd\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-WSARecvFrom ( WSARecvFrom -- )\r
- {\r
- [ s>> ]\r
- [ lpBuffers>> ]\r
- [ dwBufferCount>> ]\r
- [ lpNumberOfBytesRecvd>> ]\r
- [ lpFlags>> ]\r
- [ lpFrom>> ]\r
- [ lpFromLen>> ]\r
- [ lpOverlapped>> ]\r
- [ lpCompletionRoutine>> ]\r
- } cleave WSARecvFrom socket-error* ; inline\r
-\r
-:: finalize-buf ( buf buf' count -- )\r
- buf buf' eq? [ buf buf' count memcpy ] unless ; inline\r
-\r
-:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )\r
- buf buf' count finalize-buf\r
- count wsaRecvFrom\r
- [ port>> addr>> empty-sockaddr dup ]\r
- [ lpFrom>> ]\r
- [ lpFromLen>> int deref ]\r
- tri memcpy ; inline\r
-\r
-M: windows (receive-unsafe) ( n buf datagram -- count addrspec )\r
- [\r
- <WSARecvFrom-args>\r
- [ call-WSARecvFrom ]\r
- [ wait-for-socket ]\r
- [ parse-WSARecvFrom ]\r
- tri\r
- ] with-destructors ;\r
-\r
-TUPLE: WSASendTo-args port\r
- s lpBuffers dwBufferCount lpNumberOfBytesSent\r
- dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
-\r
-: make-send-buffer ( packet -- WSABUF )\r
- [ WSABUF malloc-struct &free ] dip\r
- [ malloc-byte-array &free >>buf ]\r
- [ length >>len ] bi ; inline\r
-\r
-: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
- WSASendTo-args new\r
- swap >>port\r
- dup port>> handle>> handle>> >>s\r
- swap make-sockaddr/size\r
- [ malloc-byte-array &free ] dip\r
- [ >>lpTo ] [ >>iToLen ] bi*\r
- swap make-send-buffer >>lpBuffers\r
- 1 >>dwBufferCount\r
- 0 >>dwFlags\r
- 0 uint <ref> >>lpNumberOfBytesSent\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-WSASendTo ( WSASendTo -- )\r
- {\r
- [ s>> ]\r
- [ lpBuffers>> ]\r
- [ dwBufferCount>> ]\r
- [ lpNumberOfBytesSent>> ]\r
- [ dwFlags>> ]\r
- [ lpTo>> ]\r
- [ iToLen>> ]\r
- [ lpOverlapped>> ]\r
- [ lpCompletionRoutine>> ]\r
- } cleave WSASendTo socket-error* ; inline\r
-\r
-M: windows (send) ( packet addrspec datagram -- )\r
- [\r
- <WSASendTo-args>\r
- [ call-WSASendTo ]\r
- [ wait-for-socket drop ]\r
- bi\r
- ] with-destructors ;\r
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.data classes.struct
+combinators destructors io.backend io.files.windows io.ports
+io.sockets io.sockets.icmp io.sockets.private kernel libc locals
+math sequences system windows.errors windows.handles
+windows.kernel32 windows.types windows.winsock ;
+FROM: namespaces => get ;
+IN: io.sockets.windows
+
+: set-socket-option ( handle level opt -- )
+ [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;
+
+: set-ioctl-socket ( handle cmd arg -- )
+ [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;
+
+M: windows addrinfo-error-string ( n -- string )
+ n>win32-error-string ;
+
+M: windows sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: windows addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ ipv4 } ] }
+ { AF_INET6 [ T{ ipv6 } ] }
+ [ drop f ]
+ } case ;
+
+HOOK: WSASocket-flags io-backend ( -- DWORD )
+
+TUPLE: win32-socket < win32-file ;
+
+: <win32-socket> ( handle -- win32-socket )
+ win32-socket new-win32-handle ;
+
+M: win32-socket dispose* ( stream -- )
+ handle>> closesocket socket-error* ;
+
+: unspecific-sockaddr/size ( addrspec -- sockaddr len )
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;
+
+: opened-socket ( handle -- win32-socket )
+ <win32-socket> |dispose add-completion ;
+
+: open-socket ( addrspec type -- win32-socket )
+ [ drop protocol-family ] [ swap protocol ] 2bi
+ f 0 WSASocket-flags WSASocket
+ dup socket-error
+ opened-socket ;
+
+M: object (get-local-address) ( socket addrspec -- sockaddr )
+ [ handle>> ] dip empty-sockaddr/size int <ref>
+ [ getsockname socket-error ] 2keep drop ;
+
+M: object (get-remote-address) ( socket addrspec -- sockaddr )
+ [ handle>> ] dip empty-sockaddr/size int <ref>
+ [ getpeername socket-error ] 2keep drop ;
+
+: bind-socket ( win32-socket sockaddr len -- )
+ [ handle>> ] 2dip bind socket-error ;
+
+M: object ((client)) ( addrspec -- handle )
+ [ SOCK_STREAM open-socket ] keep
+ [
+ bind-local-address get
+ [ nip make-sockaddr/size ]
+ [ unspecific-sockaddr/size ] if* bind-socket
+ ] [ drop ] 2bi ;
+
+: server-socket ( addrspec type -- fd )
+ [ open-socket ] [ drop ] 2bi
+ [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
+
+! http://support.microsoft.com/kb/127144
+! NOTE: Possibly tweak this because of SYN flood attacks
+: listen-backlog ( -- n ) 0x7fffffff ; inline
+
+M: object (server) ( addrspec -- handle )
+ [
+ SOCK_STREAM server-socket
+ dup handle>> listen-backlog listen winsock-return-check
+ ] with-destructors ;
+
+M: windows (datagram) ( addrspec -- handle )
+ [ SOCK_DGRAM server-socket ] with-destructors ;
+
+M: windows (raw) ( addrspec -- handle )
+ [ SOCK_RAW server-socket ] with-destructors ;
+
+M: windows (broadcast) ( datagram -- datagram )
+ dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
+
+: malloc-int ( n -- alien )
+ int <ref> malloc-byte-array ; inline
+
+M: windows WSASocket-flags ( -- DWORD )
+ WSA_FLAG_OVERLAPPED ; inline
+
+: get-ConnectEx-ptr ( socket -- void* )
+ SIO_GET_EXTENSION_FUNCTION_POINTER
+ WSAID_CONNECTEX
+ GUID heap-size
+ { void* }
+ [
+ void* heap-size
+ 0 DWORD <ref>
+ f
+ f
+ WSAIoctl SOCKET_ERROR = [
+ maybe-winsock-exception throw
+ ] when
+ ] with-out-parameters ;
+
+TUPLE: ConnectEx-args port
+ s name namelen lpSendBuffer dwSendDataLength
+ lpdwBytesSent lpOverlapped ptr ;
+
+: wait-for-socket ( args -- count )
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
+
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )
+ ConnectEx-args new
+ swap >>namelen
+ swap >>name
+ f >>lpSendBuffer
+ 0 >>dwSendDataLength
+ f >>lpdwBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-ConnectEx ( ConnectEx -- )
+ {
+ [ s>> ]
+ [ name>> ]
+ [ namelen>> ]
+ [ lpSendBuffer>> ]
+ [ dwSendDataLength>> ]
+ [ lpdwBytesSent>> ]
+ [ lpOverlapped>> ]
+ [ ptr>> ]
+ } cleave
+ int
+ { SOCKET void* int PVOID DWORD LPDWORD void* }
+ stdcall alien-indirect drop
+ winsock-error ; inline
+
+M: object establish-connection ( client-out remote -- )
+ make-sockaddr/size <ConnectEx-args>
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ dup s>> get-ConnectEx-ptr >>ptr
+ dup call-ConnectEx
+ wait-for-socket drop ;
+
+TUPLE: AcceptEx-args port
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
+
+: init-accept-buffer ( addr AcceptEx -- )
+ swap sockaddr-size 16 +
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
+ drop ; inline
+
+: <AcceptEx-args> ( server addr -- AcceptEx )
+ AcceptEx-args new
+ 2dup init-accept-buffer
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
+ over handle>> handle>> >>sListenSocket
+ swap >>port
+ 0 >>dwReceiveDataLength
+ f >>lpdwBytesReceived
+ (make-overlapped) >>lpOverlapped ; inline
+
+! AcceptEx return value is useless
+: call-AcceptEx ( AcceptEx -- )
+ {
+ [ sListenSocket>> ]
+ [ sAcceptSocket>> ]
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ [ lpdwBytesReceived>> ]
+ [ lpOverlapped>> ]
+ } cleave AcceptEx drop winsock-error ; inline
+
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f void* <ref> 0 int <ref> f void* <ref>
+ [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
+
+: extract-remote-address ( AcceptEx -- sockaddr )
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
+
+M: object (accept) ( server addr -- handle sockaddr )
+ [
+ <AcceptEx-args>
+ {
+ [ call-AcceptEx ]
+ [ wait-for-socket drop ]
+ [ sAcceptSocket>> <win32-socket> ]
+ [ extract-remote-address ]
+ } cleave
+ ] with-destructors ;
+
+TUPLE: WSARecvFrom-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
+
+:: make-receive-buffer ( n buf -- buf' WSABUF )
+ buf >c-ptr pinned-alien?
+ [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'
+ buf'
+ WSABUF malloc-struct &free
+ n >>len
+ buf' >>buf ; inline
+
+:: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )
+ n buf make-receive-buffer :> ( buf' wsaBuf )
+ buf buf'
+ WSARecvFrom-args new
+ datagram >>port
+ datagram handle>> handle>> >>s
+ datagram addr>> sockaddr-size
+ [ malloc &free >>lpFrom ]
+ [ malloc-int &free >>lpFromLen ] bi
+ wsaBuf >>lpBuffers
+ 1 >>dwBufferCount
+ 0 malloc-int &free >>lpFlags
+ 0 malloc-int &free >>lpNumberOfBytesRecvd
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSARecvFrom ( WSARecvFrom -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesRecvd>> ]
+ [ lpFlags>> ]
+ [ lpFrom>> ]
+ [ lpFromLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSARecvFrom socket-error* ; inline
+
+:: finalize-buf ( buf buf' count -- )
+ buf buf' eq? [ buf buf' count memcpy ] unless ; inline
+
+:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )
+ buf buf' count finalize-buf
+ count wsaRecvFrom
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> int deref ]
+ tri memcpy ; inline
+
+M: windows (receive-unsafe) ( n buf datagram -- count addrspec )
+ [
+ <WSARecvFrom-args>
+ [ call-WSARecvFrom ]
+ [ wait-for-socket ]
+ [ parse-WSARecvFrom ]
+ tri
+ ] with-destructors ;
+
+TUPLE: WSASendTo-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesSent
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
+
+: make-send-buffer ( packet -- WSABUF )
+ [ WSABUF malloc-struct &free ] dip
+ [ malloc-byte-array &free >>buf ]
+ [ length >>len ] bi ; inline
+
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
+ WSASendTo-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ swap make-sockaddr/size
+ [ malloc-byte-array &free ] dip
+ [ >>lpTo ] [ >>iToLen ] bi*
+ swap make-send-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 >>dwFlags
+ 0 uint <ref> >>lpNumberOfBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSASendTo ( WSASendTo -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesSent>> ]
+ [ dwFlags>> ]
+ [ lpTo>> ]
+ [ iToLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSASendTo socket-error* ; inline
+
+M: windows (send) ( packet addrspec datagram -- )
+ [
+ <WSASendTo-args>
+ [ call-WSASendTo ]
+ [ wait-for-socket drop ]
+ bi
+ ] with-destructors ;
projects / factor.git / blobdiff