1 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.strings alien.syntax arrays
4 byte-arrays kernel math sequences windows.types windows.kernel32
5 windows.errors math.bitwise io.encodings.utf16n classes.struct
6 literals windows.com.syntax ;
10 : alien>byte-array ( alien str -- byte-array )
11 heap-size dup <byte-array> [ -rot memcpy ] keep ;
15 : <wsadata> ( -- byte-array )
16 HEX: 190 <byte-array> ;
18 CONSTANT: SOCK_STREAM 1
19 CONSTANT: SOCK_DGRAM 2
22 CONSTANT: SOCK_SEQPACKET 5
24 CONSTANT: SO_DEBUG HEX: 1
25 CONSTANT: SO_ACCEPTCONN HEX: 2
26 CONSTANT: SO_REUSEADDR HEX: 4
27 CONSTANT: SO_KEEPALIVE HEX: 8
28 CONSTANT: SO_DONTROUTE HEX: 10
29 CONSTANT: SO_BROADCAST HEX: 20
30 CONSTANT: SO_USELOOPBACK HEX: 40
31 CONSTANT: SO_LINGER HEX: 80
32 CONSTANT: SO_OOBINLINE HEX: 100
33 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
35 CONSTANT: SO_SNDBUF HEX: 1001
36 CONSTANT: SO_RCVBUF HEX: 1002
37 CONSTANT: SO_SNDLOWAT HEX: 1003
38 CONSTANT: SO_RCVLOWAT HEX: 1004
39 CONSTANT: SO_SNDTIMEO HEX: 1005
40 CONSTANT: SO_RCVTIMEO HEX: 1006
41 CONSTANT: SO_ERROR HEX: 1007
42 CONSTANT: SO_TYPE HEX: 1008
44 CONSTANT: TCP_NODELAY HEX: 1
49 CONSTANT: AF_IMPLINK 3
56 CONSTANT: AF_DATAKIT 9
59 CONSTANT: AF_DECnet 12
62 CONSTANT: AF_HYLINK 15
63 CONSTANT: AF_APPLETALK 16
64 CONSTANT: AF_NETBIOS 17
75 CONSTANT: AI_PASSIVE 1
76 CONSTANT: AI_CANONNAME 2
77 CONSTANT: AI_NUMERICHOST 4
78 : AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
80 CONSTANT: NI_NUMERICHOST 1
81 CONSTANT: NI_NUMERICSERV 2
83 CONSTANT: IPPROTO_TCP 6
84 CONSTANT: IPPROTO_UDP 17
85 CONSTANT: IPPROTO_RM 113
87 CONSTANT: WSA_FLAG_OVERLAPPED 1
88 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
89 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
90 CONSTANT: WSA_INVALID_EVENT f
91 CONSTANT: WSA_WAIT_FAILED -1
92 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
93 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
94 ALIAS: WSA_INFINITE INFINITE
95 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
97 CONSTANT: INADDR_ANY 0
99 : INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
100 CONSTANT: SOCKET_ERROR -1
106 CONSTANT: SOL_SOCKET HEX: ffff
108 ! TYPEDEF: uint in_addr_t
110 ! { "in_addr_t" "s_addr" } ;
112 C-STRUCT: sockaddr-in
116 { { "char" 8 } "pad" } ;
118 C-STRUCT: sockaddr-in6
121 { "uint" "flowinfo" }
122 { { "uchar" 16 } "addr" }
123 { "uint" "scopeid" } ;
130 { addr-list void* } ;
137 { "size_t" "addrlen" }
138 { "char*" "canonname" }
139 { "sockaddr*" "addr" }
140 { "addrinfo*" "next" } ;
148 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
150 FUNCTION: ushort htons ( ushort n ) ;
151 FUNCTION: ushort ntohs ( ushort n ) ;
152 FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
153 FUNCTION: int listen ( void* socket, int backlog ) ;
154 FUNCTION: char* inet_ntoa ( int in-addr ) ;
155 FUNCTION: int getaddrinfo ( char* nodename,
160 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
163 FUNCTION: hostent* gethostbyname ( char* name ) ;
164 FUNCTION: int gethostname ( char* name, int len ) ;
165 FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
166 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
167 FUNCTION: int closesocket ( SOCKET s ) ;
168 FUNCTION: int shutdown ( SOCKET s, int how ) ;
169 FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
170 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
172 FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
173 FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
175 TYPEDEF: uint SERVICETYPE
176 TYPEDEF: OVERLAPPED WSAOVERLAPPED
177 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
179 TYPEDEF: void* LPCONDITIONPROC
180 TYPEDEF: HANDLE WSAEVENT
181 TYPEDEF: LPHANDLE LPWSAEVENT
182 TYPEDEF: sockaddr* LPSOCKADDR
185 { "uint" "TokenRate" }
186 { "uint" "TokenBucketSize" }
187 { "uint" "PeakBandwidth" }
189 { "uint" "DelayVariation" }
190 { "SERVICETYPE" "ServiceType" }
191 { "uint" "MaxSduSize" }
192 { "uint" "MinimumPolicedSize" } ;
193 TYPEDEF: FLOWSPEC* PFLOWSPEC
194 TYPEDEF: FLOWSPEC* LPFLOWSPEC
199 TYPEDEF: WSABUF* LPWSABUF
202 { "FLOWSPEC" "SendingFlowspec" }
203 { "FLOWSPEC" "ReceivingFlowspec" }
204 { "WSABUF" "ProviderSpecific" } ;
207 CONSTANT: MAX_PROTOCOL_CHAIN 7
209 C-STRUCT: WSAPROTOCOLCHAIN
211 ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ;
212 { { "DWORD" 7 } "ChainEntries" } ;
213 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
215 CONSTANT: WSAPROTOCOL_LEN 255
217 C-STRUCT: WSAPROTOCOL_INFOW
218 { "DWORD" "dwServiceFlags1" }
219 { "DWORD" "dwServiceFlags2" }
220 { "DWORD" "dwServiceFlags3" }
221 { "DWORD" "dwServiceFlags4" }
222 { "DWORD" "dwProviderFlags" }
223 { "GUID" "ProviderId" }
224 { "DWORD" "dwCatalogEntryId" }
225 { "WSAPROTOCOLCHAIN" "ProtocolChain" }
227 { "int" "iAddressFamily" }
228 { "int" "iMaxSockAddr" }
229 { "int" "iMinSockAddr" }
230 { "int" "iSocketType" }
231 { "int" "iProtocol" }
232 { "int" "iProtocolMaxOffset" }
233 { "int" "iNetworkByteOrder" }
234 { "int" "iSecurityScheme" }
235 { "DWORD" "dwMessageSize" }
236 { "DWORD" "dwProviderReserved" }
237 { { "WCHAR" 256 } "szProtocol" } ;
238 ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ;
239 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
240 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
241 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
242 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
243 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
246 C-STRUCT: WSANAMESPACE_INFOW
247 { "GUID" "NSProviderId" }
248 { "DWORD" "dwNameSpace" }
250 { "DWORD" "dwVersion" }
251 { "LPWSTR" "lpszIdentifier" } ;
252 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
253 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
254 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
255 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
256 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
258 CONSTANT: FD_MAX_EVENTS 10
260 C-STRUCT: WSANETWORKEVENTS
261 { "long" "lNetworkEvents" }
262 { { "int" FD_MAX_EVENTS } "iErrorCode" } ;
263 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
264 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
266 ! C-STRUCT: WSAOVERLAPPED
267 ! { "DWORD" "Internal" }
268 ! { "DWORD" "InternalHigh" }
269 ! { "DWORD" "Offset" }
270 ! { "DWORD" "OffsetHigh" }
271 ! { "WSAEVENT" "hEvent" }
272 ! { "DWORD" "bytesTransferred" } ;
273 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
275 FUNCTION: SOCKET WSAAccept ( SOCKET s,
278 LPCONDITIONPROC lpfnCondition,
279 DWORD dwCallbackData ) ;
281 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
283 FUNCTION: int WSACleanup ( ) ;
284 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
286 FUNCTION: int WSAConnect ( SOCKET s,
289 LPWSABUF lpCallerData,
290 LPWSABUF lpCalleeData,
293 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
294 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
295 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
296 WSAEVENT hEventObject,
297 LPWSANETWORKEVENTS lpNetworkEvents ) ;
298 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
300 FUNCTION: int WSAEventSelect ( SOCKET s,
301 WSAEVENT hEventObject,
302 long lNetworkEvents ) ;
303 FUNCTION: int WSAGetLastError ( ) ;
304 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
305 LPWSAOVERLAPPED lpOverlapped,
306 LPDWORD lpcbTransfer,
308 LPDWORD lpdwFlags ) ;
310 FUNCTION: int WSAIoctl ( SOCKET s,
311 DWORD dwIoControlCode,
316 LPDWORD lpcbBytesReturned,
318 void* lpCompletionRoutine ) ;
320 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
321 FUNCTION: int WSARecv ( SOCKET s,
324 LPDWORD lpNumberOfBytesRecvd,
326 LPWSAOVERLAPPED lpOverlapped,
327 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
329 FUNCTION: int WSARecvFrom ( SOCKET s,
332 LPDWORD lpNumberOfBytesRecvd,
336 LPWSAOVERLAPPED lpOverlapped,
337 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
339 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
340 FUNCTION: int WSASend ( SOCKET s,
343 LPDWORD lpNumberOfBytesSent,
345 LPWSAOVERLAPPED lpOverlapped,
346 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
348 FUNCTION: int WSASendTo ( SOCKET s,
351 LPDWORD lpNumberOfBytesSent,
355 LPWSAOVERLAPPED lpOverlapped,
356 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
359 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
363 FUNCTION: SOCKET WSASocketW ( int af,
366 LPWSAPROTOCOL_INFOW lpProtocolInfo,
369 ALIAS: WSASocket WSASocketW
371 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
381 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
382 FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
384 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
386 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
388 : winsock-expected-error? ( n -- ? )
389 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
391 : (winsock-error-string) ( n -- str )
392 ! #! WSAStartup returns the error code 'n' directly
393 dup winsock-expected-error?
394 [ drop f ] [ n>win32-error-string ] if ;
396 : winsock-error-string ( -- string/f )
397 WSAGetLastError (winsock-error-string) ;
399 : winsock-error ( -- )
400 winsock-error-string [ throw ] when* ;
402 : winsock-error=0/f ( n/f -- )
404 winsock-error-string throw
407 : winsock-error!=0/f ( n/f -- )
409 winsock-error-string throw
412 : winsock-return-check ( n/f -- )
413 dup { 0 f } member? [
416 (winsock-error-string) throw
419 : socket-error* ( n -- )
422 dup WSA_IO_PENDING = [
425 (winsock-error-string) throw
429 : socket-error ( n -- )
430 SOCKET_ERROR = [ winsock-error ] when ;
432 : init-winsock ( -- )
433 HEX: 0202 <wsadata> WSAStartup winsock-return-check ;