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 literals math sequences windows.types
5 windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
6 classes.struct windows.com.syntax init ;
7 FROM: alien.c-types => short ;
12 : <wsadata> ( -- byte-array )
13 HEX: 190 <byte-array> ;
15 CONSTANT: SOCK_STREAM 1
16 CONSTANT: SOCK_DGRAM 2
19 CONSTANT: SOCK_SEQPACKET 5
21 CONSTANT: SO_DEBUG HEX: 1
22 CONSTANT: SO_ACCEPTCONN HEX: 2
23 CONSTANT: SO_REUSEADDR HEX: 4
24 CONSTANT: SO_KEEPALIVE HEX: 8
25 CONSTANT: SO_DONTROUTE HEX: 10
26 CONSTANT: SO_BROADCAST HEX: 20
27 CONSTANT: SO_USELOOPBACK HEX: 40
28 CONSTANT: SO_LINGER HEX: 80
29 CONSTANT: SO_OOBINLINE HEX: 100
30 : SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
32 CONSTANT: SO_SNDBUF HEX: 1001
33 CONSTANT: SO_RCVBUF HEX: 1002
34 CONSTANT: SO_SNDLOWAT HEX: 1003
35 CONSTANT: SO_RCVLOWAT HEX: 1004
36 CONSTANT: SO_SNDTIMEO HEX: 1005
37 CONSTANT: SO_RCVTIMEO HEX: 1006
38 CONSTANT: SO_ERROR HEX: 1007
39 CONSTANT: SO_TYPE HEX: 1008
41 CONSTANT: TCP_NODELAY HEX: 1
46 CONSTANT: AF_IMPLINK 3
53 CONSTANT: AF_DATAKIT 9
56 CONSTANT: AF_DECnet 12
59 CONSTANT: AF_HYLINK 15
60 CONSTANT: AF_APPLETALK 16
61 CONSTANT: AF_NETBIOS 17
72 CONSTANT: AI_PASSIVE 1
73 CONSTANT: AI_CANONNAME 2
74 CONSTANT: AI_NUMERICHOST 4
76 CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
78 CONSTANT: NI_NUMERICHOST 1
79 CONSTANT: NI_NUMERICSERV 2
81 CONSTANT: IPPROTO_TCP 6
82 CONSTANT: IPPROTO_UDP 17
83 CONSTANT: IPPROTO_RM 113
85 CONSTANT: WSA_FLAG_OVERLAPPED 1
86 ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
87 ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
88 CONSTANT: WSA_INVALID_EVENT f
89 CONSTANT: WSA_WAIT_FAILED -1
90 ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
91 ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
92 ALIAS: WSA_INFINITE INFINITE
93 ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
95 CONSTANT: INADDR_ANY 0
97 : INVALID_SOCKET ( -- n ) -1 <alien> ; inline
99 CONSTANT: SOCKET_ERROR -1
105 CONSTANT: SOL_SOCKET HEX: ffff
127 { addr-list void* } ;
140 { canonname c-string }
152 FUNCTION: int setsockopt ( SOCKET s, int level, int optname, c-string optval, int optlen ) ;
154 FUNCTION: ushort htons ( ushort n ) ;
155 FUNCTION: ushort ntohs ( ushort n ) ;
156 FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
157 FUNCTION: int listen ( void* socket, int backlog ) ;
158 FUNCTION: c-string inet_ntoa ( int in-addr ) ;
159 FUNCTION: int getaddrinfo ( c-string nodename,
164 FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
167 FUNCTION: hostent* gethostbyname ( c-string name ) ;
168 FUNCTION: int gethostname ( c-string name, int len ) ;
169 FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
170 FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
171 FUNCTION: int closesocket ( SOCKET s ) ;
172 FUNCTION: int shutdown ( SOCKET s, int how ) ;
173 FUNCTION: int send ( SOCKET s, c-string buf, int len, int flags ) ;
174 FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags ) ;
176 FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
177 FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
179 FUNCTION: protoent* getprotobyname ( c-string name ) ;
181 TYPEDEF: uint SERVICETYPE
182 TYPEDEF: OVERLAPPED WSAOVERLAPPED
183 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
185 TYPEDEF: void* LPCONDITIONPROC
186 TYPEDEF: HANDLE WSAEVENT
187 TYPEDEF: LPHANDLE LPWSAEVENT
188 TYPEDEF: sockaddr* LPSOCKADDR
192 { TokenBucketSize uint }
193 { PeakBandwidth uint }
195 { DelayVariation uint }
196 { ServiceType SERVICETYPE }
198 { MinimumPolicedSize uint } ;
199 TYPEDEF: FLOWSPEC* PFLOWSPEC
200 TYPEDEF: FLOWSPEC* LPFLOWSPEC
205 TYPEDEF: WSABUF* LPWSABUF
208 { SendingFlowspec FLOWSPEC }
209 { ReceivingFlowspec FLOWSPEC }
210 { ProviderSpecific WSABUF } ;
213 CONSTANT: MAX_PROTOCOL_CHAIN 7
215 STRUCT: WSAPROTOCOLCHAIN
217 { ChainEntries { DWORD 7 } } ;
218 ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ;
219 TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
221 CONSTANT: WSAPROTOCOL_LEN 255
223 STRUCT: WSAPROTOCOL_INFOW
224 { dwServiceFlags1 DWORD }
225 { dwServiceFlags2 DWORD }
226 { dwServiceFlags3 DWORD }
227 { dwServiceFlags4 DWORD }
228 { dwProviderFlags DWORD }
230 { dwCatalogEntryId DWORD }
231 { ProtocolChain WSAPROTOCOLCHAIN }
233 { iAddressFamily int }
238 { iProtocolMaxOffset int }
239 { iNetworkByteOrder int }
240 { iSecurityScheme int }
241 { dwMessageSize DWORD }
242 { dwProviderReserved DWORD }
243 { szProtocol { WCHAR 256 } } ;
244 ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ;
245 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW
246 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW
247 TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO
248 TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO
249 TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO
252 STRUCT: WSANAMESPACE_INFOW
253 { NSProviderId GUID }
254 { dwNameSpace DWORD }
257 { lpszIdentifier LPWSTR } ;
258 TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW
259 TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW
260 TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
261 TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
262 TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
264 CONSTANT: FD_MAX_EVENTS 10
266 STRUCT: WSANETWORKEVENTS
267 { lNetworkEvents long }
268 { iErrorCode { int FD_MAX_EVENTS } } ;
269 TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
270 TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
272 ! STRUCT: WSAOVERLAPPED
274 ! { InternalHigh DWORD }
276 ! { OffsetHigh DWORD }
277 ! { hEvent WSAEVENT }
278 ! { bytesTransferred DWORD } ;
279 ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
281 FUNCTION: SOCKET WSAAccept ( SOCKET s,
284 LPCONDITIONPROC lpfnCondition,
285 DWORD dwCallbackData ) ;
287 ! FUNCTION: INT WSAAddressToString ( LPSOCKADDR lpsaAddress, DWORD dwAddressLength, LPWSAPROTOCOL_INFO lpProtocolInfo, LPTSTR lpszAddressString, LPDWORD lpdwAddressStringLength ) ;
289 FUNCTION: int WSACleanup ( ) ;
290 FUNCTION: BOOL WSACloseEvent ( WSAEVENT hEvent ) ;
292 FUNCTION: int WSAConnect ( SOCKET s,
295 LPWSABUF lpCallerData,
296 LPWSABUF lpCalleeData,
299 FUNCTION: WSAEVENT WSACreateEvent ( ) ;
300 ! FUNCTION: INT WSAEnumNameSpaceProviders ( LPDWORD lpdwBufferLength, LPWSANAMESPACE_INFO lpnspBuffer ) ;
301 FUNCTION: int WSAEnumNetworkEvents ( SOCKET s,
302 WSAEVENT hEventObject,
303 LPWSANETWORKEVENTS lpNetworkEvents ) ;
304 ! FUNCTION: int WSAEnumProtocols ( LPINT lpiProtocols, LPWSAPROTOCOL_INFO lpProtocolBuffer, LPDWORD lpwdBufferLength ) ;
306 FUNCTION: int WSAEventSelect ( SOCKET s,
307 WSAEVENT hEventObject,
308 long lNetworkEvents ) ;
309 FUNCTION: int WSAGetLastError ( ) ;
310 FUNCTION: BOOL WSAGetOverlappedResult ( SOCKET s,
311 LPWSAOVERLAPPED lpOverlapped,
312 LPDWORD lpcbTransfer,
314 LPDWORD lpdwFlags ) ;
316 FUNCTION: int WSAIoctl ( SOCKET s,
317 DWORD dwIoControlCode,
322 LPDWORD lpcbBytesReturned,
324 void* lpCompletionRoutine ) ;
326 TYPEDEF: void* LPWSAOVERLAPPED_COMPLETION_ROUTINE
327 FUNCTION: int WSARecv ( SOCKET s,
330 LPDWORD lpNumberOfBytesRecvd,
332 LPWSAOVERLAPPED lpOverlapped,
333 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
335 FUNCTION: int WSARecvFrom ( SOCKET s,
338 LPDWORD lpNumberOfBytesRecvd,
342 LPWSAOVERLAPPED lpOverlapped,
343 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
345 FUNCTION: BOOL WSAResetEvent ( WSAEVENT hEvent ) ;
346 FUNCTION: int WSASend ( SOCKET s,
349 LPDWORD lpNumberOfBytesSent,
351 LPWSAOVERLAPPED lpOverlapped,
352 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
354 FUNCTION: int WSASendTo ( SOCKET s,
357 LPDWORD lpNumberOfBytesSent,
361 LPWSAOVERLAPPED lpOverlapped,
362 LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine ) ;
365 FUNCTION: int WSAStartup ( short version, void* out-data ) ;
369 FUNCTION: SOCKET WSASocketW ( int af,
372 LPWSAPROTOCOL_INFOW lpProtocolInfo,
375 ALIAS: WSASocket WSASocketW
377 FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
387 FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
389 FUNCTION: void GetAcceptExSockaddrs (
390 PVOID lpOutputBuffer,
391 DWORD dwReceiveDataLength,
392 DWORD dwLocalAddressLength,
393 DWORD dwRemoteAddressLength,
394 LPSOCKADDR* LocalSockaddr,
395 LPINT LocalSockaddrLength,
396 LPSOCKADDR* RemoteSockaddr,
397 LPINT RemoteSockaddrLength
400 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
402 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
404 ERROR: winsock-exception n string ;
406 : winsock-expected-error? ( n -- ? )
407 ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
409 : (maybe-winsock-exception) ( n -- winsock-exception/f )
410 ! #! WSAStartup returns the error code 'n' directly
411 dup winsock-expected-error?
412 [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
414 : maybe-winsock-exception ( -- winsock-exception/f )
415 WSAGetLastError (maybe-winsock-exception) ;
417 : winsock-error ( -- )
418 maybe-winsock-exception [ throw ] when* ;
420 : (throw-winsock-error) ( n -- * )
421 [ ] [ n>win32-error-string ] bi winsock-exception ;
423 : throw-winsock-error ( -- * )
424 WSAGetLastError (throw-winsock-error) ;
426 : winsock-error=0/f ( n/f -- )
427 { 0 f } member? [ throw-winsock-error ] when ;
429 : winsock-error!=0/f ( n/f -- )
430 { 0 f } member? [ throw-winsock-error ] unless ;
432 ! WSAStartup and WSACleanup return the error code directly
433 : winsock-return-check ( n/f -- )
434 dup { 0 f } member? [
437 [ ] [ n>win32-error-string ] bi winsock-exception
440 : socket-error* ( n -- )
443 dup WSA_IO_PENDING = [
446 (maybe-winsock-exception) throw
450 : socket-error ( n -- )
451 SOCKET_ERROR = [ winsock-error ] when ;
453 : init-winsock ( -- )
454 HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
456 : shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
458 [ init-winsock ] "windows.winsock" add-startup-hook
459 [ shutdown-winsock ] "windows.winsock" add-shutdown-hook