1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2011, 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 Interfaces.C.Strings;
39 with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
40 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
42 with GNAT.Sockets.Linker_Options;
43 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
44 -- Need to include pragma Linker_Options which is platform dependent
46 with System; use System;
47 with System.Communication; use System.Communication;
48 with System.CRTL; use System.CRTL;
49 with System.Task_Lock;
51 package body GNAT.Sockets is
53 package C renames Interfaces.C;
57 ENOERROR : constant := 0;
59 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
60 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
61 -- The network database functions gethostbyname, gethostbyaddr,
62 -- getservbyname and getservbyport can either be guaranteed task safe by
63 -- the operating system, or else return data through a user-provided buffer
64 -- to ensure concurrent uses do not interfere.
66 -- Correspondence tables
68 Levels : constant array (Level_Type) of C.int :=
69 (Socket_Level => SOSC.SOL_SOCKET,
70 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
71 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
72 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
74 Modes : constant array (Mode_Type) of C.int :=
75 (Socket_Stream => SOSC.SOCK_STREAM,
76 Socket_Datagram => SOSC.SOCK_DGRAM);
78 Shutmodes : constant array (Shutmode_Type) of C.int :=
79 (Shut_Read => SOSC.SHUT_RD,
80 Shut_Write => SOSC.SHUT_WR,
81 Shut_Read_Write => SOSC.SHUT_RDWR);
83 Requests : constant array (Request_Name) of C.int :=
84 (Non_Blocking_IO => SOSC.FIONBIO,
85 N_Bytes_To_Read => SOSC.FIONREAD);
87 Options : constant array (Option_Name) of C.int :=
88 (Keep_Alive => SOSC.SO_KEEPALIVE,
89 Reuse_Address => SOSC.SO_REUSEADDR,
90 Broadcast => SOSC.SO_BROADCAST,
91 Send_Buffer => SOSC.SO_SNDBUF,
92 Receive_Buffer => SOSC.SO_RCVBUF,
93 Linger => SOSC.SO_LINGER,
94 Error => SOSC.SO_ERROR,
95 No_Delay => SOSC.TCP_NODELAY,
96 Add_Membership => SOSC.IP_ADD_MEMBERSHIP,
97 Drop_Membership => SOSC.IP_DROP_MEMBERSHIP,
98 Multicast_If => SOSC.IP_MULTICAST_IF,
99 Multicast_TTL => SOSC.IP_MULTICAST_TTL,
100 Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
101 Receive_Packet_Info => SOSC.IP_PKTINFO,
102 Send_Timeout => SOSC.SO_SNDTIMEO,
103 Receive_Timeout => SOSC.SO_RCVTIMEO);
104 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
105 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
107 Flags : constant array (0 .. 3) of C.int :=
108 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
109 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
110 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
111 3 => SOSC.MSG_EOR); -- Send_End_Of_Record
113 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
114 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
116 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
117 -- Use to print in hexadecimal format
119 -----------------------
120 -- Local subprograms --
121 -----------------------
123 function Resolve_Error
124 (Error_Value : Integer;
125 From_Errno : Boolean := True) return Error_Type;
126 -- Associate an enumeration value (error_type) to en error value (errno).
127 -- From_Errno prevents from mixing h_errno with errno.
129 function To_Name (N : String) return Name_Type;
130 function To_String (HN : Name_Type) return String;
131 -- Conversion functions
133 function To_Int (F : Request_Flag_Type) return C.int;
134 -- Return the int value corresponding to the specified flags combination
136 function Set_Forced_Flags (F : C.int) return C.int;
137 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
139 function Short_To_Network
140 (S : C.unsigned_short) return C.unsigned_short;
141 pragma Inline (Short_To_Network);
142 -- Convert a port number into a network port number
144 function Network_To_Short
145 (S : C.unsigned_short) return C.unsigned_short
146 renames Short_To_Network;
147 -- Symmetric operation
150 (Val : Inet_Addr_VN_Type;
151 Hex : Boolean := False) return String;
152 -- Output an array of inet address components in hex or decimal mode
154 function Is_IP_Address (Name : String) return Boolean;
155 -- Return true when Name is an IP address in standard dot notation
157 procedure Netdb_Lock;
158 pragma Inline (Netdb_Lock);
159 procedure Netdb_Unlock;
160 pragma Inline (Netdb_Unlock);
161 -- Lock/unlock operation used to protect netdb access for platforms that
162 -- require such protection.
164 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
165 procedure To_Inet_Addr
167 Result : out Inet_Addr_Type);
168 -- Conversion functions
170 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
171 -- Conversion function
173 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
174 -- Conversion function
176 function Value (S : System.Address) return String;
177 -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS,
178 -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
180 function To_Timeval (Val : Timeval_Duration) return Timeval;
181 -- Separate Val in seconds and microseconds
183 function To_Duration (Val : Timeval) return Timeval_Duration;
184 -- Reconstruct a Duration value from a Timeval record (seconds and
187 procedure Raise_Socket_Error (Error : Integer);
188 -- Raise Socket_Error with an exception message describing the error code
191 procedure Raise_Host_Error (H_Error : Integer);
192 -- Raise Host_Error exception with message describing error code (note
193 -- hstrerror seems to be obsolete) from h_errno.
195 procedure Narrow (Item : in out Socket_Set_Type);
196 -- Update Last as it may be greater than the real last socket
198 procedure Check_For_Fd_Set (Fd : Socket_Type);
199 pragma Inline (Check_For_Fd_Set);
200 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
201 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
203 -- Types needed for Datagram_Socket_Stream_Type
205 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
206 Socket : Socket_Type;
208 From : Sock_Addr_Type;
211 type Datagram_Socket_Stream_Access is
212 access all Datagram_Socket_Stream_Type;
215 (Stream : in out Datagram_Socket_Stream_Type;
216 Item : out Ada.Streams.Stream_Element_Array;
217 Last : out Ada.Streams.Stream_Element_Offset);
220 (Stream : in out Datagram_Socket_Stream_Type;
221 Item : Ada.Streams.Stream_Element_Array);
223 -- Types needed for Stream_Socket_Stream_Type
225 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
226 Socket : Socket_Type;
229 type Stream_Socket_Stream_Access is
230 access all Stream_Socket_Stream_Type;
233 (Stream : in out Stream_Socket_Stream_Type;
234 Item : out Ada.Streams.Stream_Element_Array;
235 Last : out Ada.Streams.Stream_Element_Offset);
238 (Stream : in out Stream_Socket_Stream_Type;
239 Item : Ada.Streams.Stream_Element_Array);
241 procedure Stream_Write
242 (Socket : Socket_Type;
243 Item : Ada.Streams.Stream_Element_Array;
244 To : access Sock_Addr_Type);
245 -- Common implementation for the Write operation of Datagram_Socket_Stream_
246 -- Type and Stream_Socket_Stream_Type.
248 procedure Wait_On_Socket
249 (Socket : Socket_Type;
251 Timeout : Selector_Duration;
252 Selector : access Selector_Type := null;
253 Status : out Selector_Status);
254 -- Common code for variants of socket operations supporting a timeout:
255 -- block in Check_Selector on Socket for at most the indicated timeout.
256 -- If For_Read is True, Socket is added to the read set for this call, else
257 -- it is added to the write set. If no selector is provided, a local one is
258 -- created for this call and destroyed prior to returning.
260 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
262 -- This type is used to generate automatic calls to Initialize and Finalize
263 -- during the elaboration and finalization of this package. A single object
264 -- of this type must exist at library level.
266 function Err_Code_Image (E : Integer) return String;
267 -- Return the value of E surrounded with brackets
269 procedure Initialize (X : in out Sockets_Library_Controller);
270 procedure Finalize (X : in out Sockets_Library_Controller);
272 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
273 -- If S is the empty set (detected by Last = No_Socket), make sure its
274 -- fd_set component is actually cleared. Note that the case where it is
275 -- not can occur for an uninitialized Socket_Set_Type object.
277 function Is_Open (S : Selector_Type) return Boolean;
278 -- Return True for an "open" Selector_Type object, i.e. one for which
279 -- Create_Selector has been called and Close_Selector has not been called,
280 -- or the null selector.
286 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
295 procedure Abort_Selector (Selector : Selector_Type) is
299 if not Is_Open (Selector) then
300 raise Program_Error with "closed selector";
302 elsif Selector.Is_Null then
303 raise Program_Error with "null selector";
307 -- Send one byte to unblock select system call
309 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
311 if Res = Failure then
312 Raise_Socket_Error (Socket_Errno);
320 procedure Accept_Socket
321 (Server : Socket_Type;
322 Socket : out Socket_Type;
323 Address : out Sock_Addr_Type)
326 Sin : aliased Sockaddr_In;
327 Len : aliased C.int := Sin'Size / 8;
330 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
332 if Res = Failure then
333 Raise_Socket_Error (Socket_Errno);
336 Socket := Socket_Type (Res);
338 To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
339 Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
346 procedure Accept_Socket
347 (Server : Socket_Type;
348 Socket : out Socket_Type;
349 Address : out Sock_Addr_Type;
350 Timeout : Selector_Duration;
351 Selector : access Selector_Type := null;
352 Status : out Selector_Status)
355 if Selector /= null and then not Is_Open (Selector.all) then
356 raise Program_Error with "closed selector";
359 -- Wait for socket to become available for reading
365 Selector => Selector,
368 -- Accept connection if available
370 if Status = Completed then
371 Accept_Socket (Server, Socket, Address);
382 (E : Host_Entry_Type;
383 N : Positive := 1) return Inet_Addr_Type
386 return E.Addresses (N);
389 ----------------------
390 -- Addresses_Length --
391 ----------------------
393 function Addresses_Length (E : Host_Entry_Type) return Natural is
395 return E.Addresses_Length;
396 end Addresses_Length;
403 (E : Host_Entry_Type;
404 N : Positive := 1) return String
407 return To_String (E.Aliases (N));
415 (S : Service_Entry_Type;
416 N : Positive := 1) return String
419 return To_String (S.Aliases (N));
426 function Aliases_Length (E : Host_Entry_Type) return Natural is
428 return E.Aliases_Length;
435 function Aliases_Length (S : Service_Entry_Type) return Natural is
437 return S.Aliases_Length;
444 procedure Bind_Socket
445 (Socket : Socket_Type;
446 Address : Sock_Addr_Type)
449 Sin : aliased Sockaddr_In;
450 Len : constant C.int := Sin'Size / 8;
451 -- This assumes that Address.Family = Family_Inet???
454 if Address.Family = Family_Inet6 then
455 raise Socket_Error with "IPv6 not supported";
458 Set_Family (Sin.Sin_Family, Address.Family);
459 Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
461 (Sin'Unchecked_Access,
462 Short_To_Network (C.unsigned_short (Address.Port)));
464 Res := C_Bind (C.int (Socket), Sin'Address, Len);
466 if Res = Failure then
467 Raise_Socket_Error (Socket_Errno);
471 ----------------------
472 -- Check_For_Fd_Set --
473 ----------------------
475 procedure Check_For_Fd_Set (Fd : Socket_Type) is
479 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
480 -- no check required. Warnings suppressed because condition
481 -- is known at compile time.
483 pragma Warnings (Off);
484 if Target_OS = Windows then
485 pragma Warnings (On);
489 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
490 -- that Fd is within range (otherwise behaviour is undefined).
492 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
493 raise Constraint_Error
494 with "invalid value for socket set: " & Image (Fd);
496 end Check_For_Fd_Set;
502 procedure Check_Selector
503 (Selector : Selector_Type;
504 R_Socket_Set : in out Socket_Set_Type;
505 W_Socket_Set : in out Socket_Set_Type;
506 Status : out Selector_Status;
507 Timeout : Selector_Duration := Forever)
509 E_Socket_Set : Socket_Set_Type;
512 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
519 procedure Check_Selector
520 (Selector : Selector_Type;
521 R_Socket_Set : in out Socket_Set_Type;
522 W_Socket_Set : in out Socket_Set_Type;
523 E_Socket_Set : in out Socket_Set_Type;
524 Status : out Selector_Status;
525 Timeout : Selector_Duration := Forever)
529 RSig : Socket_Type := No_Socket;
530 TVal : aliased Timeval;
531 TPtr : Timeval_Access;
534 if not Is_Open (Selector) then
535 raise Program_Error with "closed selector";
540 -- No timeout or Forever is indicated by a null timeval pointer
542 if Timeout = Forever then
545 TVal := To_Timeval (Timeout);
546 TPtr := TVal'Unchecked_Access;
549 -- Add read signalling socket, if present
551 if not Selector.Is_Null then
552 RSig := Selector.R_Sig_Socket;
553 Set (R_Socket_Set, RSig);
556 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
557 C.int (W_Socket_Set.Last)),
558 C.int (E_Socket_Set.Last));
560 -- Zero out fd_set for empty Socket_Set_Type objects
562 Normalize_Empty_Socket_Set (R_Socket_Set);
563 Normalize_Empty_Socket_Set (W_Socket_Set);
564 Normalize_Empty_Socket_Set (E_Socket_Set);
569 R_Socket_Set.Set'Access,
570 W_Socket_Set.Set'Access,
571 E_Socket_Set.Set'Access,
574 if Res = Failure then
575 Raise_Socket_Error (Socket_Errno);
578 -- If Select was resumed because of read signalling socket, read this
579 -- data and remove socket from set.
581 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
582 Clear (R_Socket_Set, RSig);
584 Res := Signalling_Fds.Read (C.int (RSig));
586 if Res = Failure then
587 Raise_Socket_Error (Socket_Errno);
596 -- Update socket sets in regard to their new contents
598 Narrow (R_Socket_Set);
599 Narrow (W_Socket_Set);
600 Narrow (E_Socket_Set);
608 (Item : in out Socket_Set_Type;
609 Socket : Socket_Type)
611 Last : aliased C.int := C.int (Item.Last);
614 Check_For_Fd_Set (Socket);
616 if Item.Last /= No_Socket then
617 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
618 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
619 Item.Last := Socket_Type (Last);
627 procedure Close_Selector (Selector : in out Selector_Type) is
629 -- Nothing to do if selector already in closed state
631 if Selector.Is_Null or else not Is_Open (Selector) then
635 -- Close the signalling file descriptors used internally for the
636 -- implementation of Abort_Selector.
638 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
639 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
641 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
642 -- (erroneous) subsequent attempt to use this selector properly fails.
644 Selector.R_Sig_Socket := No_Socket;
645 Selector.W_Sig_Socket := No_Socket;
652 procedure Close_Socket (Socket : Socket_Type) is
656 Res := C_Close (C.int (Socket));
658 if Res = Failure then
659 Raise_Socket_Error (Socket_Errno);
667 procedure Connect_Socket
668 (Socket : Socket_Type;
669 Server : Sock_Addr_Type)
672 Sin : aliased Sockaddr_In;
673 Len : constant C.int := Sin'Size / 8;
676 if Server.Family = Family_Inet6 then
677 raise Socket_Error with "IPv6 not supported";
680 Set_Family (Sin.Sin_Family, Server.Family);
681 Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
683 (Sin'Unchecked_Access,
684 Short_To_Network (C.unsigned_short (Server.Port)));
686 Res := C_Connect (C.int (Socket), Sin'Address, Len);
688 if Res = Failure then
689 Raise_Socket_Error (Socket_Errno);
697 procedure Connect_Socket
698 (Socket : Socket_Type;
699 Server : Sock_Addr_Type;
700 Timeout : Selector_Duration;
701 Selector : access Selector_Type := null;
702 Status : out Selector_Status)
705 -- Used to set Socket to non-blocking I/O
708 if Selector /= null and then not Is_Open (Selector.all) then
709 raise Program_Error with "closed selector";
712 -- Set the socket to non-blocking I/O
714 Req := (Name => Non_Blocking_IO, Enabled => True);
715 Control_Socket (Socket, Request => Req);
717 -- Start operation (non-blocking), will raise Socket_Error with
721 Connect_Socket (Socket, Server);
723 when E : Socket_Error =>
724 if Resolve_Exception (E) = Operation_Now_In_Progress then
731 -- Wait for socket to become available for writing
737 Selector => Selector,
740 -- Reset the socket to blocking I/O
742 Req := (Name => Non_Blocking_IO, Enabled => False);
743 Control_Socket (Socket, Request => Req);
750 procedure Control_Socket
751 (Socket : Socket_Type;
752 Request : in out Request_Type)
759 when Non_Blocking_IO =>
760 Arg := C.int (Boolean'Pos (Request.Enabled));
762 when N_Bytes_To_Read =>
767 (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
769 if Res = Failure then
770 Raise_Socket_Error (Socket_Errno);
774 when Non_Blocking_IO =>
777 when N_Bytes_To_Read =>
778 Request.Size := Natural (Arg);
787 (Source : Socket_Set_Type;
788 Target : out Socket_Set_Type)
794 ---------------------
795 -- Create_Selector --
796 ---------------------
798 procedure Create_Selector (Selector : out Selector_Type) is
799 Two_Fds : aliased Fd_Pair;
803 if Is_Open (Selector) then
804 -- Raise exception to prevent socket descriptor leak
806 raise Program_Error with "selector already open";
809 -- We open two signalling file descriptors. One of them is used to send
810 -- data to the other, which is included in a C_Select socket set. The
811 -- communication is used to force a call to C_Select to complete, and
812 -- the waiting task to resume its execution.
814 Res := Signalling_Fds.Create (Two_Fds'Access);
816 if Res = Failure then
817 Raise_Socket_Error (Socket_Errno);
820 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
821 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
828 procedure Create_Socket
829 (Socket : out Socket_Type;
830 Family : Family_Type := Family_Inet;
831 Mode : Mode_Type := Socket_Stream)
836 Res := C_Socket (Families (Family), Modes (Mode), 0);
838 if Res = Failure then
839 Raise_Socket_Error (Socket_Errno);
842 Socket := Socket_Type (Res);
849 procedure Empty (Item : out Socket_Set_Type) is
851 Reset_Socket_Set (Item.Set'Access);
852 Item.Last := No_Socket;
859 function Err_Code_Image (E : Integer) return String is
860 Msg : String := E'Img & "] ";
862 Msg (Msg'First) := '[';
870 procedure Finalize (X : in out Sockets_Library_Controller) is
871 pragma Unreferenced (X);
874 -- Finalization operation for the GNAT.Sockets package
883 procedure Finalize is
885 -- This is a dummy placeholder for an obsolete API.
886 -- The real finalization actions are in Initialize primitive operation
887 -- of Sockets_Library_Controller.
897 (Item : in out Socket_Set_Type;
898 Socket : out Socket_Type)
901 L : aliased C.int := C.int (Item.Last);
904 if Item.Last /= No_Socket then
906 (Item.Set'Access, Last => L'Access, Socket => S'Access);
907 Item.Last := Socket_Type (L);
908 Socket := Socket_Type (S);
919 (Stream : not null Stream_Access) return Sock_Addr_Type
922 if Stream.all in Datagram_Socket_Stream_Type then
923 return Datagram_Socket_Stream_Type (Stream.all).From;
925 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
929 -------------------------
930 -- Get_Host_By_Address --
931 -------------------------
933 function Get_Host_By_Address
934 (Address : Inet_Addr_Type;
935 Family : Family_Type := Family_Inet) return Host_Entry_Type
937 pragma Unreferenced (Family);
939 HA : aliased In_Addr := To_In_Addr (Address);
940 Buflen : constant C.int := Netdb_Buffer_Size;
941 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
942 Res : aliased Hostent;
948 if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET,
949 Res'Access, Buf'Address, Buflen, Err'Access) /= 0
952 Raise_Host_Error (Integer (Err));
955 return H : constant Host_Entry_Type :=
956 To_Host_Entry (Res'Unchecked_Access)
960 end Get_Host_By_Address;
962 ----------------------
963 -- Get_Host_By_Name --
964 ----------------------
966 function Get_Host_By_Name (Name : String) return Host_Entry_Type is
968 -- Detect IP address name and redirect to Inet_Addr
970 if Is_IP_Address (Name) then
971 return Get_Host_By_Address (Inet_Addr (Name));
975 HN : constant C.char_array := C.To_C (Name);
976 Buflen : constant C.int := Netdb_Buffer_Size;
977 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
978 Res : aliased Hostent;
985 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
988 Raise_Host_Error (Integer (Err));
991 return H : constant Host_Entry_Type :=
992 To_Host_Entry (Res'Unchecked_Access)
997 end Get_Host_By_Name;
1003 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
1004 Sin : aliased Sockaddr_In;
1005 Len : aliased C.int := Sin'Size / 8;
1006 Res : Sock_Addr_Type (Family_Inet);
1009 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
1010 Raise_Socket_Error (Socket_Errno);
1013 To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
1014 Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1019 -------------------------
1020 -- Get_Service_By_Name --
1021 -------------------------
1023 function Get_Service_By_Name
1025 Protocol : String) return Service_Entry_Type
1027 SN : constant C.char_array := C.To_C (Name);
1028 SP : constant C.char_array := C.To_C (Protocol);
1029 Buflen : constant C.int := Netdb_Buffer_Size;
1030 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1031 Res : aliased Servent;
1036 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1038 raise Service_Error with "Service not found";
1041 -- Translate from the C format to the API format
1043 return S : constant Service_Entry_Type :=
1044 To_Service_Entry (Res'Unchecked_Access)
1048 end Get_Service_By_Name;
1050 -------------------------
1051 -- Get_Service_By_Port --
1052 -------------------------
1054 function Get_Service_By_Port
1056 Protocol : String) return Service_Entry_Type
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;
1067 (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1068 Res'Access, Buf'Address, Buflen) /= 0
1071 raise Service_Error with "Service not found";
1074 -- Translate from the C format to the API format
1076 return S : constant Service_Entry_Type :=
1077 To_Service_Entry (Res'Unchecked_Access)
1081 end Get_Service_By_Port;
1083 ---------------------
1084 -- Get_Socket_Name --
1085 ---------------------
1087 function Get_Socket_Name
1088 (Socket : Socket_Type) return Sock_Addr_Type
1090 Sin : aliased Sockaddr_In;
1091 Len : aliased C.int := Sin'Size / 8;
1093 Addr : Sock_Addr_Type := No_Sock_Addr;
1096 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1098 if Res /= Failure then
1099 To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
1100 Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1104 end Get_Socket_Name;
1106 -----------------------
1107 -- Get_Socket_Option --
1108 -----------------------
1110 function Get_Socket_Option
1111 (Socket : Socket_Type;
1112 Level : Level_Type := Socket_Level;
1113 Name : Option_Name) return Option_Type
1115 use type C.unsigned_char;
1117 V8 : aliased Two_Ints;
1119 V1 : aliased C.unsigned_char;
1120 VT : aliased Timeval;
1121 Len : aliased C.int;
1122 Add : System.Address;
1124 Opt : Option_Type (Name);
1128 when Multicast_Loop |
1130 Receive_Packet_Info =>
1165 if Res = Failure then
1166 Raise_Socket_Error (Socket_Errno);
1174 Opt.Enabled := (V4 /= 0);
1177 Opt.Enabled := (V8 (V8'First) /= 0);
1178 Opt.Seconds := Natural (V8 (V8'Last));
1182 Opt.Size := Natural (V4);
1185 Opt.Error := Resolve_Error (Integer (V4));
1187 when Add_Membership |
1189 To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1190 To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1192 when Multicast_If =>
1193 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1195 when Multicast_TTL =>
1196 Opt.Time_To_Live := Integer (V1);
1198 when Multicast_Loop |
1199 Receive_Packet_Info =>
1200 Opt.Enabled := (V1 /= 0);
1204 Opt.Timeout := To_Duration (VT);
1208 end Get_Socket_Option;
1214 function Host_Name return String is
1215 Name : aliased C.char_array (1 .. 64);
1219 Res := C_Gethostname (Name'Address, Name'Length);
1221 if Res = Failure then
1222 Raise_Socket_Error (Socket_Errno);
1225 return C.To_Ada (Name);
1233 (Val : Inet_Addr_VN_Type;
1234 Hex : Boolean := False) return String
1236 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1237 -- has at most a length of 3 plus one '.' character.
1239 Buffer : String (1 .. 4 * Val'Length);
1240 Length : Natural := 1;
1241 Separator : Character;
1243 procedure Img10 (V : Inet_Addr_Comp_Type);
1244 -- Append to Buffer image of V in decimal format
1246 procedure Img16 (V : Inet_Addr_Comp_Type);
1247 -- Append to Buffer image of V in hexadecimal format
1253 procedure Img10 (V : Inet_Addr_Comp_Type) is
1254 Img : constant String := V'Img;
1255 Len : constant Natural := Img'Length - 1;
1257 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1258 Length := Length + Len;
1265 procedure Img16 (V : Inet_Addr_Comp_Type) is
1267 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
1268 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1269 Length := Length + 2;
1272 -- Start of processing for Image
1275 Separator := (if Hex then ':' else '.');
1277 for J in Val'Range loop
1284 if J /= Val'Last then
1285 Buffer (Length) := Separator;
1286 Length := Length + 1;
1290 return Buffer (1 .. Length - 1);
1297 function Image (Value : Inet_Addr_Type) return String is
1299 if Value.Family = Family_Inet then
1300 return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1302 return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1310 function Image (Value : Sock_Addr_Type) return String is
1311 Port : constant String := Value.Port'Img;
1313 return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1320 function Image (Socket : Socket_Type) return String is
1329 function Image (Item : Socket_Set_Type) return String is
1330 Socket_Set : Socket_Set_Type := Item;
1334 Last_Img : constant String := Socket_Set.Last'Img;
1336 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1337 Index : Positive := 1;
1338 Socket : Socket_Type;
1341 while not Is_Empty (Socket_Set) loop
1342 Get (Socket_Set, Socket);
1345 Socket_Img : constant String := Socket'Img;
1347 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1348 Index := Index + Socket_Img'Length;
1352 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1360 function Inet_Addr (Image : String) return Inet_Addr_Type is
1362 use Interfaces.C.Strings;
1364 Img : aliased char_array := To_C (Image);
1365 Addr : aliased C.int;
1367 Result : Inet_Addr_Type;
1370 -- Special case for an empty Image as on some platforms (e.g. Windows)
1371 -- calling Inet_Addr("") will not return an error.
1374 Raise_Socket_Error (SOSC.EINVAL);
1377 Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address);
1380 Raise_Socket_Error (Socket_Errno);
1383 Raise_Socket_Error (SOSC.EINVAL);
1386 To_Inet_Addr (To_In_Addr (Addr), Result);
1394 procedure Initialize (X : in out Sockets_Library_Controller) is
1395 pragma Unreferenced (X);
1405 procedure Initialize (Process_Blocking_IO : Boolean) is
1406 Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1409 if Process_Blocking_IO /= Expected then
1410 raise Socket_Error with
1411 "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1414 -- This is a dummy placeholder for an obsolete API
1416 -- Real initialization actions are in Initialize primitive operation
1417 -- of Sockets_Library_Controller.
1426 procedure Initialize is
1428 -- This is a dummy placeholder for an obsolete API
1430 -- Real initialization actions are in Initialize primitive operation
1431 -- of Sockets_Library_Controller.
1440 function Is_Empty (Item : Socket_Set_Type) return Boolean is
1442 return Item.Last = No_Socket;
1449 function Is_IP_Address (Name : String) return Boolean is
1451 for J in Name'Range loop
1453 and then Name (J) not in '0' .. '9'
1466 function Is_Open (S : Selector_Type) return Boolean is
1472 -- Either both controlling socket descriptors are valid (case of an
1473 -- open selector) or neither (case of a closed selector).
1475 pragma Assert ((S.R_Sig_Socket /= No_Socket)
1477 (S.W_Sig_Socket /= No_Socket));
1479 return S.R_Sig_Socket /= No_Socket;
1488 (Item : Socket_Set_Type;
1489 Socket : Socket_Type) return Boolean
1492 Check_For_Fd_Set (Socket);
1494 return Item.Last /= No_Socket
1495 and then Socket <= Item.Last
1496 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1503 procedure Listen_Socket
1504 (Socket : Socket_Type;
1505 Length : Natural := 15)
1507 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1509 if Res = Failure then
1510 Raise_Socket_Error (Socket_Errno);
1518 procedure Narrow (Item : in out Socket_Set_Type) is
1519 Last : aliased C.int := C.int (Item.Last);
1521 if Item.Last /= No_Socket then
1522 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1523 Item.Last := Socket_Type (Last);
1531 procedure Netdb_Lock is
1533 if Need_Netdb_Lock then
1534 System.Task_Lock.Lock;
1542 procedure Netdb_Unlock is
1544 if Need_Netdb_Lock then
1545 System.Task_Lock.Unlock;
1549 --------------------------------
1550 -- Normalize_Empty_Socket_Set --
1551 --------------------------------
1553 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1555 if S.Last = No_Socket then
1556 Reset_Socket_Set (S.Set'Access);
1558 end Normalize_Empty_Socket_Set;
1564 function Official_Name (E : Host_Entry_Type) return String is
1566 return To_String (E.Official);
1573 function Official_Name (S : Service_Entry_Type) return String is
1575 return To_String (S.Official);
1578 --------------------
1579 -- Wait_On_Socket --
1580 --------------------
1582 procedure Wait_On_Socket
1583 (Socket : Socket_Type;
1585 Timeout : Selector_Duration;
1586 Selector : access Selector_Type := null;
1587 Status : out Selector_Status)
1589 type Local_Selector_Access is access Selector_Type;
1590 for Local_Selector_Access'Storage_Size use Selector_Type'Size;
1592 S : Selector_Access;
1593 -- Selector to use for waiting
1595 R_Fd_Set : Socket_Set_Type;
1596 W_Fd_Set : Socket_Set_Type;
1599 -- Create selector if not provided by the user
1601 if Selector = null then
1603 Local_S : constant Local_Selector_Access := new Selector_Type;
1605 S := Local_S.all'Unchecked_Access;
1606 Create_Selector (S.all);
1610 S := Selector.all'Access;
1614 Set (R_Fd_Set, Socket);
1616 Set (W_Fd_Set, Socket);
1619 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
1621 if Selector = null then
1622 Close_Selector (S.all);
1630 function Port_Number (S : Service_Entry_Type) return Port_Type is
1639 function Protocol_Name (S : Service_Entry_Type) return String is
1641 return To_String (S.Protocol);
1644 ----------------------
1645 -- Raise_Host_Error --
1646 ----------------------
1648 procedure Raise_Host_Error (H_Error : Integer) is
1650 raise Host_Error with
1651 Err_Code_Image (H_Error)
1652 & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error));
1653 end Raise_Host_Error;
1655 ------------------------
1656 -- Raise_Socket_Error --
1657 ------------------------
1659 procedure Raise_Socket_Error (Error : Integer) is
1660 use type C.Strings.chars_ptr;
1662 raise Socket_Error with
1663 Err_Code_Image (Error)
1664 & C.Strings.Value (Socket_Error_Message (Error));
1665 end Raise_Socket_Error;
1672 (Stream : in out Datagram_Socket_Stream_Type;
1673 Item : out Ada.Streams.Stream_Element_Array;
1674 Last : out Ada.Streams.Stream_Element_Offset)
1676 First : Ada.Streams.Stream_Element_Offset := Item'First;
1677 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1678 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1684 Item (First .. Max),
1690 -- Exit when all or zero data received. Zero means that the socket
1693 exit when Index < First or else Index = Max;
1704 (Stream : in out Stream_Socket_Stream_Type;
1705 Item : out Ada.Streams.Stream_Element_Array;
1706 Last : out Ada.Streams.Stream_Element_Offset)
1708 pragma Warnings (Off, Stream);
1710 First : Ada.Streams.Stream_Element_Offset := Item'First;
1711 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1712 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1716 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1719 -- Exit when all or zero data received. Zero means that the socket
1722 exit when Index < First or else Index = Max;
1728 --------------------
1729 -- Receive_Socket --
1730 --------------------
1732 procedure Receive_Socket
1733 (Socket : Socket_Type;
1734 Item : out Ada.Streams.Stream_Element_Array;
1735 Last : out Ada.Streams.Stream_Element_Offset;
1736 Flags : Request_Flag_Type := No_Request_Flag)
1742 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1744 if Res = Failure then
1745 Raise_Socket_Error (Socket_Errno);
1748 Last := Last_Index (First => Item'First, Count => size_t (Res));
1751 --------------------
1752 -- Receive_Socket --
1753 --------------------
1755 procedure Receive_Socket
1756 (Socket : Socket_Type;
1757 Item : out Ada.Streams.Stream_Element_Array;
1758 Last : out Ada.Streams.Stream_Element_Offset;
1759 From : out Sock_Addr_Type;
1760 Flags : Request_Flag_Type := No_Request_Flag)
1763 Sin : aliased Sockaddr_In;
1764 Len : aliased C.int := Sin'Size / 8;
1776 if Res = Failure then
1777 Raise_Socket_Error (Socket_Errno);
1780 Last := Last_Index (First => Item'First, Count => size_t (Res));
1782 To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1783 From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1786 --------------------
1787 -- Receive_Vector --
1788 --------------------
1790 procedure Receive_Vector
1791 (Socket : Socket_Type;
1792 Vector : Vector_Type;
1793 Count : out Ada.Streams.Stream_Element_Count;
1794 Flags : Request_Flag_Type := No_Request_Flag)
1799 (Msg_Name => System.Null_Address,
1801 Msg_Iov => Vector'Address,
1803 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1804 -- platforms) when the supplied vector is longer than IOV_MAX,
1805 -- so use minimum of the two lengths.
1807 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
1808 (Vector'Length, SOSC.IOV_MAX),
1810 Msg_Control => System.Null_Address,
1811 Msg_Controllen => 0,
1821 if Res = ssize_t (Failure) then
1822 Raise_Socket_Error (Socket_Errno);
1825 Count := Ada.Streams.Stream_Element_Count (Res);
1832 function Resolve_Error
1833 (Error_Value : Integer;
1834 From_Errno : Boolean := True) return Error_Type
1836 use GNAT.Sockets.SOSC;
1839 if not From_Errno then
1841 when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1842 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
1843 when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
1844 when SOSC.NO_DATA => return Unknown_Server_Error;
1845 when others => return Cannot_Resolve_Error;
1849 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1850 -- can't include it in the case statement below.
1852 pragma Warnings (Off);
1853 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1855 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1856 return Resource_Temporarily_Unavailable;
1859 -- This is not a case statement because if a particular error
1860 -- number constant is not defined, s-oscons-tmplt.c defines
1861 -- it to -1. If multiple constants are not defined, they
1862 -- would each be -1 and result in a "duplicate value in case" error.
1864 -- But we have to leave warnings off because the compiler is also
1865 -- smart enough to note that when two errnos have the same value,
1866 -- the second if condition is useless.
1867 if Error_Value = ENOERROR then
1869 elsif Error_Value = EACCES then
1870 return Permission_Denied;
1871 elsif Error_Value = EADDRINUSE then
1872 return Address_Already_In_Use;
1873 elsif Error_Value = EADDRNOTAVAIL then
1874 return Cannot_Assign_Requested_Address;
1875 elsif Error_Value = EAFNOSUPPORT then
1876 return Address_Family_Not_Supported_By_Protocol;
1877 elsif Error_Value = EALREADY then
1878 return Operation_Already_In_Progress;
1879 elsif Error_Value = EBADF then
1880 return Bad_File_Descriptor;
1881 elsif Error_Value = ECONNABORTED then
1882 return Software_Caused_Connection_Abort;
1883 elsif Error_Value = ECONNREFUSED then
1884 return Connection_Refused;
1885 elsif Error_Value = ECONNRESET then
1886 return Connection_Reset_By_Peer;
1887 elsif Error_Value = EDESTADDRREQ then
1888 return Destination_Address_Required;
1889 elsif Error_Value = EFAULT then
1891 elsif Error_Value = EHOSTDOWN then
1892 return Host_Is_Down;
1893 elsif Error_Value = EHOSTUNREACH then
1894 return No_Route_To_Host;
1895 elsif Error_Value = EINPROGRESS then
1896 return Operation_Now_In_Progress;
1897 elsif Error_Value = EINTR then
1898 return Interrupted_System_Call;
1899 elsif Error_Value = EINVAL then
1900 return Invalid_Argument;
1901 elsif Error_Value = EIO then
1902 return Input_Output_Error;
1903 elsif Error_Value = EISCONN then
1904 return Transport_Endpoint_Already_Connected;
1905 elsif Error_Value = ELOOP then
1906 return Too_Many_Symbolic_Links;
1907 elsif Error_Value = EMFILE then
1908 return Too_Many_Open_Files;
1909 elsif Error_Value = EMSGSIZE then
1910 return Message_Too_Long;
1911 elsif Error_Value = ENAMETOOLONG then
1912 return File_Name_Too_Long;
1913 elsif Error_Value = ENETDOWN then
1914 return Network_Is_Down;
1915 elsif Error_Value = ENETRESET then
1916 return Network_Dropped_Connection_Because_Of_Reset;
1917 elsif Error_Value = ENETUNREACH then
1918 return Network_Is_Unreachable;
1919 elsif Error_Value = ENOBUFS then
1920 return No_Buffer_Space_Available;
1921 elsif Error_Value = ENOPROTOOPT then
1922 return Protocol_Not_Available;
1923 elsif Error_Value = ENOTCONN then
1924 return Transport_Endpoint_Not_Connected;
1925 elsif Error_Value = ENOTSOCK then
1926 return Socket_Operation_On_Non_Socket;
1927 elsif Error_Value = EOPNOTSUPP then
1928 return Operation_Not_Supported;
1929 elsif Error_Value = EPFNOSUPPORT then
1930 return Protocol_Family_Not_Supported;
1931 elsif Error_Value = EPIPE then
1933 elsif Error_Value = EPROTONOSUPPORT then
1934 return Protocol_Not_Supported;
1935 elsif Error_Value = EPROTOTYPE then
1936 return Protocol_Wrong_Type_For_Socket;
1937 elsif Error_Value = ESHUTDOWN then
1938 return Cannot_Send_After_Transport_Endpoint_Shutdown;
1939 elsif Error_Value = ESOCKTNOSUPPORT then
1940 return Socket_Type_Not_Supported;
1941 elsif Error_Value = ETIMEDOUT then
1942 return Connection_Timed_Out;
1943 elsif Error_Value = ETOOMANYREFS then
1944 return Too_Many_References;
1945 elsif Error_Value = EWOULDBLOCK then
1946 return Resource_Temporarily_Unavailable;
1948 return Cannot_Resolve_Error;
1950 pragma Warnings (On);
1954 -----------------------
1955 -- Resolve_Exception --
1956 -----------------------
1958 function Resolve_Exception
1959 (Occurrence : Exception_Occurrence) return Error_Type
1961 Id : constant Exception_Id := Exception_Identity (Occurrence);
1962 Msg : constant String := Exception_Message (Occurrence);
1969 while First <= Msg'Last
1970 and then Msg (First) not in '0' .. '9'
1975 if First > Msg'Last then
1976 return Cannot_Resolve_Error;
1980 while Last < Msg'Last
1981 and then Msg (Last + 1) in '0' .. '9'
1986 Val := Integer'Value (Msg (First .. Last));
1988 if Id = Socket_Error_Id then
1989 return Resolve_Error (Val);
1991 elsif Id = Host_Error_Id then
1992 return Resolve_Error (Val, False);
1995 return Cannot_Resolve_Error;
1997 end Resolve_Exception;
2003 procedure Send_Socket
2004 (Socket : Socket_Type;
2005 Item : Ada.Streams.Stream_Element_Array;
2006 Last : out Ada.Streams.Stream_Element_Offset;
2007 Flags : Request_Flag_Type := No_Request_Flag)
2010 Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2017 procedure Send_Socket
2018 (Socket : Socket_Type;
2019 Item : Ada.Streams.Stream_Element_Array;
2020 Last : out Ada.Streams.Stream_Element_Offset;
2021 To : Sock_Addr_Type;
2022 Flags : Request_Flag_Type := No_Request_Flag)
2026 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2033 procedure Send_Socket
2034 (Socket : Socket_Type;
2035 Item : Ada.Streams.Stream_Element_Array;
2036 Last : out Ada.Streams.Stream_Element_Offset;
2037 To : access Sock_Addr_Type;
2038 Flags : Request_Flag_Type := No_Request_Flag)
2042 Sin : aliased Sockaddr_In;
2043 C_To : System.Address;
2048 Set_Family (Sin.Sin_Family, To.Family);
2049 Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
2051 (Sin'Unchecked_Access,
2052 Short_To_Network (C.unsigned_short (To.Port)));
2053 C_To := Sin'Address;
2054 Len := Sin'Size / 8;
2057 C_To := System.Null_Address;
2065 Set_Forced_Flags (To_Int (Flags)),
2069 if Res = Failure then
2070 Raise_Socket_Error (Socket_Errno);
2073 Last := Last_Index (First => Item'First, Count => size_t (Res));
2080 procedure Send_Vector
2081 (Socket : Socket_Type;
2082 Vector : Vector_Type;
2083 Count : out Ada.Streams.Stream_Element_Count;
2084 Flags : Request_Flag_Type := No_Request_Flag)
2090 Iov_Count : SOSC.Msg_Iovlen_T;
2091 This_Iov_Count : SOSC.Msg_Iovlen_T;
2097 while Iov_Count < Vector'Length loop
2099 pragma Warnings (Off);
2100 -- Following test may be compile time known on some targets
2103 (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2105 else Vector'Length - Iov_Count);
2107 pragma Warnings (On);
2110 (Msg_Name => System.Null_Address,
2113 (Vector'First + Integer (Iov_Count))'Address,
2114 Msg_Iovlen => This_Iov_Count,
2115 Msg_Control => System.Null_Address,
2116 Msg_Controllen => 0,
2123 Set_Forced_Flags (To_Int (Flags)));
2125 if Res = ssize_t (Failure) then
2126 Raise_Socket_Error (Socket_Errno);
2129 Count := Count + Ada.Streams.Stream_Element_Count (Res);
2130 Iov_Count := Iov_Count + This_Iov_Count;
2138 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2140 Check_For_Fd_Set (Socket);
2142 if Item.Last = No_Socket then
2144 -- Uninitialized socket set, make sure it is properly zeroed out
2146 Reset_Socket_Set (Item.Set'Access);
2147 Item.Last := Socket;
2149 elsif Item.Last < Socket then
2150 Item.Last := Socket;
2153 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2156 ----------------------
2157 -- Set_Forced_Flags --
2158 ----------------------
2160 function Set_Forced_Flags (F : C.int) return C.int is
2161 use type C.unsigned;
2162 function To_unsigned is
2163 new Ada.Unchecked_Conversion (C.int, C.unsigned);
2165 new Ada.Unchecked_Conversion (C.unsigned, C.int);
2167 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2168 end Set_Forced_Flags;
2170 -----------------------
2171 -- Set_Socket_Option --
2172 -----------------------
2174 procedure Set_Socket_Option
2175 (Socket : Socket_Type;
2176 Level : Level_Type := Socket_Level;
2177 Option : Option_Type)
2179 V8 : aliased Two_Ints;
2181 V1 : aliased C.unsigned_char;
2182 VT : aliased Timeval;
2184 Add : System.Address := Null_Address;
2193 V4 := C.int (Boolean'Pos (Option.Enabled));
2198 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2199 V8 (V8'Last) := C.int (Option.Seconds);
2205 V4 := C.int (Option.Size);
2210 V4 := C.int (Boolean'Pos (True));
2214 when Add_Membership |
2216 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2217 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
2221 when Multicast_If =>
2222 V4 := To_Int (To_In_Addr (Option.Outgoing_If));
2226 when Multicast_TTL =>
2227 V1 := C.unsigned_char (Option.Time_To_Live);
2231 when Multicast_Loop |
2232 Receive_Packet_Info =>
2233 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
2239 VT := To_Timeval (Option.Timeout);
2248 Options (Option.Name),
2251 if Res = Failure then
2252 Raise_Socket_Error (Socket_Errno);
2254 end Set_Socket_Option;
2256 ----------------------
2257 -- Short_To_Network --
2258 ----------------------
2260 function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2261 use type C.unsigned_short;
2264 -- Big-endian case. No conversion needed. On these platforms,
2265 -- htons() defaults to a null procedure.
2267 pragma Warnings (Off);
2268 -- Since the test can generate "always True/False" warning
2270 if Default_Bit_Order = High_Order_First then
2273 pragma Warnings (On);
2275 -- Little-endian case. We must swap the high and low bytes of this
2276 -- short to make the port number network compliant.
2279 return (S / 256) + (S mod 256) * 256;
2281 end Short_To_Network;
2283 ---------------------
2284 -- Shutdown_Socket --
2285 ---------------------
2287 procedure Shutdown_Socket
2288 (Socket : Socket_Type;
2289 How : Shutmode_Type := Shut_Read_Write)
2294 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2296 if Res = Failure then
2297 Raise_Socket_Error (Socket_Errno);
2299 end Shutdown_Socket;
2306 (Socket : Socket_Type;
2307 Send_To : Sock_Addr_Type) return Stream_Access
2309 S : Datagram_Socket_Stream_Access;
2312 S := new Datagram_Socket_Stream_Type;
2315 S.From := Get_Socket_Name (Socket);
2316 return Stream_Access (S);
2323 function Stream (Socket : Socket_Type) return Stream_Access is
2324 S : Stream_Socket_Stream_Access;
2326 S := new Stream_Socket_Stream_Type;
2328 return Stream_Access (S);
2335 procedure Stream_Write
2336 (Socket : Socket_Type;
2337 Item : Ada.Streams.Stream_Element_Array;
2338 To : access Sock_Addr_Type)
2340 First : Ada.Streams.Stream_Element_Offset;
2341 Index : Ada.Streams.Stream_Element_Offset;
2342 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2345 First := Item'First;
2347 while First <= Max loop
2348 Send_Socket (Socket, Item (First .. Max), Index, To);
2350 -- Exit when all or zero data sent. Zero means that the socket has
2351 -- been closed by peer.
2353 exit when Index < First or else Index = Max;
2358 -- For an empty array, we have First > Max, and hence Index >= Max (no
2359 -- error, the loop above is never executed). After a successful send,
2360 -- Index = Max. The only remaining case, Index < Max, is therefore
2361 -- always an actual send failure.
2364 Raise_Socket_Error (Socket_Errno);
2372 function To_C (Socket : Socket_Type) return Integer is
2374 return Integer (Socket);
2381 function To_Duration (Val : Timeval) return Timeval_Duration is
2383 return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2390 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2394 Aliases_Count, Addresses_Count : Natural;
2396 -- H_Length is not used because it is currently only set to 4
2397 -- H_Addrtype is always AF_INET
2401 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2402 Aliases_Count := Aliases_Count + 1;
2405 Addresses_Count := 0;
2406 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2407 Addresses_Count := Addresses_Count + 1;
2410 return Result : Host_Entry_Type
2411 (Aliases_Length => Aliases_Count,
2412 Addresses_Length => Addresses_Count)
2414 Result.Official := To_Name (Value (Hostent_H_Name (E)));
2416 for J in Result.Aliases'Range loop
2417 Result.Aliases (J) :=
2418 To_Name (Value (Hostent_H_Alias
2419 (E, C.int (J - Result.Aliases'First))));
2422 for J in Result.Addresses'Range loop
2425 for Addr'Address use
2426 Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2427 pragma Import (Ada, Addr);
2429 To_Inet_Addr (Addr, Result.Addresses (J));
2439 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2441 if Addr.Family = Family_Inet then
2442 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2443 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2444 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2445 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2448 raise Socket_Error with "IPv6 not supported";
2455 procedure To_Inet_Addr
2457 Result : out Inet_Addr_Type) is
2459 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2460 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2461 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2462 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2469 function To_Int (F : Request_Flag_Type) return C.int
2471 Current : Request_Flag_Type := F;
2472 Result : C.int := 0;
2475 for J in Flags'Range loop
2476 exit when Current = 0;
2478 if Current mod 2 /= 0 then
2479 if Flags (J) = -1 then
2480 Raise_Socket_Error (SOSC.EOPNOTSUPP);
2483 Result := Result + Flags (J);
2486 Current := Current / 2;
2496 function To_Name (N : String) return Name_Type is
2498 return Name_Type'(N'Length, N);
2501 ----------------------
2502 -- To_Service_Entry --
2503 ----------------------
2505 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2509 Aliases_Count : Natural;
2513 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2514 Aliases_Count := Aliases_Count + 1;
2517 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2518 Result.Official := To_Name (Value (Servent_S_Name (E)));
2520 for J in Result.Aliases'Range loop
2521 Result.Aliases (J) :=
2522 To_Name (Value (Servent_S_Alias
2523 (E, C.int (J - Result.Aliases'First))));
2526 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2528 Port_Type (Network_To_Short (Servent_S_Port (E)));
2530 end To_Service_Entry;
2536 function To_String (HN : Name_Type) return String is
2538 return HN.Name (1 .. HN.Length);
2545 function To_Timeval (Val : Timeval_Duration) return Timeval is
2550 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2556 -- Normal case where we do round down
2559 S := time_t (Val - 0.5);
2560 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2570 function Value (S : System.Address) return String is
2571 Str : String (1 .. Positive'Last);
2572 for Str'Address use S;
2573 pragma Import (Ada, Str);
2575 Terminator : Positive := Str'First;
2578 while Str (Terminator) /= ASCII.NUL loop
2579 Terminator := Terminator + 1;
2582 return Str (1 .. Terminator - 1);
2590 (Stream : in out Datagram_Socket_Stream_Type;
2591 Item : Ada.Streams.Stream_Element_Array)
2594 Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2602 (Stream : in out Stream_Socket_Stream_Type;
2603 Item : Ada.Streams.Stream_Element_Array)
2606 Stream_Write (Stream.Socket, Item, To => null);
2609 Sockets_Library_Controller_Object : Sockets_Library_Controller;
2610 pragma Unreferenced (Sockets_Library_Controller_Object);
2611 -- The elaboration and finalization of this object perform the required
2612 -- initialization and cleanup actions for the sockets library.