1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2014, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Streams; use Ada.Streams;
33 with Ada.Exceptions; use Ada.Exceptions;
34 with Ada.Finalization;
35 with Ada.Unchecked_Conversion;
37 with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
38 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
40 with GNAT.Sockets.Linker_Options;
41 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
42 -- Need to include pragma Linker_Options which is platform dependent
44 with System; use System;
45 with System.Communication; use System.Communication;
46 with System.CRTL; use System.CRTL;
47 with System.Task_Lock;
49 package body GNAT.Sockets is
51 package C renames Interfaces.C;
55 ENOERROR : constant := 0;
57 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
58 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
59 -- The network database functions gethostbyname, gethostbyaddr,
60 -- getservbyname and getservbyport can either be guaranteed task safe by
61 -- the operating system, or else return data through a user-provided buffer
62 -- to ensure concurrent uses do not interfere.
64 -- Correspondence tables
66 Levels : constant array (Level_Type) of C.int :=
67 (Socket_Level => SOSC.SOL_SOCKET,
68 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
69 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
70 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
72 Modes : constant array (Mode_Type) of C.int :=
73 (Socket_Stream => SOSC.SOCK_STREAM,
74 Socket_Datagram => SOSC.SOCK_DGRAM);
76 Shutmodes : constant array (Shutmode_Type) of C.int :=
77 (Shut_Read => SOSC.SHUT_RD,
78 Shut_Write => SOSC.SHUT_WR,
79 Shut_Read_Write => SOSC.SHUT_RDWR);
81 Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T :=
82 (Non_Blocking_IO => SOSC.FIONBIO,
83 N_Bytes_To_Read => SOSC.FIONREAD);
85 Options : constant array (Option_Name) of C.int :=
86 (Keep_Alive => SOSC.SO_KEEPALIVE,
87 Reuse_Address => SOSC.SO_REUSEADDR,
88 Broadcast => SOSC.SO_BROADCAST,
89 Send_Buffer => SOSC.SO_SNDBUF,
90 Receive_Buffer => SOSC.SO_RCVBUF,
91 Linger => SOSC.SO_LINGER,
92 Error => SOSC.SO_ERROR,
93 No_Delay => SOSC.TCP_NODELAY,
94 Add_Membership => SOSC.IP_ADD_MEMBERSHIP,
95 Drop_Membership => SOSC.IP_DROP_MEMBERSHIP,
96 Multicast_If => SOSC.IP_MULTICAST_IF,
97 Multicast_TTL => SOSC.IP_MULTICAST_TTL,
98 Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
99 Receive_Packet_Info => SOSC.IP_PKTINFO,
100 Send_Timeout => SOSC.SO_SNDTIMEO,
101 Receive_Timeout => SOSC.SO_RCVTIMEO);
102 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
103 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
105 Flags : constant array (0 .. 3) of C.int :=
106 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
107 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
108 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
109 3 => SOSC.MSG_EOR); -- Send_End_Of_Record
111 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
112 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
114 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
115 -- Use to print in hexadecimal format
117 -----------------------
118 -- Local subprograms --
119 -----------------------
121 function Resolve_Error
122 (Error_Value : Integer;
123 From_Errno : Boolean := True) return Error_Type;
124 -- Associate an enumeration value (error_type) to an error value (errno).
125 -- From_Errno prevents from mixing h_errno with errno.
127 function To_Name (N : String) return Name_Type;
128 function To_String (HN : Name_Type) return String;
129 -- Conversion functions
131 function To_Int (F : Request_Flag_Type) return C.int;
132 -- Return the int value corresponding to the specified flags combination
134 function Set_Forced_Flags (F : C.int) return C.int;
135 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
137 function Short_To_Network
138 (S : C.unsigned_short) return C.unsigned_short;
139 pragma Inline (Short_To_Network);
140 -- Convert a port number into a network port number
142 function Network_To_Short
143 (S : C.unsigned_short) return C.unsigned_short
144 renames Short_To_Network;
145 -- Symmetric operation
148 (Val : Inet_Addr_VN_Type;
149 Hex : Boolean := False) return String;
150 -- Output an array of inet address components in hex or decimal mode
152 function Is_IP_Address (Name : String) return Boolean;
153 -- Return true when Name is an IP address in standard dot notation
155 procedure Netdb_Lock;
156 pragma Inline (Netdb_Lock);
157 procedure Netdb_Unlock;
158 pragma Inline (Netdb_Unlock);
159 -- Lock/unlock operation used to protect netdb access for platforms that
160 -- require such protection.
162 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
163 procedure To_Inet_Addr
165 Result : out Inet_Addr_Type);
166 -- Conversion functions
168 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
169 -- Conversion function
171 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
172 -- Conversion function
174 function Value (S : System.Address) return String;
175 -- Same as Interfaces.C.Strings.Value but taking a System.Address
177 function To_Timeval (Val : Timeval_Duration) return Timeval;
178 -- Separate Val in seconds and microseconds
180 function To_Duration (Val : Timeval) return Timeval_Duration;
181 -- Reconstruct a Duration value from a Timeval record (seconds and
184 procedure Raise_Socket_Error (Error : Integer);
185 -- Raise Socket_Error with an exception message describing the error code
188 procedure Raise_Host_Error (H_Error : Integer);
189 -- Raise Host_Error exception with message describing error code (note
190 -- hstrerror seems to be obsolete) from h_errno.
192 procedure Narrow (Item : in out Socket_Set_Type);
193 -- Update Last as it may be greater than the real last socket
195 procedure Check_For_Fd_Set (Fd : Socket_Type);
196 pragma Inline (Check_For_Fd_Set);
197 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
198 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
200 function Connect_Socket
201 (Socket : Socket_Type;
202 Server : Sock_Addr_Type) return C.int;
203 pragma Inline (Connect_Socket);
204 -- Underlying implementation for the Connect_Socket procedures
206 -- Types needed for Datagram_Socket_Stream_Type
208 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
209 Socket : Socket_Type;
211 From : Sock_Addr_Type;
214 type Datagram_Socket_Stream_Access is
215 access all Datagram_Socket_Stream_Type;
218 (Stream : in out Datagram_Socket_Stream_Type;
219 Item : out Ada.Streams.Stream_Element_Array;
220 Last : out Ada.Streams.Stream_Element_Offset);
223 (Stream : in out Datagram_Socket_Stream_Type;
224 Item : Ada.Streams.Stream_Element_Array);
226 -- Types needed for Stream_Socket_Stream_Type
228 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
229 Socket : Socket_Type;
232 type Stream_Socket_Stream_Access is
233 access all Stream_Socket_Stream_Type;
236 (Stream : in out Stream_Socket_Stream_Type;
237 Item : out Ada.Streams.Stream_Element_Array;
238 Last : out Ada.Streams.Stream_Element_Offset);
241 (Stream : in out Stream_Socket_Stream_Type;
242 Item : Ada.Streams.Stream_Element_Array);
244 procedure Wait_On_Socket
245 (Socket : Socket_Type;
247 Timeout : Selector_Duration;
248 Selector : access Selector_Type := null;
249 Status : out Selector_Status);
250 -- Common code for variants of socket operations supporting a timeout:
251 -- block in Check_Selector on Socket for at most the indicated timeout.
252 -- If For_Read is True, Socket is added to the read set for this call, else
253 -- it is added to the write set. If no selector is provided, a local one is
254 -- created for this call and destroyed prior to returning.
256 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
258 -- This type is used to generate automatic calls to Initialize and Finalize
259 -- during the elaboration and finalization of this package. A single object
260 -- of this type must exist at library level.
262 function Err_Code_Image (E : Integer) return String;
263 -- Return the value of E surrounded with brackets
265 procedure Initialize (X : in out Sockets_Library_Controller);
266 procedure Finalize (X : in out Sockets_Library_Controller);
268 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
269 -- If S is the empty set (detected by Last = No_Socket), make sure its
270 -- fd_set component is actually cleared. Note that the case where it is
271 -- not can occur for an uninitialized Socket_Set_Type object.
273 function Is_Open (S : Selector_Type) return Boolean;
274 -- Return True for an "open" Selector_Type object, i.e. one for which
275 -- Create_Selector has been called and Close_Selector has not been called,
276 -- or the null selector.
282 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
291 procedure Abort_Selector (Selector : Selector_Type) is
295 if not Is_Open (Selector) then
296 raise Program_Error with "closed selector";
298 elsif Selector.Is_Null then
299 raise Program_Error with "null selector";
303 -- Send one byte to unblock select system call
305 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
307 if Res = Failure then
308 Raise_Socket_Error (Socket_Errno);
316 procedure Accept_Socket
317 (Server : Socket_Type;
318 Socket : out Socket_Type;
319 Address : out Sock_Addr_Type)
322 Sin : aliased Sockaddr_In;
323 Len : aliased C.int := Sin'Size / 8;
326 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
328 if Res = Failure then
329 Raise_Socket_Error (Socket_Errno);
332 Socket := Socket_Type (Res);
334 To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
335 Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
342 procedure Accept_Socket
343 (Server : Socket_Type;
344 Socket : out Socket_Type;
345 Address : out Sock_Addr_Type;
346 Timeout : Selector_Duration;
347 Selector : access Selector_Type := null;
348 Status : out Selector_Status)
351 if Selector /= null and then not Is_Open (Selector.all) then
352 raise Program_Error with "closed selector";
355 -- Wait for socket to become available for reading
361 Selector => Selector,
364 -- Accept connection if available
366 if Status = Completed then
367 Accept_Socket (Server, Socket, Address);
378 (E : Host_Entry_Type;
379 N : Positive := 1) return Inet_Addr_Type
382 return E.Addresses (N);
385 ----------------------
386 -- Addresses_Length --
387 ----------------------
389 function Addresses_Length (E : Host_Entry_Type) return Natural is
391 return E.Addresses_Length;
392 end Addresses_Length;
399 (E : Host_Entry_Type;
400 N : Positive := 1) return String
403 return To_String (E.Aliases (N));
411 (S : Service_Entry_Type;
412 N : Positive := 1) return String
415 return To_String (S.Aliases (N));
422 function Aliases_Length (E : Host_Entry_Type) return Natural is
424 return E.Aliases_Length;
431 function Aliases_Length (S : Service_Entry_Type) return Natural is
433 return S.Aliases_Length;
440 procedure Bind_Socket
441 (Socket : Socket_Type;
442 Address : Sock_Addr_Type)
445 Sin : aliased Sockaddr_In;
446 Len : constant C.int := Sin'Size / 8;
447 -- This assumes that Address.Family = Family_Inet???
450 if Address.Family = Family_Inet6 then
451 raise Socket_Error with "IPv6 not supported";
454 Set_Family (Sin.Sin_Family, Address.Family);
455 Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
457 (Sin'Unchecked_Access,
458 Short_To_Network (C.unsigned_short (Address.Port)));
460 Res := C_Bind (C.int (Socket), Sin'Address, Len);
462 if Res = Failure then
463 Raise_Socket_Error (Socket_Errno);
467 ----------------------
468 -- Check_For_Fd_Set --
469 ----------------------
471 procedure Check_For_Fd_Set (Fd : Socket_Type) is
475 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
476 -- no check required. Warnings suppressed because condition
477 -- is known at compile time.
479 if Target_OS = Windows then
483 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
484 -- that Fd is within range (otherwise behaviour is undefined).
486 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
487 raise Constraint_Error
488 with "invalid value for socket set: " & Image (Fd);
490 end Check_For_Fd_Set;
496 procedure Check_Selector
497 (Selector : Selector_Type;
498 R_Socket_Set : in out Socket_Set_Type;
499 W_Socket_Set : in out Socket_Set_Type;
500 Status : out Selector_Status;
501 Timeout : Selector_Duration := Forever)
503 E_Socket_Set : Socket_Set_Type;
506 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
509 procedure Check_Selector
510 (Selector : Selector_Type;
511 R_Socket_Set : in out Socket_Set_Type;
512 W_Socket_Set : in out Socket_Set_Type;
513 E_Socket_Set : in out Socket_Set_Type;
514 Status : out Selector_Status;
515 Timeout : Selector_Duration := Forever)
519 RSig : Socket_Type := No_Socket;
520 TVal : aliased Timeval;
521 TPtr : Timeval_Access;
524 if not Is_Open (Selector) then
525 raise Program_Error with "closed selector";
530 -- No timeout or Forever is indicated by a null timeval pointer
532 if Timeout = Forever then
535 TVal := To_Timeval (Timeout);
536 TPtr := TVal'Unchecked_Access;
539 -- Add read signalling socket, if present
541 if not Selector.Is_Null then
542 RSig := Selector.R_Sig_Socket;
543 Set (R_Socket_Set, RSig);
546 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
547 C.int (W_Socket_Set.Last)),
548 C.int (E_Socket_Set.Last));
550 -- Zero out fd_set for empty Socket_Set_Type objects
552 Normalize_Empty_Socket_Set (R_Socket_Set);
553 Normalize_Empty_Socket_Set (W_Socket_Set);
554 Normalize_Empty_Socket_Set (E_Socket_Set);
559 R_Socket_Set.Set'Access,
560 W_Socket_Set.Set'Access,
561 E_Socket_Set.Set'Access,
564 if Res = Failure then
565 Raise_Socket_Error (Socket_Errno);
568 -- If Select was resumed because of read signalling socket, read this
569 -- data and remove socket from set.
571 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
572 Clear (R_Socket_Set, RSig);
574 Res := Signalling_Fds.Read (C.int (RSig));
576 if Res = Failure then
577 Raise_Socket_Error (Socket_Errno);
586 -- Update socket sets in regard to their new contents
588 Narrow (R_Socket_Set);
589 Narrow (W_Socket_Set);
590 Narrow (E_Socket_Set);
598 (Item : in out Socket_Set_Type;
599 Socket : Socket_Type)
601 Last : aliased C.int := C.int (Item.Last);
604 Check_For_Fd_Set (Socket);
606 if Item.Last /= No_Socket then
607 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
608 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
609 Item.Last := Socket_Type (Last);
617 procedure Close_Selector (Selector : in out Selector_Type) is
619 -- Nothing to do if selector already in closed state
621 if Selector.Is_Null or else not Is_Open (Selector) then
625 -- Close the signalling file descriptors used internally for the
626 -- implementation of Abort_Selector.
628 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
629 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
631 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
632 -- (erroneous) subsequent attempt to use this selector properly fails.
634 Selector.R_Sig_Socket := No_Socket;
635 Selector.W_Sig_Socket := No_Socket;
642 procedure Close_Socket (Socket : Socket_Type) is
646 Res := C_Close (C.int (Socket));
648 if Res = Failure then
649 Raise_Socket_Error (Socket_Errno);
657 function Connect_Socket
658 (Socket : Socket_Type;
659 Server : Sock_Addr_Type) return C.int
661 Sin : aliased Sockaddr_In;
662 Len : constant C.int := Sin'Size / 8;
665 if Server.Family = Family_Inet6 then
666 raise Socket_Error with "IPv6 not supported";
669 Set_Family (Sin.Sin_Family, Server.Family);
670 Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
672 (Sin'Unchecked_Access,
673 Short_To_Network (C.unsigned_short (Server.Port)));
675 return C_Connect (C.int (Socket), Sin'Address, Len);
678 procedure Connect_Socket
679 (Socket : Socket_Type;
680 Server : Sock_Addr_Type)
683 if Connect_Socket (Socket, Server) = Failure then
684 Raise_Socket_Error (Socket_Errno);
688 procedure Connect_Socket
689 (Socket : Socket_Type;
690 Server : Sock_Addr_Type;
691 Timeout : Selector_Duration;
692 Selector : access Selector_Type := null;
693 Status : out Selector_Status)
696 -- Used to set Socket to non-blocking I/O
698 Conn_Err : aliased Integer;
699 -- Error status of the socket after completion of select(2)
702 Conn_Err_Size : aliased C.int := Conn_Err'Size / 8;
703 -- For getsockopt(2) call
706 if Selector /= null and then not Is_Open (Selector.all) then
707 raise Program_Error with "closed selector";
710 -- Set the socket to non-blocking I/O
712 Req := (Name => Non_Blocking_IO, Enabled => True);
713 Control_Socket (Socket, Request => Req);
715 -- Start operation (non-blocking), will return Failure with errno set
718 Res := Connect_Socket (Socket, Server);
719 if Res = Failure then
720 Conn_Err := Socket_Errno;
721 if Conn_Err /= SOSC.EINPROGRESS then
722 Raise_Socket_Error (Conn_Err);
726 -- Wait for socket to become available for writing (unless the Timeout
727 -- is zero, in which case we consider that it has already expired, and
728 -- we do not need to wait at all).
730 if Timeout = 0.0 then
738 Selector => Selector,
742 -- Check error condition (the asynchronous connect may have terminated
743 -- with an error, e.g. ECONNREFUSED) if select(2) completed.
745 if Status = Completed then
747 (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR,
748 Conn_Err'Address, Conn_Err_Size'Access);
751 Conn_Err := Socket_Errno;
758 -- Reset the socket to blocking I/O
760 Req := (Name => Non_Blocking_IO, Enabled => False);
761 Control_Socket (Socket, Request => Req);
763 -- Report error condition if any
765 if Conn_Err /= 0 then
766 Raise_Socket_Error (Conn_Err);
774 procedure Control_Socket
775 (Socket : Socket_Type;
776 Request : in out Request_Type)
783 when Non_Blocking_IO =>
784 Arg := C.int (Boolean'Pos (Request.Enabled));
786 when N_Bytes_To_Read =>
791 (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
793 if Res = Failure then
794 Raise_Socket_Error (Socket_Errno);
798 when Non_Blocking_IO =>
801 when N_Bytes_To_Read =>
802 Request.Size := Natural (Arg);
811 (Source : Socket_Set_Type;
812 Target : out Socket_Set_Type)
818 ---------------------
819 -- Create_Selector --
820 ---------------------
822 procedure Create_Selector (Selector : out Selector_Type) is
823 Two_Fds : aliased Fd_Pair;
827 if Is_Open (Selector) then
828 -- Raise exception to prevent socket descriptor leak
830 raise Program_Error with "selector already open";
833 -- We open two signalling file descriptors. One of them is used to send
834 -- data to the other, which is included in a C_Select socket set. The
835 -- communication is used to force a call to C_Select to complete, and
836 -- the waiting task to resume its execution.
838 Res := Signalling_Fds.Create (Two_Fds'Access);
840 if Res = Failure then
841 Raise_Socket_Error (Socket_Errno);
844 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
845 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
852 procedure Create_Socket
853 (Socket : out Socket_Type;
854 Family : Family_Type := Family_Inet;
855 Mode : Mode_Type := Socket_Stream)
860 Res := C_Socket (Families (Family), Modes (Mode), 0);
862 if Res = Failure then
863 Raise_Socket_Error (Socket_Errno);
866 Socket := Socket_Type (Res);
873 procedure Empty (Item : out Socket_Set_Type) is
875 Reset_Socket_Set (Item.Set'Access);
876 Item.Last := No_Socket;
883 function Err_Code_Image (E : Integer) return String is
884 Msg : String := E'Img & "] ";
886 Msg (Msg'First) := '[';
894 procedure Finalize (X : in out Sockets_Library_Controller) is
895 pragma Unreferenced (X);
898 -- Finalization operation for the GNAT.Sockets package
907 procedure Finalize is
909 -- This is a dummy placeholder for an obsolete API.
910 -- The real finalization actions are in Initialize primitive operation
911 -- of Sockets_Library_Controller.
921 (Item : in out Socket_Set_Type;
922 Socket : out Socket_Type)
925 L : aliased C.int := C.int (Item.Last);
928 if Item.Last /= No_Socket then
930 (Item.Set'Access, Last => L'Access, Socket => S'Access);
931 Item.Last := Socket_Type (L);
932 Socket := Socket_Type (S);
943 (Stream : not null Stream_Access) return Sock_Addr_Type
946 if Stream.all in Datagram_Socket_Stream_Type then
947 return Datagram_Socket_Stream_Type (Stream.all).From;
949 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
953 -------------------------
954 -- Get_Host_By_Address --
955 -------------------------
957 function Get_Host_By_Address
958 (Address : Inet_Addr_Type;
959 Family : Family_Type := Family_Inet) return Host_Entry_Type
961 pragma Unreferenced (Family);
963 HA : aliased In_Addr := To_In_Addr (Address);
964 Buflen : constant C.int := Netdb_Buffer_Size;
965 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
966 Res : aliased Hostent;
972 if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET,
973 Res'Access, Buf'Address, Buflen, Err'Access) /= 0
976 Raise_Host_Error (Integer (Err));
980 return H : constant Host_Entry_Type :=
981 To_Host_Entry (Res'Unchecked_Access)
990 end Get_Host_By_Address;
992 ----------------------
993 -- Get_Host_By_Name --
994 ----------------------
996 function Get_Host_By_Name (Name : String) return Host_Entry_Type is
998 -- Detect IP address name and redirect to Inet_Addr
1000 if Is_IP_Address (Name) then
1001 return Get_Host_By_Address (Inet_Addr (Name));
1005 HN : constant C.char_array := C.To_C (Name);
1006 Buflen : constant C.int := Netdb_Buffer_Size;
1007 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1008 Res : aliased Hostent;
1009 Err : aliased C.int;
1015 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1018 Raise_Host_Error (Integer (Err));
1021 return H : constant Host_Entry_Type :=
1022 To_Host_Entry (Res'Unchecked_Access)
1027 end Get_Host_By_Name;
1033 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
1034 Sin : aliased Sockaddr_In;
1035 Len : aliased C.int := Sin'Size / 8;
1036 Res : Sock_Addr_Type (Family_Inet);
1039 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
1040 Raise_Socket_Error (Socket_Errno);
1043 To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
1044 Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1049 -------------------------
1050 -- Get_Service_By_Name --
1051 -------------------------
1053 function Get_Service_By_Name
1055 Protocol : String) return Service_Entry_Type
1057 SN : constant C.char_array := C.To_C (Name);
1058 SP : constant C.char_array := C.To_C (Protocol);
1059 Buflen : constant C.int := Netdb_Buffer_Size;
1060 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1061 Res : aliased Servent;
1066 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1068 raise Service_Error with "Service not found";
1071 -- Translate from the C format to the API format
1073 return S : constant Service_Entry_Type :=
1074 To_Service_Entry (Res'Unchecked_Access)
1078 end Get_Service_By_Name;
1080 -------------------------
1081 -- Get_Service_By_Port --
1082 -------------------------
1084 function Get_Service_By_Port
1086 Protocol : String) return Service_Entry_Type
1088 SP : constant C.char_array := C.To_C (Protocol);
1089 Buflen : constant C.int := Netdb_Buffer_Size;
1090 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1091 Res : aliased Servent;
1097 (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1098 Res'Access, Buf'Address, Buflen) /= 0
1101 raise Service_Error with "Service not found";
1104 -- Translate from the C format to the API format
1106 return S : constant Service_Entry_Type :=
1107 To_Service_Entry (Res'Unchecked_Access)
1111 end Get_Service_By_Port;
1113 ---------------------
1114 -- Get_Socket_Name --
1115 ---------------------
1117 function Get_Socket_Name
1118 (Socket : Socket_Type) return Sock_Addr_Type
1120 Sin : aliased Sockaddr_In;
1121 Len : aliased C.int := Sin'Size / 8;
1123 Addr : Sock_Addr_Type := No_Sock_Addr;
1126 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1128 if Res /= Failure then
1129 To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
1130 Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1134 end Get_Socket_Name;
1136 -----------------------
1137 -- Get_Socket_Option --
1138 -----------------------
1140 function Get_Socket_Option
1141 (Socket : Socket_Type;
1142 Level : Level_Type := Socket_Level;
1143 Name : Option_Name) return Option_Type
1146 use type C.unsigned_char;
1148 V8 : aliased Two_Ints;
1150 V1 : aliased C.unsigned_char;
1151 VT : aliased Timeval;
1152 Len : aliased C.int;
1153 Add : System.Address;
1155 Opt : Option_Type (Name);
1159 when Multicast_Loop |
1161 Receive_Packet_Info =>
1179 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1180 -- struct timeval, but on Windows it is a milliseconds count in
1183 if Target_OS = Windows then
1207 if Res = Failure then
1208 Raise_Socket_Error (Socket_Errno);
1216 Opt.Enabled := (V4 /= 0);
1219 Opt.Enabled := (V8 (V8'First) /= 0);
1220 Opt.Seconds := Natural (V8 (V8'Last));
1224 Opt.Size := Natural (V4);
1227 Opt.Error := Resolve_Error (Integer (V4));
1229 when Add_Membership |
1231 To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1232 To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1234 when Multicast_If =>
1235 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1237 when Multicast_TTL =>
1238 Opt.Time_To_Live := Integer (V1);
1240 when Multicast_Loop |
1241 Receive_Packet_Info =>
1242 Opt.Enabled := (V1 /= 0);
1247 if Target_OS = Windows then
1249 -- Timeout is in milliseconds, actual value is 500 ms +
1250 -- returned value (unless it is 0).
1255 Opt.Timeout := Natural (V4) * 0.001 + 0.500;
1259 Opt.Timeout := To_Duration (VT);
1264 end Get_Socket_Option;
1270 function Host_Name return String is
1271 Name : aliased C.char_array (1 .. 64);
1275 Res := C_Gethostname (Name'Address, Name'Length);
1277 if Res = Failure then
1278 Raise_Socket_Error (Socket_Errno);
1281 return C.To_Ada (Name);
1289 (Val : Inet_Addr_VN_Type;
1290 Hex : Boolean := False) return String
1292 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1293 -- has at most a length of 3 plus one '.' character.
1295 Buffer : String (1 .. 4 * Val'Length);
1296 Length : Natural := 1;
1297 Separator : Character;
1299 procedure Img10 (V : Inet_Addr_Comp_Type);
1300 -- Append to Buffer image of V in decimal format
1302 procedure Img16 (V : Inet_Addr_Comp_Type);
1303 -- Append to Buffer image of V in hexadecimal format
1309 procedure Img10 (V : Inet_Addr_Comp_Type) is
1310 Img : constant String := V'Img;
1311 Len : constant Natural := Img'Length - 1;
1313 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1314 Length := Length + Len;
1321 procedure Img16 (V : Inet_Addr_Comp_Type) is
1323 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
1324 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1325 Length := Length + 2;
1328 -- Start of processing for Image
1331 Separator := (if Hex then ':' else '.');
1333 for J in Val'Range loop
1340 if J /= Val'Last then
1341 Buffer (Length) := Separator;
1342 Length := Length + 1;
1346 return Buffer (1 .. Length - 1);
1353 function Image (Value : Inet_Addr_Type) return String is
1355 if Value.Family = Family_Inet then
1356 return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1358 return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1366 function Image (Value : Sock_Addr_Type) return String is
1367 Port : constant String := Value.Port'Img;
1369 return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1376 function Image (Socket : Socket_Type) return String is
1385 function Image (Item : Socket_Set_Type) return String is
1386 Socket_Set : Socket_Set_Type := Item;
1390 Last_Img : constant String := Socket_Set.Last'Img;
1392 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1393 Index : Positive := 1;
1394 Socket : Socket_Type;
1397 while not Is_Empty (Socket_Set) loop
1398 Get (Socket_Set, Socket);
1401 Socket_Img : constant String := Socket'Img;
1403 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1404 Index := Index + Socket_Img'Length;
1408 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1416 function Inet_Addr (Image : String) return Inet_Addr_Type is
1419 Img : aliased char_array := To_C (Image);
1420 Addr : aliased C.int;
1422 Result : Inet_Addr_Type;
1425 -- Special case for an empty Image as on some platforms (e.g. Windows)
1426 -- calling Inet_Addr("") will not return an error.
1429 Raise_Socket_Error (SOSC.EINVAL);
1432 Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address);
1435 Raise_Socket_Error (Socket_Errno);
1438 Raise_Socket_Error (SOSC.EINVAL);
1441 To_Inet_Addr (To_In_Addr (Addr), Result);
1449 procedure Initialize (X : in out Sockets_Library_Controller) is
1450 pragma Unreferenced (X);
1460 procedure Initialize (Process_Blocking_IO : Boolean) is
1461 Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1464 if Process_Blocking_IO /= Expected then
1465 raise Socket_Error with
1466 "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1469 -- This is a dummy placeholder for an obsolete API
1471 -- Real initialization actions are in Initialize primitive operation
1472 -- of Sockets_Library_Controller.
1481 procedure Initialize is
1483 -- This is a dummy placeholder for an obsolete API
1485 -- Real initialization actions are in Initialize primitive operation
1486 -- of Sockets_Library_Controller.
1495 function Is_Empty (Item : Socket_Set_Type) return Boolean is
1497 return Item.Last = No_Socket;
1504 function Is_IP_Address (Name : String) return Boolean is
1506 for J in Name'Range loop
1508 and then Name (J) not in '0' .. '9'
1521 function Is_Open (S : Selector_Type) return Boolean is
1527 -- Either both controlling socket descriptors are valid (case of an
1528 -- open selector) or neither (case of a closed selector).
1530 pragma Assert ((S.R_Sig_Socket /= No_Socket)
1532 (S.W_Sig_Socket /= No_Socket));
1534 return S.R_Sig_Socket /= No_Socket;
1543 (Item : Socket_Set_Type;
1544 Socket : Socket_Type) return Boolean
1547 Check_For_Fd_Set (Socket);
1549 return Item.Last /= No_Socket
1550 and then Socket <= Item.Last
1551 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1558 procedure Listen_Socket
1559 (Socket : Socket_Type;
1560 Length : Natural := 15)
1562 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1564 if Res = Failure then
1565 Raise_Socket_Error (Socket_Errno);
1573 procedure Narrow (Item : in out Socket_Set_Type) is
1574 Last : aliased C.int := C.int (Item.Last);
1576 if Item.Last /= No_Socket then
1577 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1578 Item.Last := Socket_Type (Last);
1586 procedure Netdb_Lock is
1588 if Need_Netdb_Lock then
1589 System.Task_Lock.Lock;
1597 procedure Netdb_Unlock is
1599 if Need_Netdb_Lock then
1600 System.Task_Lock.Unlock;
1604 --------------------------------
1605 -- Normalize_Empty_Socket_Set --
1606 --------------------------------
1608 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1610 if S.Last = No_Socket then
1611 Reset_Socket_Set (S.Set'Access);
1613 end Normalize_Empty_Socket_Set;
1619 function Official_Name (E : Host_Entry_Type) return String is
1621 return To_String (E.Official);
1628 function Official_Name (S : Service_Entry_Type) return String is
1630 return To_String (S.Official);
1633 --------------------
1634 -- Wait_On_Socket --
1635 --------------------
1637 procedure Wait_On_Socket
1638 (Socket : Socket_Type;
1640 Timeout : Selector_Duration;
1641 Selector : access Selector_Type := null;
1642 Status : out Selector_Status)
1644 type Local_Selector_Access is access Selector_Type;
1645 for Local_Selector_Access'Storage_Size use Selector_Type'Size;
1647 S : Selector_Access;
1648 -- Selector to use for waiting
1650 R_Fd_Set : Socket_Set_Type;
1651 W_Fd_Set : Socket_Set_Type;
1654 -- Create selector if not provided by the user
1656 if Selector = null then
1658 Local_S : constant Local_Selector_Access := new Selector_Type;
1660 S := Local_S.all'Unchecked_Access;
1661 Create_Selector (S.all);
1665 S := Selector.all'Access;
1669 Set (R_Fd_Set, Socket);
1671 Set (W_Fd_Set, Socket);
1674 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
1676 if Selector = null then
1677 Close_Selector (S.all);
1685 function Port_Number (S : Service_Entry_Type) return Port_Type is
1694 function Protocol_Name (S : Service_Entry_Type) return String is
1696 return To_String (S.Protocol);
1699 ----------------------
1700 -- Raise_Host_Error --
1701 ----------------------
1703 procedure Raise_Host_Error (H_Error : Integer) is
1705 raise Host_Error with
1706 Err_Code_Image (H_Error)
1707 & Host_Error_Messages.Host_Error_Message (H_Error);
1708 end Raise_Host_Error;
1710 ------------------------
1711 -- Raise_Socket_Error --
1712 ------------------------
1714 procedure Raise_Socket_Error (Error : Integer) is
1716 raise Socket_Error with
1717 Err_Code_Image (Error) & Socket_Error_Message (Error);
1718 end Raise_Socket_Error;
1725 (Stream : in out Datagram_Socket_Stream_Type;
1726 Item : out Ada.Streams.Stream_Element_Array;
1727 Last : out Ada.Streams.Stream_Element_Offset)
1742 (Stream : in out Stream_Socket_Stream_Type;
1743 Item : out Ada.Streams.Stream_Element_Array;
1744 Last : out Ada.Streams.Stream_Element_Offset)
1746 First : Ada.Streams.Stream_Element_Offset := Item'First;
1747 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1748 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1752 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1755 -- Exit when all or zero data received. Zero means that the socket
1758 exit when Index < First or else Index = Max;
1764 --------------------
1765 -- Receive_Socket --
1766 --------------------
1768 procedure Receive_Socket
1769 (Socket : Socket_Type;
1770 Item : out Ada.Streams.Stream_Element_Array;
1771 Last : out Ada.Streams.Stream_Element_Offset;
1772 Flags : Request_Flag_Type := No_Request_Flag)
1778 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1780 if Res = Failure then
1781 Raise_Socket_Error (Socket_Errno);
1784 Last := Last_Index (First => Item'First, Count => size_t (Res));
1787 --------------------
1788 -- Receive_Socket --
1789 --------------------
1791 procedure Receive_Socket
1792 (Socket : Socket_Type;
1793 Item : out Ada.Streams.Stream_Element_Array;
1794 Last : out Ada.Streams.Stream_Element_Offset;
1795 From : out Sock_Addr_Type;
1796 Flags : Request_Flag_Type := No_Request_Flag)
1799 Sin : aliased Sockaddr_In;
1800 Len : aliased C.int := Sin'Size / 8;
1812 if Res = Failure then
1813 Raise_Socket_Error (Socket_Errno);
1816 Last := Last_Index (First => Item'First, Count => size_t (Res));
1818 To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1819 From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1822 --------------------
1823 -- Receive_Vector --
1824 --------------------
1826 procedure Receive_Vector
1827 (Socket : Socket_Type;
1828 Vector : Vector_Type;
1829 Count : out Ada.Streams.Stream_Element_Count;
1830 Flags : Request_Flag_Type := No_Request_Flag)
1835 (Msg_Name => System.Null_Address,
1837 Msg_Iov => Vector'Address,
1839 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1840 -- platforms) when the supplied vector is longer than IOV_MAX,
1841 -- so use minimum of the two lengths.
1843 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
1844 (Vector'Length, SOSC.IOV_MAX),
1846 Msg_Control => System.Null_Address,
1847 Msg_Controllen => 0,
1857 if Res = ssize_t (Failure) then
1858 Raise_Socket_Error (Socket_Errno);
1861 Count := Ada.Streams.Stream_Element_Count (Res);
1868 function Resolve_Error
1869 (Error_Value : Integer;
1870 From_Errno : Boolean := True) return Error_Type
1872 use GNAT.Sockets.SOSC;
1875 if not From_Errno then
1877 when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1878 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
1879 when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
1880 when SOSC.NO_DATA => return Unknown_Server_Error;
1881 when others => return Cannot_Resolve_Error;
1885 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1886 -- can't include it in the case statement below.
1888 pragma Warnings (Off);
1889 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1891 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1892 return Resource_Temporarily_Unavailable;
1895 -- This is not a case statement because if a particular error
1896 -- number constant is not defined, s-oscons-tmplt.c defines
1897 -- it to -1. If multiple constants are not defined, they
1898 -- would each be -1 and result in a "duplicate value in case" error.
1900 -- But we have to leave warnings off because the compiler is also
1901 -- smart enough to note that when two errnos have the same value,
1902 -- the second if condition is useless.
1903 if Error_Value = ENOERROR then
1905 elsif Error_Value = EACCES then
1906 return Permission_Denied;
1907 elsif Error_Value = EADDRINUSE then
1908 return Address_Already_In_Use;
1909 elsif Error_Value = EADDRNOTAVAIL then
1910 return Cannot_Assign_Requested_Address;
1911 elsif Error_Value = EAFNOSUPPORT then
1912 return Address_Family_Not_Supported_By_Protocol;
1913 elsif Error_Value = EALREADY then
1914 return Operation_Already_In_Progress;
1915 elsif Error_Value = EBADF then
1916 return Bad_File_Descriptor;
1917 elsif Error_Value = ECONNABORTED then
1918 return Software_Caused_Connection_Abort;
1919 elsif Error_Value = ECONNREFUSED then
1920 return Connection_Refused;
1921 elsif Error_Value = ECONNRESET then
1922 return Connection_Reset_By_Peer;
1923 elsif Error_Value = EDESTADDRREQ then
1924 return Destination_Address_Required;
1925 elsif Error_Value = EFAULT then
1927 elsif Error_Value = EHOSTDOWN then
1928 return Host_Is_Down;
1929 elsif Error_Value = EHOSTUNREACH then
1930 return No_Route_To_Host;
1931 elsif Error_Value = EINPROGRESS then
1932 return Operation_Now_In_Progress;
1933 elsif Error_Value = EINTR then
1934 return Interrupted_System_Call;
1935 elsif Error_Value = EINVAL then
1936 return Invalid_Argument;
1937 elsif Error_Value = EIO then
1938 return Input_Output_Error;
1939 elsif Error_Value = EISCONN then
1940 return Transport_Endpoint_Already_Connected;
1941 elsif Error_Value = ELOOP then
1942 return Too_Many_Symbolic_Links;
1943 elsif Error_Value = EMFILE then
1944 return Too_Many_Open_Files;
1945 elsif Error_Value = EMSGSIZE then
1946 return Message_Too_Long;
1947 elsif Error_Value = ENAMETOOLONG then
1948 return File_Name_Too_Long;
1949 elsif Error_Value = ENETDOWN then
1950 return Network_Is_Down;
1951 elsif Error_Value = ENETRESET then
1952 return Network_Dropped_Connection_Because_Of_Reset;
1953 elsif Error_Value = ENETUNREACH then
1954 return Network_Is_Unreachable;
1955 elsif Error_Value = ENOBUFS then
1956 return No_Buffer_Space_Available;
1957 elsif Error_Value = ENOPROTOOPT then
1958 return Protocol_Not_Available;
1959 elsif Error_Value = ENOTCONN then
1960 return Transport_Endpoint_Not_Connected;
1961 elsif Error_Value = ENOTSOCK then
1962 return Socket_Operation_On_Non_Socket;
1963 elsif Error_Value = EOPNOTSUPP then
1964 return Operation_Not_Supported;
1965 elsif Error_Value = EPFNOSUPPORT then
1966 return Protocol_Family_Not_Supported;
1967 elsif Error_Value = EPIPE then
1969 elsif Error_Value = EPROTONOSUPPORT then
1970 return Protocol_Not_Supported;
1971 elsif Error_Value = EPROTOTYPE then
1972 return Protocol_Wrong_Type_For_Socket;
1973 elsif Error_Value = ESHUTDOWN then
1974 return Cannot_Send_After_Transport_Endpoint_Shutdown;
1975 elsif Error_Value = ESOCKTNOSUPPORT then
1976 return Socket_Type_Not_Supported;
1977 elsif Error_Value = ETIMEDOUT then
1978 return Connection_Timed_Out;
1979 elsif Error_Value = ETOOMANYREFS then
1980 return Too_Many_References;
1981 elsif Error_Value = EWOULDBLOCK then
1982 return Resource_Temporarily_Unavailable;
1984 return Cannot_Resolve_Error;
1986 pragma Warnings (On);
1990 -----------------------
1991 -- Resolve_Exception --
1992 -----------------------
1994 function Resolve_Exception
1995 (Occurrence : Exception_Occurrence) return Error_Type
1997 Id : constant Exception_Id := Exception_Identity (Occurrence);
1998 Msg : constant String := Exception_Message (Occurrence);
2005 while First <= Msg'Last
2006 and then Msg (First) not in '0' .. '9'
2011 if First > Msg'Last then
2012 return Cannot_Resolve_Error;
2016 while Last < Msg'Last
2017 and then Msg (Last + 1) in '0' .. '9'
2022 Val := Integer'Value (Msg (First .. Last));
2024 if Id = Socket_Error_Id then
2025 return Resolve_Error (Val);
2027 elsif Id = Host_Error_Id then
2028 return Resolve_Error (Val, False);
2031 return Cannot_Resolve_Error;
2033 end Resolve_Exception;
2039 procedure Send_Socket
2040 (Socket : Socket_Type;
2041 Item : Ada.Streams.Stream_Element_Array;
2042 Last : out Ada.Streams.Stream_Element_Offset;
2043 Flags : Request_Flag_Type := No_Request_Flag)
2046 Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2053 procedure Send_Socket
2054 (Socket : Socket_Type;
2055 Item : Ada.Streams.Stream_Element_Array;
2056 Last : out Ada.Streams.Stream_Element_Offset;
2057 To : Sock_Addr_Type;
2058 Flags : Request_Flag_Type := No_Request_Flag)
2062 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2069 procedure Send_Socket
2070 (Socket : Socket_Type;
2071 Item : Ada.Streams.Stream_Element_Array;
2072 Last : out Ada.Streams.Stream_Element_Offset;
2073 To : access Sock_Addr_Type;
2074 Flags : Request_Flag_Type := No_Request_Flag)
2078 Sin : aliased Sockaddr_In;
2079 C_To : System.Address;
2084 Set_Family (Sin.Sin_Family, To.Family);
2085 Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
2087 (Sin'Unchecked_Access,
2088 Short_To_Network (C.unsigned_short (To.Port)));
2089 C_To := Sin'Address;
2090 Len := Sin'Size / 8;
2093 C_To := System.Null_Address;
2101 Set_Forced_Flags (To_Int (Flags)),
2105 if Res = Failure then
2106 Raise_Socket_Error (Socket_Errno);
2109 Last := Last_Index (First => Item'First, Count => size_t (Res));
2116 procedure Send_Vector
2117 (Socket : Socket_Type;
2118 Vector : Vector_Type;
2119 Count : out Ada.Streams.Stream_Element_Count;
2120 Flags : Request_Flag_Type := No_Request_Flag)
2126 Iov_Count : SOSC.Msg_Iovlen_T;
2127 This_Iov_Count : SOSC.Msg_Iovlen_T;
2133 while Iov_Count < Vector'Length loop
2135 pragma Warnings (Off);
2136 -- Following test may be compile time known on some targets
2139 (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2141 else Vector'Length - Iov_Count);
2143 pragma Warnings (On);
2146 (Msg_Name => System.Null_Address,
2149 (Vector'First + Integer (Iov_Count))'Address,
2150 Msg_Iovlen => This_Iov_Count,
2151 Msg_Control => System.Null_Address,
2152 Msg_Controllen => 0,
2159 Set_Forced_Flags (To_Int (Flags)));
2161 if Res = ssize_t (Failure) then
2162 Raise_Socket_Error (Socket_Errno);
2165 Count := Count + Ada.Streams.Stream_Element_Count (Res);
2166 Iov_Count := Iov_Count + This_Iov_Count;
2174 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2176 Check_For_Fd_Set (Socket);
2178 if Item.Last = No_Socket then
2180 -- Uninitialized socket set, make sure it is properly zeroed out
2182 Reset_Socket_Set (Item.Set'Access);
2183 Item.Last := Socket;
2185 elsif Item.Last < Socket then
2186 Item.Last := Socket;
2189 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2192 -----------------------
2193 -- Set_Close_On_Exec --
2194 -----------------------
2196 procedure Set_Close_On_Exec
2197 (Socket : Socket_Type;
2198 Close_On_Exec : Boolean;
2199 Status : out Boolean)
2201 function C_Set_Close_On_Exec
2202 (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
2203 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2205 Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
2206 end Set_Close_On_Exec;
2208 ----------------------
2209 -- Set_Forced_Flags --
2210 ----------------------
2212 function Set_Forced_Flags (F : C.int) return C.int is
2213 use type C.unsigned;
2214 function To_unsigned is
2215 new Ada.Unchecked_Conversion (C.int, C.unsigned);
2217 new Ada.Unchecked_Conversion (C.unsigned, C.int);
2219 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2220 end Set_Forced_Flags;
2222 -----------------------
2223 -- Set_Socket_Option --
2224 -----------------------
2226 procedure Set_Socket_Option
2227 (Socket : Socket_Type;
2228 Level : Level_Type := Socket_Level;
2229 Option : Option_Type)
2233 V8 : aliased Two_Ints;
2235 V1 : aliased C.unsigned_char;
2236 VT : aliased Timeval;
2238 Add : System.Address := Null_Address;
2247 V4 := C.int (Boolean'Pos (Option.Enabled));
2252 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2253 V8 (V8'Last) := C.int (Option.Seconds);
2259 V4 := C.int (Option.Size);
2264 V4 := C.int (Boolean'Pos (True));
2268 when Add_Membership |
2270 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2271 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
2275 when Multicast_If =>
2276 V4 := To_Int (To_In_Addr (Option.Outgoing_If));
2280 when Multicast_TTL =>
2281 V1 := C.unsigned_char (Option.Time_To_Live);
2285 when Multicast_Loop |
2286 Receive_Packet_Info =>
2287 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
2294 if Target_OS = Windows then
2296 -- On Windows, the timeout is a DWORD in milliseconds, and
2297 -- the actual timeout is 500 ms + the given value (unless it
2300 V4 := C.int (Option.Timeout / 0.001);
2313 VT := To_Timeval (Option.Timeout);
2323 Options (Option.Name),
2326 if Res = Failure then
2327 Raise_Socket_Error (Socket_Errno);
2329 end Set_Socket_Option;
2331 ----------------------
2332 -- Short_To_Network --
2333 ----------------------
2335 function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2336 use type C.unsigned_short;
2339 -- Big-endian case. No conversion needed. On these platforms, htons()
2340 -- defaults to a null procedure.
2342 if Default_Bit_Order = High_Order_First then
2345 -- Little-endian case. We must swap the high and low bytes of this
2346 -- short to make the port number network compliant.
2349 return (S / 256) + (S mod 256) * 256;
2351 end Short_To_Network;
2353 ---------------------
2354 -- Shutdown_Socket --
2355 ---------------------
2357 procedure Shutdown_Socket
2358 (Socket : Socket_Type;
2359 How : Shutmode_Type := Shut_Read_Write)
2364 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2366 if Res = Failure then
2367 Raise_Socket_Error (Socket_Errno);
2369 end Shutdown_Socket;
2376 (Socket : Socket_Type;
2377 Send_To : Sock_Addr_Type) return Stream_Access
2379 S : Datagram_Socket_Stream_Access;
2382 S := new Datagram_Socket_Stream_Type;
2385 S.From := Get_Socket_Name (Socket);
2386 return Stream_Access (S);
2393 function Stream (Socket : Socket_Type) return Stream_Access is
2394 S : Stream_Socket_Stream_Access;
2396 S := new Stream_Socket_Stream_Type;
2398 return Stream_Access (S);
2405 function To_C (Socket : Socket_Type) return Integer is
2407 return Integer (Socket);
2414 function To_Duration (Val : Timeval) return Timeval_Duration is
2416 return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2423 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2426 Aliases_Count, Addresses_Count : Natural;
2428 -- H_Length is not used because it is currently only ever set to 4, as
2429 -- we only handle the case of H_Addrtype being AF_INET.
2432 if Hostent_H_Addrtype (E) /= SOSC.AF_INET then
2433 Raise_Socket_Error (SOSC.EPFNOSUPPORT);
2437 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2438 Aliases_Count := Aliases_Count + 1;
2441 Addresses_Count := 0;
2442 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2443 Addresses_Count := Addresses_Count + 1;
2446 return Result : Host_Entry_Type
2447 (Aliases_Length => Aliases_Count,
2448 Addresses_Length => Addresses_Count)
2450 Result.Official := To_Name (Value (Hostent_H_Name (E)));
2452 for J in Result.Aliases'Range loop
2453 Result.Aliases (J) :=
2454 To_Name (Value (Hostent_H_Alias
2455 (E, C.int (J - Result.Aliases'First))));
2458 for J in Result.Addresses'Range loop
2462 -- Hostent_H_Addr (E, <index>) may return an address that is
2463 -- not correctly aligned for In_Addr, so we need to use
2464 -- an intermediate copy operation on a type with an alignemnt
2465 -- of 1 to recover the value.
2467 subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8);
2468 Unaligned_Addr : Addr_Buf_T;
2469 for Unaligned_Addr'Address
2470 use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2471 pragma Import (Ada, Unaligned_Addr);
2473 Aligned_Addr : Addr_Buf_T;
2474 for Aligned_Addr'Address use Addr'Address;
2475 pragma Import (Ada, Aligned_Addr);
2478 Aligned_Addr := Unaligned_Addr;
2479 To_Inet_Addr (Addr, Result.Addresses (J));
2489 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2491 if Addr.Family = Family_Inet then
2492 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2493 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2494 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2495 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2498 raise Socket_Error with "IPv6 not supported";
2505 procedure To_Inet_Addr
2507 Result : out Inet_Addr_Type) is
2509 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2510 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2511 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2512 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2519 function To_Int (F : Request_Flag_Type) return C.int
2521 Current : Request_Flag_Type := F;
2522 Result : C.int := 0;
2525 for J in Flags'Range loop
2526 exit when Current = 0;
2528 if Current mod 2 /= 0 then
2529 if Flags (J) = -1 then
2530 Raise_Socket_Error (SOSC.EOPNOTSUPP);
2533 Result := Result + Flags (J);
2536 Current := Current / 2;
2546 function To_Name (N : String) return Name_Type is
2548 return Name_Type'(N'Length, N);
2551 ----------------------
2552 -- To_Service_Entry --
2553 ----------------------
2555 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2558 Aliases_Count : Natural;
2562 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2563 Aliases_Count := Aliases_Count + 1;
2566 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2567 Result.Official := To_Name (Value (Servent_S_Name (E)));
2569 for J in Result.Aliases'Range loop
2570 Result.Aliases (J) :=
2571 To_Name (Value (Servent_S_Alias
2572 (E, C.int (J - Result.Aliases'First))));
2575 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2577 Port_Type (Network_To_Short (Servent_S_Port (E)));
2579 end To_Service_Entry;
2585 function To_String (HN : Name_Type) return String is
2587 return HN.Name (1 .. HN.Length);
2594 function To_Timeval (Val : Timeval_Duration) return Timeval is
2599 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2605 -- Normal case where we do round down
2608 S := time_t (Val - 0.5);
2609 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2619 function Value (S : System.Address) return String is
2620 Str : String (1 .. Positive'Last);
2621 for Str'Address use S;
2622 pragma Import (Ada, Str);
2624 Terminator : Positive := Str'First;
2627 while Str (Terminator) /= ASCII.NUL loop
2628 Terminator := Terminator + 1;
2631 return Str (1 .. Terminator - 1);
2639 (Stream : in out Datagram_Socket_Stream_Type;
2640 Item : Ada.Streams.Stream_Element_Array)
2642 Last : Stream_Element_Offset;
2651 -- It is an error if not all of the data has been sent
2653 if Last /= Item'Last then
2654 Raise_Socket_Error (Socket_Errno);
2663 (Stream : in out Stream_Socket_Stream_Type;
2664 Item : Ada.Streams.Stream_Element_Array)
2666 First : Ada.Streams.Stream_Element_Offset;
2667 Index : Ada.Streams.Stream_Element_Offset;
2668 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2671 First := Item'First;
2673 while First <= Max loop
2674 Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
2676 -- Exit when all or zero data sent. Zero means that the socket has
2677 -- been closed by peer.
2679 exit when Index < First or else Index = Max;
2684 -- For an empty array, we have First > Max, and hence Index >= Max (no
2685 -- error, the loop above is never executed). After a successful send,
2686 -- Index = Max. The only remaining case, Index < Max, is therefore
2687 -- always an actual send failure.
2690 Raise_Socket_Error (Socket_Errno);
2694 Sockets_Library_Controller_Object : Sockets_Library_Controller;
2695 pragma Unreferenced (Sockets_Library_Controller_Object);
2696 -- The elaboration and finalization of this object perform the required
2697 -- initialization and cleanup actions for the sockets library.