1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . T H I N --
9 -- Copyright (C) 2001-2004 Ada Core Technologies, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package provides a target dependent thin interface to the sockets
35 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
36 -- should not be directly with'ed by an applications program.
38 -- This version is for NT.
40 with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
41 with Interfaces.C.Strings; use Interfaces.C.Strings;
43 with System; use System;
45 package body GNAT.Sockets.Thin is
49 WSAData_Dummy : array (1 .. 512) of C.int;
51 WS_Version : constant := 16#0101#;
52 Initialized : Boolean := False;
54 SYSNOTREADY : constant := 10091;
55 VERNOTSUPPORTED : constant := 10092;
56 NOTINITIALISED : constant := 10093;
57 EDISCON : constant := 10101;
59 function Standard_Connect
61 Name : System.Address;
64 pragma Import (Stdcall, Standard_Connect, "connect");
66 function Standard_Select
68 Readfds : Fd_Set_Access;
69 Writefds : Fd_Set_Access;
70 Exceptfds : Fd_Set_Access;
71 Timeout : Timeval_Access)
73 pragma Import (Stdcall, Standard_Select, "select");
123 Error_Messages : constant array (Error_Type) of chars_ptr :=
125 New_String ("Interrupted system call"),
127 New_String ("Bad file number"),
129 New_String ("Permission denied"),
131 New_String ("Bad address"),
133 New_String ("Invalid argument"),
135 New_String ("Too many open files"),
137 New_String ("Operation would block"),
139 New_String ("Operation now in progress. This error is "
140 & "returned if any Windows Sockets API "
141 & "function is called while a blocking "
142 & "function is in progress"),
144 New_String ("Operation already in progress"),
146 New_String ("Socket operation on nonsocket"),
148 New_String ("Destination address required"),
150 New_String ("Message too long"),
152 New_String ("Protocol wrong type for socket"),
154 New_String ("Protocol not available"),
156 New_String ("Protocol not supported"),
158 New_String ("Socket type not supported"),
160 New_String ("Operation not supported on socket"),
162 New_String ("Protocol family not supported"),
164 New_String ("Address family not supported by protocol family"),
166 New_String ("Address already in use"),
168 New_String ("Cannot assign requested address"),
170 New_String ("Network is down. This error may be "
171 & "reported at any time if the Windows "
172 & "Sockets implementation detects an "
173 & "underlying failure"),
175 New_String ("Network is unreachable"),
177 New_String ("Network dropped connection on reset"),
179 New_String ("Software caused connection abort"),
181 New_String ("Connection reset by peer"),
183 New_String ("No buffer space available"),
185 New_String ("Socket is already connected"),
187 New_String ("Socket is not connected"),
189 New_String ("Cannot send after socket shutdown"),
191 New_String ("Too many references: cannot splice"),
193 New_String ("Connection timed out"),
195 New_String ("Connection refused"),
197 New_String ("Too many levels of symbolic links"),
199 New_String ("File name too long"),
201 New_String ("Host is down"),
203 New_String ("No route to host"),
205 New_String ("Returned by WSAStartup(), indicating that "
206 & "the network subsystem is unusable"),
208 New_String ("Returned by WSAStartup(), indicating that "
209 & "the Windows Sockets DLL cannot support "
210 & "this application"),
212 New_String ("Winsock not initialized. This message is "
213 & "returned by any function except WSAStartup(), "
214 & "indicating that a successful WSAStartup() has "
215 & "not yet been performed"),
217 New_String ("Disconnect"),
219 New_String ("Host not found. This message indicates "
220 & "that the key (name, address, and so on) was not found"),
222 New_String ("Nonauthoritative host not found. This error may "
223 & "suggest that the name service itself is not "
226 New_String ("Nonrecoverable error. This error may suggest that the "
227 & "name service itself is not functioning"),
229 New_String ("Valid name, no data record of requested type. "
230 & "This error indicates that the key (name, address, "
231 & "and so on) was not found."),
233 New_String ("Unknown system error"));
241 Name : System.Address;
248 Res := Standard_Connect (S, Name, Namelen);
251 if Socket_Errno = EWOULDBLOCK then
252 Set_Socket_Errno (EINPROGRESS);
265 Iov : System.Address;
272 Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
273 for Iovec'Address use Iov;
274 pragma Import (Ada, Iovec);
277 for J in Iovec'Range loop
280 Iovec (J).Base.all'Address,
281 C.int (Iovec (J).Length),
287 Count := Count + Res;
299 Readfds : Fd_Set_Access;
300 Writefds : Fd_Set_Access;
301 Exceptfds : Fd_Set_Access;
302 Timeout : Timeval_Access)
305 pragma Warnings (Off, Exceptfds);
307 RFS : constant Fd_Set_Access := Readfds;
308 WFS : constant Fd_Set_Access := Writefds;
309 WFSC : Fd_Set_Access := No_Fd_Set;
310 EFS : Fd_Set_Access := Exceptfds;
313 Last : aliased C.int;
316 -- Asynchronous connection failures are notified in the
317 -- exception fd set instead of the write fd set. To ensure
318 -- POSIX compatitibility, copy write fd set into exception fd
319 -- set. Once select() returns, check any socket present in the
320 -- exception fd set and peek at incoming out-of-band data. If
321 -- the test is not successful, and the socket is present in
322 -- the initial write fd set, then move the socket from the
323 -- exception fd set to the write fd set.
325 if WFS /= No_Fd_Set then
326 -- Add any socket present in write fd set into exception fd set
328 if EFS = No_Fd_Set then
329 EFS := New_Socket_Set (WFS);
332 WFSC := New_Socket_Set (WFS);
337 (WFSC, S'Unchecked_Access, Last'Unchecked_Access);
339 Insert_Socket_In_Set (EFS, S);
342 Free_Socket_Set (WFSC);
345 -- Keep a copy of write fd set
347 WFSC := New_Socket_Set (WFS);
350 Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
352 if EFS /= No_Fd_Set then
354 EFSC : constant Fd_Set_Access := New_Socket_Set (EFS);
355 Flag : constant C.int := MSG_PEEK + MSG_OOB;
358 Fromlen : aliased C.int;
364 (EFSC, S'Unchecked_Access, Last'Unchecked_Access);
366 -- No more sockets in EFSC
370 -- Check out-of-band data
373 (S, Buffer'Address, 1, Flag,
374 null, Fromlen'Unchecked_Access);
376 -- If the signal is not an out-of-band data, then it
377 -- is a connection failure notification.
380 Remove_Socket_From_Set (EFS, S);
382 -- If S is present in the initial write fd set,
383 -- move it from exception fd set back to write fd
384 -- set. Otherwise, ignore this event since the user
385 -- is not watching for it.
388 and then (Is_Socket_In_Set (WFSC, S) /= 0)
390 Insert_Socket_In_Set (WFS, S);
395 Free_Socket_Set (EFSC);
398 if Exceptfds = No_Fd_Set then
399 Free_Socket_Set (EFS);
403 -- Free any copy of write fd set
405 if WFSC /= No_Fd_Set then
406 Free_Socket_Set (WFSC);
418 Iov : System.Address;
425 Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
426 for Iovec'Address use Iov;
427 pragma Import (Ada, Iovec);
430 for J in Iovec'Range loop
433 Iovec (J).Base.all'Address,
434 C.int (Iovec (J).Length),
440 Count := Count + Res;
450 procedure Finalize is
454 Initialized := False;
462 procedure Initialize (Process_Blocking_IO : Boolean := False) is
463 pragma Unreferenced (Process_Blocking_IO);
465 Return_Value : Interfaces.C.int;
468 if not Initialized then
469 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
470 pragma Assert (Interfaces.C."=" (Return_Value, 0));
479 procedure Set_Address
480 (Sin : Sockaddr_In_Access;
484 Sin.Sin_Addr := Address;
492 (Sin : Sockaddr_In_Access;
496 Sin.Sin_Family := C.unsigned_short (Family);
504 (Sin : Sockaddr_In_Access;
507 pragma Unreferenced (Sin);
508 pragma Unreferenced (Len);
519 (Sin : Sockaddr_In_Access;
520 Port : C.unsigned_short)
523 Sin.Sin_Port := Port;
526 --------------------------
527 -- Socket_Error_Message --
528 --------------------------
530 function Socket_Error_Message
532 return C.Strings.chars_ptr
534 use GNAT.Sockets.Constants;
538 when EINTR => return Error_Messages (N_EINTR);
539 when EBADF => return Error_Messages (N_EBADF);
540 when EACCES => return Error_Messages (N_EACCES);
541 when EFAULT => return Error_Messages (N_EFAULT);
542 when EINVAL => return Error_Messages (N_EINVAL);
543 when EMFILE => return Error_Messages (N_EMFILE);
544 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
545 when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
546 when EALREADY => return Error_Messages (N_EALREADY);
547 when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
548 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
549 when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
550 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
551 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
552 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
553 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
554 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
555 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
556 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
557 when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
558 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
559 when ENETDOWN => return Error_Messages (N_ENETDOWN);
560 when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
561 when ENETRESET => return Error_Messages (N_ENETRESET);
562 when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
563 when ECONNRESET => return Error_Messages (N_ECONNRESET);
564 when ENOBUFS => return Error_Messages (N_ENOBUFS);
565 when EISCONN => return Error_Messages (N_EISCONN);
566 when ENOTCONN => return Error_Messages (N_ENOTCONN);
567 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
568 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
569 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
570 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
571 when ELOOP => return Error_Messages (N_ELOOP);
572 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
573 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
574 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
575 when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY);
576 when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED);
577 when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED);
578 when EDISCON => return Error_Messages (N_EDISCON);
579 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
580 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
581 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
582 when NO_DATA => return Error_Messages (N_NO_DATA);
583 when others => return Error_Messages (N_OTHERS);
585 end Socket_Error_Message;
587 end GNAT.Sockets.Thin;