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-2005, AdaCore --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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;
62 Namelen : C.int) return C.int;
63 pragma Import (Stdcall, Standard_Connect, "connect");
65 function Standard_Select
67 Readfds : Fd_Set_Access;
68 Writefds : Fd_Set_Access;
69 Exceptfds : Fd_Set_Access;
70 Timeout : Timeval_Access) return C.int;
71 pragma Import (Stdcall, Standard_Select, "select");
121 Error_Messages : constant array (Error_Type) of chars_ptr :=
123 New_String ("Interrupted system call"),
125 New_String ("Bad file number"),
127 New_String ("Permission denied"),
129 New_String ("Bad address"),
131 New_String ("Invalid argument"),
133 New_String ("Too many open files"),
135 New_String ("Operation would block"),
137 New_String ("Operation now in progress. This error is "
138 & "returned if any Windows Sockets API "
139 & "function is called while a blocking "
140 & "function is in progress"),
142 New_String ("Operation already in progress"),
144 New_String ("Socket operation on nonsocket"),
146 New_String ("Destination address required"),
148 New_String ("Message too long"),
150 New_String ("Protocol wrong type for socket"),
152 New_String ("Protocol not available"),
154 New_String ("Protocol not supported"),
156 New_String ("Socket type not supported"),
158 New_String ("Operation not supported on socket"),
160 New_String ("Protocol family not supported"),
162 New_String ("Address family not supported by protocol family"),
164 New_String ("Address already in use"),
166 New_String ("Cannot assign requested address"),
168 New_String ("Network is down. This error may be "
169 & "reported at any time if the Windows "
170 & "Sockets implementation detects an "
171 & "underlying failure"),
173 New_String ("Network is unreachable"),
175 New_String ("Network dropped connection on reset"),
177 New_String ("Software caused connection abort"),
179 New_String ("Connection reset by peer"),
181 New_String ("No buffer space available"),
183 New_String ("Socket is already connected"),
185 New_String ("Socket is not connected"),
187 New_String ("Cannot send after socket shutdown"),
189 New_String ("Too many references: cannot splice"),
191 New_String ("Connection timed out"),
193 New_String ("Connection refused"),
195 New_String ("Too many levels of symbolic links"),
197 New_String ("File name too long"),
199 New_String ("Host is down"),
201 New_String ("No route to host"),
203 New_String ("Returned by WSAStartup(), indicating that "
204 & "the network subsystem is unusable"),
206 New_String ("Returned by WSAStartup(), indicating that "
207 & "the Windows Sockets DLL cannot support "
208 & "this application"),
210 New_String ("Winsock not initialized. This message is "
211 & "returned by any function except WSAStartup(), "
212 & "indicating that a successful WSAStartup() has "
213 & "not yet been performed"),
215 New_String ("Disconnect"),
217 New_String ("Host not found. This message indicates "
218 & "that the key (name, address, and so on) was not found"),
220 New_String ("Nonauthoritative host not found. This error may "
221 & "suggest that the name service itself is not "
224 New_String ("Nonrecoverable error. This error may suggest that the "
225 & "name service itself is not functioning"),
227 New_String ("Valid name, no data record of requested type. "
228 & "This error indicates that the key (name, address, "
229 & "and so on) was not found."),
231 New_String ("Unknown system error"));
239 Name : System.Address;
240 Namelen : C.int) return C.int
245 Res := Standard_Connect (S, Name, Namelen);
248 if Socket_Errno = EWOULDBLOCK then
249 Set_Socket_Errno (EINPROGRESS);
262 Iov : System.Address;
263 Iovcnt : C.int) return C.int
268 Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
269 for Iovec'Address use Iov;
270 pragma Import (Ada, Iovec);
273 for J in Iovec'Range loop
276 Iovec (J).Base.all'Address,
277 C.int (Iovec (J).Length),
283 Count := Count + Res;
295 Readfds : Fd_Set_Access;
296 Writefds : Fd_Set_Access;
297 Exceptfds : Fd_Set_Access;
298 Timeout : Timeval_Access) return C.int
300 pragma Warnings (Off, Exceptfds);
302 RFS : constant Fd_Set_Access := Readfds;
303 WFS : constant Fd_Set_Access := Writefds;
304 WFSC : Fd_Set_Access := No_Fd_Set;
305 EFS : Fd_Set_Access := Exceptfds;
308 Last : aliased C.int;
311 -- Asynchronous connection failures are notified in the
312 -- exception fd set instead of the write fd set. To ensure
313 -- POSIX compatitibility, copy write fd set into exception fd
314 -- set. Once select() returns, check any socket present in the
315 -- exception fd set and peek at incoming out-of-band data. If
316 -- the test is not successful, and the socket is present in
317 -- the initial write fd set, then move the socket from the
318 -- exception fd set to the write fd set.
320 if WFS /= No_Fd_Set then
321 -- Add any socket present in write fd set into exception fd set
323 if EFS = No_Fd_Set then
324 EFS := New_Socket_Set (WFS);
327 WFSC := New_Socket_Set (WFS);
332 (WFSC, S'Unchecked_Access, Last'Unchecked_Access);
334 Insert_Socket_In_Set (EFS, S);
337 Free_Socket_Set (WFSC);
340 -- Keep a copy of write fd set
342 WFSC := New_Socket_Set (WFS);
345 Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
347 if EFS /= No_Fd_Set then
349 EFSC : constant Fd_Set_Access := New_Socket_Set (EFS);
350 Flag : constant C.int := MSG_PEEK + MSG_OOB;
353 Fromlen : aliased C.int;
359 (EFSC, S'Unchecked_Access, Last'Unchecked_Access);
361 -- No more sockets in EFSC
365 -- Check out-of-band data
368 (S, Buffer'Address, 1, Flag,
369 null, Fromlen'Unchecked_Access);
371 -- If the signal is not an out-of-band data, then it
372 -- is a connection failure notification.
375 Remove_Socket_From_Set (EFS, S);
377 -- If S is present in the initial write fd set,
378 -- move it from exception fd set back to write fd
379 -- set. Otherwise, ignore this event since the user
380 -- is not watching for it.
383 and then (Is_Socket_In_Set (WFSC, S) /= 0)
385 Insert_Socket_In_Set (WFS, S);
390 Free_Socket_Set (EFSC);
393 if Exceptfds = No_Fd_Set then
394 Free_Socket_Set (EFS);
398 -- Free any copy of write fd set
400 if WFSC /= No_Fd_Set then
401 Free_Socket_Set (WFSC);
412 (Cp : C.Strings.chars_ptr) return C.int
414 use type C.unsigned_long;
416 function Internal_Inet_Addr
417 (Cp : C.Strings.chars_ptr) return C.unsigned_long;
418 pragma Import (Stdcall, Internal_Inet_Addr, "inet_addr");
420 Res : C.unsigned_long;
422 Res := Internal_Inet_Addr (Cp);
424 if Res = C.unsigned_long'Last then
425 -- This value is returned in case of error
428 return C.int (Internal_Inet_Addr (Cp));
438 Iov : System.Address;
439 Iovcnt : C.int) return C.int
444 Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
445 for Iovec'Address use Iov;
446 pragma Import (Ada, Iovec);
449 for J in Iovec'Range loop
452 Iovec (J).Base.all'Address,
453 C.int (Iovec (J).Length),
459 Count := Count + Res;
469 procedure Finalize is
473 Initialized := False;
481 procedure Initialize (Process_Blocking_IO : Boolean := False) is
482 pragma Unreferenced (Process_Blocking_IO);
484 Return_Value : Interfaces.C.int;
487 if not Initialized then
488 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
489 pragma Assert (Interfaces.C."=" (Return_Value, 0));
498 procedure Set_Address
499 (Sin : Sockaddr_In_Access;
503 Sin.Sin_Addr := Address;
511 (Sin : Sockaddr_In_Access;
515 Sin.Sin_Family := C.unsigned_short (Family);
523 (Sin : Sockaddr_In_Access;
526 pragma Unreferenced (Sin);
527 pragma Unreferenced (Len);
538 (Sin : Sockaddr_In_Access;
539 Port : C.unsigned_short)
542 Sin.Sin_Port := Port;
545 --------------------------
546 -- Socket_Error_Message --
547 --------------------------
549 function Socket_Error_Message
550 (Errno : Integer) return C.Strings.chars_ptr
554 when EINTR => return Error_Messages (N_EINTR);
555 when EBADF => return Error_Messages (N_EBADF);
556 when EACCES => return Error_Messages (N_EACCES);
557 when EFAULT => return Error_Messages (N_EFAULT);
558 when EINVAL => return Error_Messages (N_EINVAL);
559 when EMFILE => return Error_Messages (N_EMFILE);
560 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
561 when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
562 when EALREADY => return Error_Messages (N_EALREADY);
563 when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
564 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
565 when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
566 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
567 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
568 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
569 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
570 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
571 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
572 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
573 when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
574 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
575 when ENETDOWN => return Error_Messages (N_ENETDOWN);
576 when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
577 when ENETRESET => return Error_Messages (N_ENETRESET);
578 when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
579 when ECONNRESET => return Error_Messages (N_ECONNRESET);
580 when ENOBUFS => return Error_Messages (N_ENOBUFS);
581 when EISCONN => return Error_Messages (N_EISCONN);
582 when ENOTCONN => return Error_Messages (N_ENOTCONN);
583 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
584 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
585 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
586 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
587 when ELOOP => return Error_Messages (N_ELOOP);
588 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
589 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
590 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
591 when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY);
592 when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED);
593 when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED);
594 when EDISCON => return Error_Messages (N_EDISCON);
595 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
596 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
597 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
598 when NO_DATA => return Error_Messages (N_NO_DATA);
599 when others => return Error_Messages (N_OTHERS);
601 end Socket_Error_Message;
603 end GNAT.Sockets.Thin;