! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alien.c-types classes.struct combinators\r
-destructors io.backend io.backend.windows io.sockets\r
-io.sockets.private kernel system windows.handles\r
-windows.winsock ;\r
+USING: accessors alien alien.c-types alien.data classes.struct\r
+combinators destructors io.backend io.ports\r
+io.sockets io.sockets.private kernel libc math sequences system\r
+windows.handles windows.kernel32 windows.types windows.winsock ;\r
FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+\r
+: malloc-int ( n -- alien )\r
+ <int> malloc-byte-array ; inline\r
+\r
+M: winnt WSASocket-flags ( -- DWORD )\r
+ WSA_FLAG_OVERLAPPED ;\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
+ DWORD <c-object>\r
+ f\r
+ f\r
+ WSAIoctl SOCKET_ERROR = [\r
+ winsock-error-string 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 -- n )\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-string [ throw ] when* ; 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
+: call-AcceptEx ( AcceptEx -- )\r
+ {\r
+ [ sListenSocket>> ]\r
+ [ sAcceptSocket>> ]\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ [ lpdwBytesReceived>> ]\r
+ [ lpOverlapped>> ]\r
+ } cleave AcceptEx drop\r
+ winsock-error-string [ throw ] when* ; inline\r
+\r
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;\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 ( -- WSABUF )\r
+ WSABUF malloc-struct &free\r
+ default-buffer-size get\r
+ [ >>len ] [ malloc &free >>buf ] bi ; inline\r
+\r
+: <WSARecvFrom-args> ( datagram -- WSARecvFrom )\r
+ WSARecvFrom-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup port>> addr>> sockaddr-size\r
+ [ malloc &free >>lpFrom ]\r
+ [ malloc-int &free >>lpFromLen ] bi\r
+ make-receive-buffer >>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
+: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )\r
+ [ lpBuffers>> buf>> swap memory>byte-array ]\r
+ [\r
+ [ port>> addr>> empty-sockaddr dup ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> *int ]\r
+ tri memcpy\r
+ ] bi ; inline\r
+\r
+M: winnt (receive) ( datagram -- packet 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> >>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: winnt (send) ( packet addrspec datagram -- )\r
+ [\r
+ <WSASendTo-args>\r
+ [ call-WSASendTo ]\r
+ [ wait-for-socket drop ]\r
+ bi\r
+ ] with-destructors ;\r
projects / factor.git / blobdiff