1 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data alien.syntax
4 byte-arrays classes.struct grouping init kernel literals math
5 math.parser sequences system vocabs.parser windows.com.syntax
6 windows.errors windows.kernel32 windows.types ;
7 FROM: alien.c-types => short ;
11 ! Some differences between Win32 and Win64
12 cpu x86.64? "windows.winsock.64" "windows.winsock.32" ? use-vocab
17 : <wsadata> ( -- byte-array )
20 CONSTANT: SOCK_STREAM 1
21 CONSTANT: SOCK_DGRAM 2
24 CONSTANT: SOCK_SEQPACKET 5
26 CONSTANT: SO_DEBUG 0x1
27 CONSTANT: SO_ACCEPTCONN 0x2
28 CONSTANT: SO_REUSEADDR 0x4
29 CONSTANT: SO_KEEPALIVE 0x8
30 CONSTANT: SO_DONTROUTE 0x10
31 CONSTANT: SO_BROADCAST 0x20
32 CONSTANT: SO_USELOOPBACK 0x40
33 CONSTANT: SO_LINGER 0x80
34 CONSTANT: SO_OOBINLINE 0x100
35 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
37 CONSTANT: SO_SNDBUF 0x1001
38 CONSTANT: SO_RCVBUF 0x1002
39 CONSTANT: SO_SNDLOWAT 0x1003
40 CONSTANT: SO_RCVLOWAT 0x1004
41 CONSTANT: SO_SNDTIMEO 0x1005
42 CONSTANT: SO_RCVTIMEO 0x1006
43 CONSTANT: SO_ERROR 0x1007
44 CONSTANT: SO_TYPE 0x1008
46 CONSTANT: TCP_NODELAY 0x1
51 CONSTANT: AF_IMPLINK 3
58 CONSTANT: AF_DATAKIT 9
61 CONSTANT: AF_DECnet 12
64 CONSTANT: AF_HYLINK 15
65 CONSTANT: AF_APPLETALK 16
66 CONSTANT: AF_NETBIOS 17
77 CONSTANT: AI_PASSIVE 0x0001
78 CONSTANT: AI_CANONNAME 0x0002
79 CONSTANT: AI_NUMERICHOST 0x0004
80 CONSTANT: AI_ALL 0x0100
81 CONSTANT: AI_ADDRCONFIG 0x0400
83 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
85 CONSTANT: NI_NUMERICHOST 1
86 CONSTANT: NI_NUMERICSERV 2
88 CONSTANT: IPPROTO_TCP 6
89 CONSTANT: IPPROTO_UDP 17
90 CONSTANT: IPPROTO_RM 113
92 CONSTANT: FIOASYNC 0x8004667d
93 CONSTANT: FIONBIO 0x8004667e
94 CONSTANT: FIONREAD 0x4004667f
96 CONSTANT: WSA_FLAG_OVERLAPPED 1
97 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
98 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
99 CONSTANT: WSA_INVALID_EVENT f
100 CONSTANT: WSA_WAIT_FAILED -1
101 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
102 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
103 ALIAS: WSA_INFINITE INFINITE
104 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
106 CONSTANT: INADDR_ANY 0
108 : INVALID_SOCKET ( -- n ) -1 <alien> ; inline
110 : SOCKET_ERROR ( -- n ) -1 ; inline
116 CONSTANT: SOL_SOCKET 0xffff
138 { addr-list void* } ;
151 { canonname c-string }
159 GENERIC: sockaddr>ip ( sockaddr -- string )
161 M: sockaddr-in sockaddr>ip ( sockaddr -- string )
162 addr>> uint <ref> [ number>string ] { } map-as "." join ;
164 M: sockaddr-in6 sockaddr>ip ( uchar-array -- string )
165 addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
169 { fd_array SOCKET[64] } ;
173 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen )
174 FUNCTION: int ioctlsocket ( SOCKET s, long cmd, ulong* *argp )
176 FUNCTION: ushort htons ( ushort n )
177 FUNCTION: ushort ntohs ( ushort n )
178 FUNCTION: int bind ( SOCKET socket, sockaddr-in* sockaddr, int len )
179 FUNCTION: int listen ( SOCKET socket, int backlog )
180 FUNCTION: c-string inet_ntoa ( int in-addr )
181 FUNCTION: int getaddrinfo ( c-string nodename,
186 FUNCTION: void freeaddrinfo ( addrinfo* ai )
189 FUNCTION: hostent* gethostbyname ( c-string name )
190 FUNCTION: int gethostname ( c-string name, int len )
191 FUNCTION: SOCKET socket ( int domain, int type, int protocol )
192 FUNCTION: int connect ( SOCKET socket, sockaddr-in* sockaddr, int addrlen )
193 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout )
194 FUNCTION: int closesocket ( SOCKET s )
195 FUNCTION: int shutdown ( SOCKET s, int how )
196 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags )
197 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags )
199 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen )
200 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen )
202 FUNCTION: protoent* getprotobyname ( c-string name )
204 FUNCTION: servent* getservbyname ( c-string name, c-string prot )
205 FUNCTION: servent* getservbyport ( int port, c-string prot )
207 TYPEDEF: uint SERVICETYPE
208 TYPEDEF: void* LPWSADATA
209 TYPEDEF: OVERLAPPED WSAOVERLAPPED
210 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
212 TYPEDEF: void* LPCONDITIONPROC
213 TYPEDEF: HANDLE WSAEVENT
214 TYPEDEF: LPHANDLE LPWSAEVENT
215 TYPEDEF: sockaddr* LPSOCKADDR
219 { TokenBucketSize uint }
220 { PeakBandwidth uint }
222 { DelayVariation uint }
223 { ServiceType SERVICETYPE }
225 { MinimumPolicedSize uint } ;
226 TYPEDEF: FLOWSPEC* PFLOWSPEC
227 TYPEDEF: FLOWSPEC* LPFLOWSPEC
232 TYPEDEF: WSABUF* LPWSABUF
235 { SendingFlowspec FLOWSPEC }
236 { ReceivingFlowspec FLOWSPEC }
237 { ProviderSpecific WSABUF } ;
240 CONSTANT: MAX_PROTOCOL_CHAIN 7
242 STRUCT: WSAPROTOCOLCHAIN
244 { ChainEntries { DWORD 7 } } ;
245 ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
246 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
248 CONSTANT: WSAPROTOCOL_LEN 255
250 STRUCT: WSAPROTOCOL_INFOW
251 { dwServiceFlags1 DWORD }
252 { dwServiceFlags2 DWORD }
253 { dwServiceFlags3 DWORD }
254 { dwServiceFlags4 DWORD }
255 { dwProviderFlags DWORD }
257 { dwCatalogEntryId DWORD }
258 { ProtocolChain WSAPROTOCOLCHAIN }
260 { iAddressFamily int }
265 { iProtocolMaxOffset int }
266 { iNetworkByteOrder int }
267 { iSecurityScheme int }
268 { dwMessageSize DWORD }
269 { dwProviderReserved DWORD }
270 { szProtocol { WCHAR 256 } } ;
271 ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
272 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
273 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
274 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
275 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
276 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
279 STRUCT: WSANAMESPACE_INFOW
280 { NSProviderId GUID }
281 { dwNameSpace DWORD }
284 { lpszIdentifier LPWSTR } ;
285 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
286 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
287 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
288 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
289 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
291 CONSTANT: FD_MAX_EVENTS 10
293 STRUCT: WSANETWORKEVENTS
294 { lNetworkEvents long }
295 { iErrorCode { int FD_MAX_EVENTS } } ;
296 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
297 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
299 ! STRUCT: WSAOVERLAPPED
301 ! { InternalHigh DWORD }
303 ! { OffsetHigh DWORD }
304 ! { hEvent WSAEVENT }
305 ! { bytesTransferred DWORD } ;
306 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
308 FUNCTION: SOCKET WSAAccept ( SOCKET s,
311 LPCONDITIONPROC lpfnCondition,
312 DWORD dwCallbackData )
314 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
316 FUNCTION: int WSACleanup ( )
317 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent )
319 FUNCTION: int WSAConnect ( SOCKET s,
322 LPWSABUF lpCallerData,
323 LPWSABUF lpCalleeData,
326 FUNCTION: WSAEVENT WSACreateEvent ( )
327 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
328 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
329 WSAEVENT hEventObject,
330 LPWSANETWORKEVENTS lpNetworkEvents )
331 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
333 FUNCTION: int WSAEventSelect ( SOCKET s,
334 WSAEVENT hEventObject,
335 long lNetworkEvents )
336 FUNCTION: int WSAGetLastError ( )
337 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
338 LPWSAOVERLAPPED lpOverlapped,
339 LPDWORD lpcbTransfer,
343 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
344 FUNCTION: int WSAIoctl ( SOCKET s,
345 DWORD dwIoControlCode,
350 LPDWORD lpcbBytesReturned,
351 LPWSAOVERLAPPED lpOverlapped,
352 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
354 FUNCTION: int WSARecv ( SOCKET s,
357 LPDWORD lpNumberOfBytesRecvd,
359 LPWSAOVERLAPPED lpOverlapped,
360 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
362 FUNCTION: int WSARecvFrom ( SOCKET s,
365 LPDWORD lpNumberOfBytesRecvd,
369 LPWSAOVERLAPPED lpOverlapped,
370 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
372 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent )
373 FUNCTION: int WSASend ( SOCKET s,
376 LPDWORD lpNumberOfBytesSent,
378 LPWSAOVERLAPPED lpOverlapped,
379 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
381 FUNCTION: int WSASendTo ( SOCKET s,
384 LPDWORD lpNumberOfBytesSent,
388 LPWSAOVERLAPPED lpOverlapped,
389 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine )
391 FUNCTION: int WSAStartup ( WORD version, LPWSADATA out-data )
393 FUNCTION: SOCKET WSASocketW ( int af,
396 LPWSAPROTOCOL_INFOW lpProtocolInfo,
399 ALIAS: WSASocket WSASocketW
401 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
410 FUNCTION: int AcceptEx ( SOCKET listen,
417 LPOVERLAPPED overlapped )
419 FUNCTION: void GetAcceptExSockaddrs (
420 PVOID lpOutputBuffer,
421 DWORD dwReceiveDataLength,
422 DWORD dwLocalAddressLength,
423 DWORD dwRemoteAddressLength,
424 LPSOCKADDR* LocalSockaddr,
425 LPINT LocalSockaddrLength,
426 LPSOCKADDR* RemoteSockaddr,
427 LPINT RemoteSockaddrLength
430 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
432 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
434 ERROR: winsock-exception n string ;
436 : winsock-expected-error? ( n -- ? )
437 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
439 : (maybe-winsock-exception) ( n -- winsock-exception/f )
440 ! ! WSAStartup returns the error code 'n' directly
441 dup winsock-expected-error?
442 [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
444 : maybe-winsock-exception ( -- winsock-exception/f )
445 WSAGetLastError (maybe-winsock-exception) ;
447 : winsock-error ( -- )
448 maybe-winsock-exception [ throw ] when* ;
450 : (winsock-error) ( n -- * )
451 [ ] [ n>win32-error-string ] bi winsock-exception ;
453 : throw-winsock-error ( -- * )
454 WSAGetLastError (winsock-error) ;
456 : winsock-error=0/f ( n/f -- )
457 { 0 f } member? [ winsock-error ] when ;
459 : winsock-error!=0/f ( n/f -- )
460 { 0 f } member? [ winsock-error ] unless ;
462 ! WSAStartup and WSACleanup return the error code directly
463 : winsock-return-check ( n/f -- )
464 dup { 0 f } member? [
467 [ ] [ n>win32-error-string ] bi winsock-exception
470 : socket-error* ( n -- )
473 dup WSA_IO_PENDING = [
476 (maybe-winsock-exception) throw
480 : socket-error ( n -- )
481 SOCKET_ERROR = [ winsock-error ] when ;
483 : init-winsock ( -- )
484 0x0202 <wsadata> WSAStartup winsock-return-check ;
486 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
488 [ init-winsock ] "windows.winsock" add-startup-hook
489 [ shutdown-winsock ] "windows.winsock" add-shutdown-hook