1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2019, 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.Containers.Generic_Array_Sort;
35 with Ada.Finalization;
36 with Ada.Unchecked_Conversion;
38 with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
39 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
41 with GNAT.Sockets.Linker_Options;
42 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
43 -- Need to include pragma Linker_Options which is platform dependent
45 with System; use System;
46 with System.Communication; use System.Communication;
47 with System.CRTL; use System.CRTL;
48 with System.Task_Lock;
50 package body GNAT.Sockets is
52 package C renames Interfaces.C;
54 type IPV6_Mreq is record
55 ipv6mr_multiaddr : In6_Addr;
56 ipv6mr_interface : C.unsigned;
57 end record with Convention => C;
58 -- Record to Add/Drop_Membership for multicast in IPv6
60 ENOERROR : constant := 0;
62 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
63 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
64 -- The network database functions gethostbyname, gethostbyaddr,
65 -- getservbyname and getservbyport can either be guaranteed task safe by
66 -- the operating system, or else return data through a user-provided buffer
67 -- to ensure concurrent uses do not interfere.
69 -- Correspondence tables
71 Levels : constant array (Level_Type) of C.int :=
72 (Socket_Level => SOSC.SOL_SOCKET,
73 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
74 IP_Protocol_For_IPv6_Level => SOSC.IPPROTO_IPV6,
75 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
76 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP,
77 IP_Protocol_For_ICMP_Level => SOSC.IPPROTO_ICMP,
78 IP_Protocol_For_IGMP_Level => SOSC.IPPROTO_IGMP,
79 IP_Protocol_For_RAW_Level => SOSC.IPPROTO_RAW);
81 Modes : constant array (Mode_Type) of C.int :=
82 (Socket_Stream => SOSC.SOCK_STREAM,
83 Socket_Datagram => SOSC.SOCK_DGRAM,
84 Socket_Raw => SOSC.SOCK_RAW);
86 Shutmodes : constant array (Shutmode_Type) of C.int :=
87 (Shut_Read => SOSC.SHUT_RD,
88 Shut_Write => SOSC.SHUT_WR,
89 Shut_Read_Write => SOSC.SHUT_RDWR);
91 Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T :=
92 (Non_Blocking_IO => SOSC.FIONBIO,
93 N_Bytes_To_Read => SOSC.FIONREAD);
95 Options : constant array (Specific_Option_Name) of C.int :=
96 (Keep_Alive => SOSC.SO_KEEPALIVE,
97 Reuse_Address => SOSC.SO_REUSEADDR,
98 Broadcast => SOSC.SO_BROADCAST,
99 Send_Buffer => SOSC.SO_SNDBUF,
100 Receive_Buffer => SOSC.SO_RCVBUF,
101 Linger => SOSC.SO_LINGER,
102 Error => SOSC.SO_ERROR,
103 No_Delay => SOSC.TCP_NODELAY,
104 Add_Membership_V4 => SOSC.IP_ADD_MEMBERSHIP,
105 Drop_Membership_V4 => SOSC.IP_DROP_MEMBERSHIP,
106 Multicast_If_V4 => SOSC.IP_MULTICAST_IF,
107 Multicast_Loop_V4 => SOSC.IP_MULTICAST_LOOP,
108 Receive_Packet_Info => SOSC.IP_PKTINFO,
109 Multicast_TTL => SOSC.IP_MULTICAST_TTL,
110 Add_Membership_V6 => SOSC.IPV6_ADD_MEMBERSHIP,
111 Drop_Membership_V6 => SOSC.IPV6_DROP_MEMBERSHIP,
112 Multicast_If_V6 => SOSC.IPV6_MULTICAST_IF,
113 Multicast_Loop_V6 => SOSC.IPV6_MULTICAST_LOOP,
114 Multicast_Hops => SOSC.IPV6_MULTICAST_HOPS,
115 IPv6_Only => SOSC.IPV6_V6ONLY,
116 Send_Timeout => SOSC.SO_SNDTIMEO,
117 Receive_Timeout => SOSC.SO_RCVTIMEO,
118 Busy_Polling => SOSC.SO_BUSY_POLL);
119 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
120 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
122 Flags : constant array (0 .. 3) of C.int :=
123 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
124 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
125 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
126 3 => SOSC.MSG_EOR); -- Send_End_Of_Record
128 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
129 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
131 type In_Addr_Union (Family : Family_Inet_4_6) is record
138 end record with Unchecked_Union;
140 -----------------------
141 -- Local subprograms --
142 -----------------------
144 function Resolve_Error
145 (Error_Value : Integer;
146 From_Errno : Boolean := True) return Error_Type;
147 -- Associate an enumeration value (error_type) to an error value (errno).
148 -- From_Errno prevents from mixing h_errno with errno.
150 function To_Name (N : String) return Name_Type;
151 function To_String (HN : Name_Type) return String;
152 -- Conversion functions
154 function To_Int (F : Request_Flag_Type) return C.int;
155 -- Return the int value corresponding to the specified flags combination
157 function Set_Forced_Flags (F : C.int) return C.int;
158 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
160 procedure Netdb_Lock;
161 pragma Inline (Netdb_Lock);
162 procedure Netdb_Unlock;
163 pragma Inline (Netdb_Unlock);
164 -- Lock/unlock operation used to protect netdb access for platforms that
165 -- require such protection.
167 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
168 -- Conversion function
170 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
171 -- Conversion function
173 function Value (S : System.Address) return String;
174 -- Same as Interfaces.C.Strings.Value but taking a System.Address
176 function To_Timeval (Val : Timeval_Duration) return Timeval;
177 -- Separate Val in seconds and microseconds
179 function To_Duration (Val : Timeval) return Timeval_Duration;
180 -- Reconstruct a Duration value from a Timeval record (seconds and
183 function Dedot (Value : String) return String
184 is (if Value /= "" and then Value (Value'Last) = '.'
185 then Value (Value'First .. Value'Last - 1)
187 -- Removes dot at the end of error message
189 procedure Raise_Socket_Error (Error : Integer);
190 -- Raise Socket_Error with an exception message describing the error code
193 procedure Raise_Host_Error (H_Error : Integer; Name : String);
194 -- Raise Host_Error exception with message describing error code (note
195 -- hstrerror seems to be obsolete) from h_errno. Name is the name
196 -- or address that was being looked up.
198 procedure Raise_GAI_Error (RC : C.int; Name : String);
199 -- Raise Host_Error with exception message in case of errors in
200 -- getaddrinfo and getnameinfo.
202 function Is_Windows return Boolean with Inline;
203 -- Returns True on Windows platform
205 procedure Narrow (Item : in out Socket_Set_Type);
206 -- Update Last as it may be greater than the real last socket
208 procedure Check_For_Fd_Set (Fd : Socket_Type);
209 pragma Inline (Check_For_Fd_Set);
210 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
211 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
213 function Connect_Socket
214 (Socket : Socket_Type;
215 Server : Sock_Addr_Type) return C.int;
216 pragma Inline (Connect_Socket);
217 -- Underlying implementation for the Connect_Socket procedures
219 -- Types needed for Datagram_Socket_Stream_Type
221 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
222 Socket : Socket_Type;
224 From : Sock_Addr_Type;
227 type Datagram_Socket_Stream_Access is
228 access all Datagram_Socket_Stream_Type;
231 (Stream : in out Datagram_Socket_Stream_Type;
232 Item : out Ada.Streams.Stream_Element_Array;
233 Last : out Ada.Streams.Stream_Element_Offset);
236 (Stream : in out Datagram_Socket_Stream_Type;
237 Item : Ada.Streams.Stream_Element_Array);
239 -- Types needed for Stream_Socket_Stream_Type
241 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
242 Socket : Socket_Type;
245 type Stream_Socket_Stream_Access is
246 access all Stream_Socket_Stream_Type;
249 (Stream : in out Stream_Socket_Stream_Type;
250 Item : out Ada.Streams.Stream_Element_Array;
251 Last : out Ada.Streams.Stream_Element_Offset);
254 (Stream : in out Stream_Socket_Stream_Type;
255 Item : Ada.Streams.Stream_Element_Array);
257 procedure Wait_On_Socket
258 (Socket : Socket_Type;
260 Timeout : Selector_Duration;
261 Selector : access Selector_Type := null;
262 Status : out Selector_Status);
263 -- Common code for variants of socket operations supporting a timeout:
264 -- block in Check_Selector on Socket for at most the indicated timeout.
265 -- If For_Read is True, Socket is added to the read set for this call, else
266 -- it is added to the write set. If no selector is provided, a local one is
267 -- created for this call and destroyed prior to returning.
269 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
271 -- This type is used to generate automatic calls to Initialize and Finalize
272 -- during the elaboration and finalization of this package. A single object
273 -- of this type must exist at library level.
275 function Err_Code_Image (E : Integer) return String;
276 -- Return the value of E surrounded with brackets
278 procedure Initialize (X : in out Sockets_Library_Controller);
279 procedure Finalize (X : in out Sockets_Library_Controller);
281 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
282 -- If S is the empty set (detected by Last = No_Socket), make sure its
283 -- fd_set component is actually cleared. Note that the case where it is
284 -- not can occur for an uninitialized Socket_Set_Type object.
286 function Is_Open (S : Selector_Type) return Boolean;
287 -- Return True for an "open" Selector_Type object, i.e. one for which
288 -- Create_Selector has been called and Close_Selector has not been called,
289 -- or the null selector.
291 function Create_Address
292 (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
294 -- Creates address from family and Inet_Addr_Bytes array.
296 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes
298 -- Extract bytes from address
304 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
313 procedure Abort_Selector (Selector : Selector_Type) is
317 if not Is_Open (Selector) then
318 raise Program_Error with "closed selector";
320 elsif Selector.Is_Null then
321 raise Program_Error with "null selector";
325 -- Send one byte to unblock select system call
327 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
329 if Res = Failure then
330 Raise_Socket_Error (Socket_Errno);
338 procedure Accept_Socket
339 (Server : Socket_Type;
340 Socket : out Socket_Type;
341 Address : out Sock_Addr_Type)
344 Sin : aliased Sockaddr;
345 Len : aliased C.int := Sin'Size / 8;
348 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
350 if Res = Failure then
351 Raise_Socket_Error (Socket_Errno);
354 Socket := Socket_Type (Res);
355 Address := Get_Address (Sin, Len);
362 procedure Accept_Socket
363 (Server : Socket_Type;
364 Socket : out Socket_Type;
365 Address : out Sock_Addr_Type;
366 Timeout : Selector_Duration;
367 Selector : access Selector_Type := null;
368 Status : out Selector_Status)
371 if Selector /= null and then not Is_Open (Selector.all) then
372 raise Program_Error with "closed selector";
375 -- Wait for socket to become available for reading
381 Selector => Selector,
384 -- Accept connection if available
386 if Status = Completed then
387 Accept_Socket (Server, Socket, Address);
398 (E : Host_Entry_Type;
399 N : Positive := 1) return Inet_Addr_Type
402 return E.Addresses (N);
405 ----------------------
406 -- Addresses_Length --
407 ----------------------
409 function Addresses_Length (E : Host_Entry_Type) return Natural is
411 return E.Addresses_Length;
412 end Addresses_Length;
419 (E : Host_Entry_Type;
420 N : Positive := 1) return String
423 return To_String (E.Aliases (N));
431 (S : Service_Entry_Type;
432 N : Positive := 1) return String
435 return To_String (S.Aliases (N));
442 function Aliases_Length (E : Host_Entry_Type) return Natural is
444 return E.Aliases_Length;
451 function Aliases_Length (S : Service_Entry_Type) return Natural is
453 return S.Aliases_Length;
460 procedure Bind_Socket
461 (Socket : Socket_Type;
462 Address : Sock_Addr_Type)
465 Sin : aliased Sockaddr;
469 Set_Address (Sin'Unchecked_Access, Address, Len);
471 Res := C_Bind (C.int (Socket), Sin'Address, Len);
473 if Res = Failure then
474 Raise_Socket_Error (Socket_Errno);
478 ----------------------
479 -- Check_For_Fd_Set --
480 ----------------------
482 procedure Check_For_Fd_Set (Fd : Socket_Type) is
484 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
485 -- no check required. Warnings suppressed because condition
486 -- is known at compile time.
492 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
493 -- that Fd is within range (otherwise behavior is undefined).
495 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
496 raise Constraint_Error
497 with "invalid value for socket set: " & Image (Fd);
499 end Check_For_Fd_Set;
505 procedure Check_Selector
506 (Selector : Selector_Type;
507 R_Socket_Set : in out Socket_Set_Type;
508 W_Socket_Set : in out Socket_Set_Type;
509 Status : out Selector_Status;
510 Timeout : Selector_Duration := Forever)
512 E_Socket_Set : Socket_Set_Type;
515 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
518 procedure Check_Selector
519 (Selector : Selector_Type;
520 R_Socket_Set : in out Socket_Set_Type;
521 W_Socket_Set : in out Socket_Set_Type;
522 E_Socket_Set : in out Socket_Set_Type;
523 Status : out Selector_Status;
524 Timeout : Selector_Duration := Forever)
528 RSig : Socket_Type := No_Socket;
529 TVal : aliased Timeval;
530 TPtr : Timeval_Access;
533 if not Is_Open (Selector) then
534 raise Program_Error with "closed selector";
539 -- No timeout or Forever is indicated by a null timeval pointer
541 if Timeout = Forever then
544 TVal := To_Timeval (Timeout);
545 TPtr := TVal'Unchecked_Access;
548 -- Add read signalling socket, if present
550 if not Selector.Is_Null then
551 RSig := Selector.R_Sig_Socket;
552 Set (R_Socket_Set, RSig);
555 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
556 C.int (W_Socket_Set.Last)),
557 C.int (E_Socket_Set.Last));
559 -- Zero out fd_set for empty Socket_Set_Type objects
561 Normalize_Empty_Socket_Set (R_Socket_Set);
562 Normalize_Empty_Socket_Set (W_Socket_Set);
563 Normalize_Empty_Socket_Set (E_Socket_Set);
568 R_Socket_Set.Set'Access,
569 W_Socket_Set.Set'Access,
570 E_Socket_Set.Set'Access,
573 if Res = Failure then
574 Raise_Socket_Error (Socket_Errno);
577 -- If Select was resumed because of read signalling socket, read this
578 -- data and remove socket from set.
580 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
581 Clear (R_Socket_Set, RSig);
583 Res := Signalling_Fds.Read (C.int (RSig));
585 if Res = Failure then
586 Raise_Socket_Error (Socket_Errno);
595 -- Update socket sets in regard to their new contents
597 Narrow (R_Socket_Set);
598 Narrow (W_Socket_Set);
599 Narrow (E_Socket_Set);
607 (Item : in out Socket_Set_Type;
608 Socket : Socket_Type)
610 Last : aliased C.int := C.int (Item.Last);
613 Check_For_Fd_Set (Socket);
615 if Item.Last /= No_Socket then
616 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
617 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
618 Item.Last := Socket_Type (Last);
626 procedure Close_Selector (Selector : in out Selector_Type) is
628 -- Nothing to do if selector already in closed state
630 if Selector.Is_Null or else not Is_Open (Selector) then
634 -- Close the signalling file descriptors used internally for the
635 -- implementation of Abort_Selector.
637 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
638 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
640 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
641 -- (erroneous) subsequent attempt to use this selector properly fails.
643 Selector.R_Sig_Socket := No_Socket;
644 Selector.W_Sig_Socket := No_Socket;
651 procedure Close_Socket (Socket : Socket_Type) is
655 Res := C_Close (C.int (Socket));
657 if Res = Failure then
658 Raise_Socket_Error (Socket_Errno);
666 function Connect_Socket
667 (Socket : Socket_Type;
668 Server : Sock_Addr_Type) return C.int
670 Sin : aliased Sockaddr;
673 Set_Address (Sin'Unchecked_Access, Server, Len);
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);
839 pragma Annotate (CodePeer, Modified, Two_Fds);
841 if Res = Failure then
842 Raise_Socket_Error (Socket_Errno);
845 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
846 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
853 procedure Create_Socket
854 (Socket : out Socket_Type;
855 Family : Family_Type := Family_Inet;
856 Mode : Mode_Type := Socket_Stream;
857 Level : Level_Type := IP_Protocol_For_IP_Level)
862 Res := C_Socket (Families (Family), Modes (Mode), Levels (Level));
864 if Res = Failure then
865 Raise_Socket_Error (Socket_Errno);
868 Socket := Socket_Type (Res);
871 ------------------------
872 -- Create_Socket_Pair --
873 ------------------------
875 procedure Create_Socket_Pair
876 (Left : out Socket_Type;
877 Right : out Socket_Type;
878 Family : Family_Type := Family_Unspec;
879 Mode : Mode_Type := Socket_Stream;
880 Level : Level_Type := IP_Protocol_For_IP_Level)
883 Pair : aliased Thin_Common.Fd_Pair;
887 ((if Family = Family_Unspec then Default_Socket_Pair_Family
888 else Families (Family)),
889 Modes (Mode), Levels (Level), Pair'Access);
890 pragma Annotate (CodePeer, Modified, Pair);
892 if Res = Failure then
893 Raise_Socket_Error (Socket_Errno);
896 Left := Socket_Type (Pair (Pair'First));
897 Right := Socket_Type (Pair (Pair'Last));
898 end Create_Socket_Pair;
904 procedure Empty (Item : out Socket_Set_Type) is
906 Reset_Socket_Set (Item.Set'Access);
907 Item.Last := No_Socket;
914 function Err_Code_Image (E : Integer) return String is
915 Msg : String := E'Img & "] ";
917 Msg (Msg'First) := '[';
925 procedure Finalize (X : in out Sockets_Library_Controller) is
926 pragma Unreferenced (X);
929 -- Finalization operation for the GNAT.Sockets package
938 procedure Finalize is
940 -- This is a dummy placeholder for an obsolete API.
941 -- The real finalization actions are in Initialize primitive operation
942 -- of Sockets_Library_Controller.
952 (Item : in out Socket_Set_Type;
953 Socket : out Socket_Type)
956 L : aliased C.int := C.int (Item.Last);
959 if Item.Last /= No_Socket then
961 (Item.Set'Access, Last => L'Access, Socket => S'Access);
962 pragma Annotate (CodePeer, Modified, L);
963 pragma Annotate (CodePeer, Modified, S);
965 Item.Last := Socket_Type (L);
966 Socket := Socket_Type (S);
978 (Stream : not null Stream_Access) return Sock_Addr_Type
981 if Stream.all in Datagram_Socket_Stream_Type then
982 return Datagram_Socket_Stream_Type (Stream.all).From;
984 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
988 ---------------------
989 -- Raise_GAI_Error --
990 ---------------------
992 procedure Raise_GAI_Error (RC : C.int; Name : String) is
994 if RC = SOSC.EAI_SYSTEM then
996 Errcode : constant Integer := Socket_Errno;
998 raise Host_Error with Err_Code_Image (Errcode)
999 & Dedot (Socket_Error_Message (Errcode)) & ": " & Name;
1002 raise Host_Error with Err_Code_Image (Integer (RC))
1003 & Dedot (CS.Value (C_GAI_Strerror (RC))) & ": " & Name;
1005 end Raise_GAI_Error;
1007 ----------------------
1008 -- Get_Address_Info --
1009 ----------------------
1011 function Get_Address_Info
1014 Family : Family_Type := Family_Unspec;
1015 Mode : Mode_Type := Socket_Stream;
1016 Level : Level_Type := IP_Protocol_For_IP_Level;
1017 Numeric_Host : Boolean := False;
1018 Passive : Boolean := False;
1019 Unknown : access procedure
1020 (Family, Mode, Level, Length : Integer) := null)
1021 return Address_Info_Array
1023 A : aliased Addrinfo_Access;
1024 N : aliased C.char_array := C.To_C (Host);
1025 S : aliased C.char_array := C.To_C (if Service = "" then "0"
1027 Hints : aliased constant Addrinfo :=
1028 (ai_family => Families (Family),
1029 ai_socktype => Modes (Mode),
1030 ai_protocol => Levels (Level),
1031 ai_flags => (if Numeric_Host then SOSC.AI_NUMERICHOST else 0) +
1032 (if Passive then SOSC.AI_PASSIVE else 0),
1037 Iter : Addrinfo_Access;
1040 function To_Array return Address_Info_Array;
1041 -- Convert taken from OS addrinfo list A into Address_Info_Array
1047 function To_Array return Address_Info_Array is
1048 Result : Address_Info_Array (1 .. 8);
1050 procedure Unsupported;
1051 -- Calls Unknown callback if defiend
1057 procedure Unsupported is
1059 if Unknown /= null then
1061 (Integer (Iter.ai_family),
1062 Integer (Iter.ai_socktype),
1063 Integer (Iter.ai_protocol),
1064 Integer (Iter.ai_addrlen));
1068 -- Start of processing for To_Array
1071 for J in Result'Range loop
1072 Look_For_Supported : loop
1075 (Off, "may be referenced before it has a value");
1077 return Result (1 .. J - 1);
1080 (On, "may be referenced before it has a value");
1084 Get_Address (Iter.ai_addr.all, C.int (Iter.ai_addrlen));
1086 if Result (J).Addr.Family = Family_Unspec then
1089 for M in Modes'Range loop
1091 if Modes (M) = Iter.ai_socktype then
1092 Result (J).Mode := M;
1099 for L in Levels'Range loop
1100 if Levels (L) = Iter.ai_protocol then
1101 Result (J).Level := L;
1106 exit Look_For_Supported;
1112 Iter := Iter.ai_next;
1113 end loop Look_For_Supported;
1115 Iter := Iter.ai_next;
1118 return Result & To_Array;
1121 -- Start of processing for Get_Address_Info
1125 (Node => (if Host = "" then null else N'Unchecked_Access),
1126 Service => S'Unchecked_Access,
1127 Hints => Hints'Unchecked_Access,
1132 (R, Host & (if Service = "" then "" else ':' & Service));
1137 return Result : constant Address_Info_Array := To_Array do
1140 end Get_Address_Info;
1147 (Addr_Info : in out Address_Info_Array;
1148 Compare : access function (Left, Right : Address_Info) return Boolean)
1150 function Comp (Left, Right : Address_Info) return Boolean is
1151 (Compare (Left, Right));
1152 procedure Sorter is new Ada.Containers.Generic_Array_Sort
1153 (Positive, Address_Info, Address_Info_Array, Comp);
1158 ------------------------
1159 -- IPv6_TCP_Preferred --
1160 ------------------------
1162 function IPv6_TCP_Preferred (Left, Right : Address_Info) return Boolean is
1164 pragma Assert (Family_Inet < Family_Inet6);
1165 -- To be sure that Family_Type enumeration has appropriate elements
1168 if Left.Addr.Family /= Right.Addr.Family then
1169 return Left.Addr.Family > Right.Addr.Family;
1172 pragma Assert (Socket_Stream < Socket_Datagram);
1173 -- To be sure that Mode_Type enumeration has appropriate elements order
1175 return Left.Mode < Right.Mode;
1176 end IPv6_TCP_Preferred;
1182 function Get_Name_Info
1183 (Addr : Sock_Addr_Type;
1184 Numeric_Host : Boolean := False;
1185 Numeric_Serv : Boolean := False) return Host_Service
1187 SA : aliased Sockaddr;
1188 H : aliased C.char_array := (1 .. SOSC.NI_MAXHOST => C.nul);
1189 S : aliased C.char_array := (1 .. SOSC.NI_MAXSERV => C.nul);
1193 Set_Address (SA'Unchecked_Access, Addr, Len);
1196 (SA'Unchecked_Access, socklen_t (Len),
1197 H'Unchecked_Access, H'Length,
1198 S'Unchecked_Access, S'Length,
1199 (if Numeric_Host then SOSC.NI_NUMERICHOST else 0) +
1200 (if Numeric_Serv then SOSC.NI_NUMERICSERV else 0));
1203 Raise_GAI_Error (RC, Image (Addr));
1207 HR : constant String := C.To_Ada (H);
1208 SR : constant String := C.To_Ada (S);
1210 return (HR'Length, SR'Length, HR, SR);
1214 -------------------------
1215 -- Get_Host_By_Address --
1216 -------------------------
1218 function Get_Host_By_Address
1219 (Address : Inet_Addr_Type;
1220 Family : Family_Type := Family_Inet) return Host_Entry_Type
1222 pragma Unreferenced (Family);
1224 HA : aliased In_Addr_Union (Address.Family);
1225 Buflen : constant C.int := Netdb_Buffer_Size;
1226 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1227 Res : aliased Hostent;
1228 Err : aliased C.int;
1231 case Address.Family is
1233 HA.In4 := To_In_Addr (Address);
1234 when Family_Inet6 =>
1235 HA.In6 := To_In6_Addr (Address);
1242 (case Address.Family is
1243 when Family_Inet => HA.In4'Size,
1244 when Family_Inet6 => HA.In6'Size) / 8,
1245 Families (Address.Family),
1246 Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1249 Raise_Host_Error (Integer (Err), Image (Address));
1253 return H : constant Host_Entry_Type :=
1254 To_Host_Entry (Res'Unchecked_Access)
1263 end Get_Host_By_Address;
1265 ----------------------
1266 -- Get_Host_By_Name --
1267 ----------------------
1269 function Get_Host_By_Name (Name : String) return Host_Entry_Type is
1271 -- If the given name actually is the string representation of
1272 -- an IP address, use Get_Host_By_Address instead.
1274 if Is_IPv4_Address (Name) or else Is_IPv6_Address (Name) then
1275 return Get_Host_By_Address (Inet_Addr (Name));
1279 HN : constant C.char_array := C.To_C (Name);
1280 Buflen : constant C.int := Netdb_Buffer_Size;
1281 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1282 Res : aliased Hostent;
1283 Err : aliased C.int;
1289 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1292 Raise_Host_Error (Integer (Err), Name);
1295 return H : constant Host_Entry_Type :=
1296 To_Host_Entry (Res'Unchecked_Access)
1301 end Get_Host_By_Name;
1307 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
1308 Sin : aliased Sockaddr;
1309 Len : aliased C.int := Sin'Size / 8;
1311 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
1312 Raise_Socket_Error (Socket_Errno);
1315 return Get_Address (Sin, Len);
1318 -------------------------
1319 -- Get_Service_By_Name --
1320 -------------------------
1322 function Get_Service_By_Name
1324 Protocol : String) return Service_Entry_Type
1326 SN : constant C.char_array := C.To_C (Name);
1327 SP : constant C.char_array := C.To_C (Protocol);
1328 Buflen : constant C.int := Netdb_Buffer_Size;
1329 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1330 Res : aliased Servent;
1335 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1337 raise Service_Error with "Service not found";
1340 -- Translate from the C format to the API format
1342 return S : constant Service_Entry_Type :=
1343 To_Service_Entry (Res'Unchecked_Access)
1347 end Get_Service_By_Name;
1349 -------------------------
1350 -- Get_Service_By_Port --
1351 -------------------------
1353 function Get_Service_By_Port
1355 Protocol : String) return Service_Entry_Type
1357 SP : constant C.char_array := C.To_C (Protocol);
1358 Buflen : constant C.int := Netdb_Buffer_Size;
1359 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
1360 Res : aliased Servent;
1366 (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1367 Res'Access, Buf'Address, Buflen) /= 0
1370 raise Service_Error with "Service not found";
1373 -- Translate from the C format to the API format
1375 return S : constant Service_Entry_Type :=
1376 To_Service_Entry (Res'Unchecked_Access)
1380 end Get_Service_By_Port;
1382 ---------------------
1383 -- Get_Socket_Name --
1384 ---------------------
1386 function Get_Socket_Name
1387 (Socket : Socket_Type) return Sock_Addr_Type
1389 Sin : aliased Sockaddr;
1390 Len : aliased C.int := Sin'Size / 8;
1393 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1395 if Res = Failure then
1396 return No_Sock_Addr;
1399 return Get_Address (Sin, Len);
1400 end Get_Socket_Name;
1402 -----------------------
1403 -- Get_Socket_Option --
1404 -----------------------
1406 function Get_Socket_Option
1407 (Socket : Socket_Type;
1410 Optname : Interfaces.C.int := -1) return Option_Type
1412 use type C.unsigned;
1413 use type C.unsigned_char;
1415 V8 : aliased Two_Ints;
1417 U4 : aliased C.unsigned;
1418 V1 : aliased C.unsigned_char;
1419 VT : aliased Timeval;
1420 Len : aliased C.int;
1421 Add : System.Address;
1423 Opt : Option_Type (Name);
1424 Onm : Interfaces.C.int;
1427 if Name in Specific_Option_Name then
1428 Onm := Options (Name);
1430 elsif Optname = -1 then
1431 raise Socket_Error with "optname must be specified";
1439 | Receive_Packet_Info
1463 when Receive_Timeout
1466 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1467 -- struct timeval, but on Windows it is a milliseconds count in
1478 when Add_Membership_V4
1480 | Drop_Membership_V4
1481 | Drop_Membership_V6
1483 raise Socket_Error with
1484 "Add/Drop membership valid only for Set_Socket_Option";
1499 if Res = Failure then
1500 Raise_Socket_Error (Socket_Errno);
1504 when Generic_Option =>
1516 Opt.Enabled := (V4 /= 0);
1518 when Busy_Polling =>
1519 Opt.Microseconds := Natural (V4);
1522 Opt.Enabled := (V8 (V8'First) /= 0);
1523 Opt.Seconds := Natural (V8 (V8'Last));
1528 Opt.Size := Natural (V4);
1531 Opt.Error := Resolve_Error (Integer (V4));
1533 when Add_Membership_V4
1535 | Drop_Membership_V4
1536 | Drop_Membership_V6
1538 -- No way to be here. Exception raised in the first case Name
1542 when Multicast_If_V4 =>
1543 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1545 when Multicast_If_V6 =>
1546 Opt.Outgoing_If_Index := Natural (V4);
1548 when Multicast_TTL =>
1549 Opt.Time_To_Live := Integer (V1);
1551 when Multicast_Hops =>
1552 Opt.Hop_Limit := Integer (V4);
1554 when Receive_Packet_Info
1556 Opt.Enabled := (V1 /= 0);
1558 when Receive_Timeout
1563 -- Timeout is in milliseconds, actual value is 500 ms +
1564 -- returned value (unless it is 0).
1569 Opt.Timeout := Duration (U4) / 1000 + 0.500;
1573 Opt.Timeout := To_Duration (VT);
1578 end Get_Socket_Option;
1584 function Host_Name return String is
1585 Name : aliased C.char_array (1 .. 64);
1589 Res := C_Gethostname (Name'Address, Name'Length);
1591 if Res = Failure then
1592 Raise_Socket_Error (Socket_Errno);
1595 return C.To_Ada (Name);
1602 function Image (Value : Inet_Addr_Type) return String is
1603 use type CS.char_array_access;
1604 Size : constant socklen_t :=
1605 (case Value.Family is
1606 when Family_Inet => 4 * Value.Sin_V4'Length,
1607 when Family_Inet6 => 6 * 5 + 4 * 4);
1608 -- 1234:1234:1234:1234:1234:1234:123.123.123.123
1609 Dst : aliased C.char_array := (1 .. C.size_t (Size) => C.nul);
1610 Ia : aliased In_Addr_Union (Value.Family);
1612 case Value.Family is
1613 when Family_Inet6 =>
1614 Ia.In6 := To_In6_Addr (Value);
1616 Ia.In4 := To_In_Addr (Value);
1620 (Families (Value.Family), Ia'Address,
1621 Dst'Unchecked_Access, Size) = null
1623 Raise_Socket_Error (Socket_Errno);
1626 return C.To_Ada (Dst);
1633 function Image (Value : Sock_Addr_Type) return String is
1634 function Ipv6_Brackets (S : String) return String is
1635 (if Value.Family = Family_Inet6 then "[" & S & "]" else S);
1637 case Value.Family is
1639 if ASU.Length (Value.Name) > 0
1640 and then ASU.Element (Value.Name, 1) = ASCII.NUL
1642 return '@' & ASU.Slice (Value.Name, 2, ASU.Length (Value.Name));
1644 return ASU.To_String (Value.Name);
1647 when Family_Inet_4_6 =>
1649 Port : constant String := Value.Port'Img;
1651 return Ipv6_Brackets (Image (Value.Addr)) & ':'
1652 & Port (2 .. Port'Last);
1655 when Family_Unspec =>
1664 function Image (Socket : Socket_Type) return String is
1673 function Image (Item : Socket_Set_Type) return String is
1674 Socket_Set : Socket_Set_Type := Item;
1678 Last_Img : constant String := Socket_Set.Last'Img;
1680 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1681 Index : Positive := 1;
1682 Socket : Socket_Type;
1685 while not Is_Empty (Socket_Set) loop
1686 Get (Socket_Set, Socket);
1689 Socket_Img : constant String := Socket'Img;
1691 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1692 Index := Index + Socket_Img'Length;
1696 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1704 function Inet_Addr (Image : String) return Inet_Addr_Type is
1707 Img : aliased char_array := To_C (Image);
1709 Result : Inet_Addr_Type;
1710 IPv6 : constant Boolean := Is_IPv6_Address (Image);
1711 Ia : aliased In_Addr_Union
1712 (if IPv6 then Family_Inet6 else Family_Inet);
1714 -- Special case for an empty Image as on some platforms (e.g. Windows)
1715 -- calling Inet_Addr("") will not return an error.
1718 Raise_Socket_Error (SOSC.EINVAL);
1722 ((if IPv6 then SOSC.AF_INET6 else SOSC.AF_INET), Img'Address,
1726 Raise_Socket_Error (Socket_Errno);
1729 Raise_Socket_Error (SOSC.EINVAL);
1733 To_Inet_Addr (Ia.In6, Result);
1735 To_Inet_Addr (Ia.In4, Result);
1745 procedure Initialize (X : in out Sockets_Library_Controller) is
1746 pragma Unreferenced (X);
1756 procedure Initialize (Process_Blocking_IO : Boolean) is
1757 Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1760 if Process_Blocking_IO /= Expected then
1761 raise Socket_Error with
1762 "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1765 -- This is a dummy placeholder for an obsolete API
1767 -- Real initialization actions are in Initialize primitive operation
1768 -- of Sockets_Library_Controller.
1777 procedure Initialize is
1779 -- This is a dummy placeholder for an obsolete API
1781 -- Real initialization actions are in Initialize primitive operation
1782 -- of Sockets_Library_Controller.
1791 function Is_Windows return Boolean is
1794 return Target_OS = Windows;
1801 function Is_Empty (Item : Socket_Set_Type) return Boolean is
1803 return Item.Last = No_Socket;
1806 ---------------------
1807 -- Is_IPv6_Address --
1808 ---------------------
1810 function Is_IPv6_Address (Name : String) return Boolean is
1811 Prev_Colon : Natural := 0;
1812 Double_Colon : Boolean := False;
1813 Colons : Natural := 0;
1815 for J in Name'Range loop
1816 if Name (J) = ':' then
1817 Colons := Colons + 1;
1819 if Prev_Colon > 0 and then J = Prev_Colon + 1 then
1820 if Double_Colon then
1821 -- Only one double colon allowed
1825 Double_Colon := True;
1827 elsif J = Name'Last then
1828 -- Single colon at the end is not allowed
1834 elsif Prev_Colon = Name'First then
1835 -- Single colon at start is not allowed
1838 elsif Name (J) = '.' then
1839 return Prev_Colon > 0
1840 and then Is_IPv4_Address (Name (Prev_Colon + 1 .. Name'Last));
1842 elsif Name (J) not in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' then
1848 return Colons in 2 .. 8;
1849 end Is_IPv6_Address;
1851 ---------------------
1852 -- Is_IPv4_Address --
1853 ---------------------
1855 function Is_IPv4_Address (Name : String) return Boolean is
1856 Dots : Natural := 0;
1859 -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
1860 -- and there must be at least one digit around each.
1862 for J in Name'Range loop
1863 if Name (J) = '.' then
1865 -- Check that the dot is not in first or last position, and that
1866 -- it is followed by a digit. Note that we already know that it is
1867 -- preceded by a digit, or we would have returned earlier on.
1869 if J in Name'First + 1 .. Name'Last - 1
1870 and then Name (J + 1) in '0' .. '9'
1874 -- Definitely not a proper dotted quad
1880 elsif Name (J) not in '0' .. '9' then
1885 return Dots in 1 .. 3;
1886 end Is_IPv4_Address;
1892 function Is_Open (S : Selector_Type) return Boolean is
1898 -- Either both controlling socket descriptors are valid (case of an
1899 -- open selector) or neither (case of a closed selector).
1901 pragma Assert ((S.R_Sig_Socket /= No_Socket)
1903 (S.W_Sig_Socket /= No_Socket));
1905 return S.R_Sig_Socket /= No_Socket;
1914 (Item : Socket_Set_Type;
1915 Socket : Socket_Type) return Boolean
1918 Check_For_Fd_Set (Socket);
1920 return Item.Last /= No_Socket
1921 and then Socket <= Item.Last
1922 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1929 procedure Listen_Socket
1930 (Socket : Socket_Type;
1931 Length : Natural := 15)
1933 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1935 if Res = Failure then
1936 Raise_Socket_Error (Socket_Errno);
1944 procedure Narrow (Item : in out Socket_Set_Type) is
1945 Last : aliased C.int := C.int (Item.Last);
1947 if Item.Last /= No_Socket then
1948 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1949 Item.Last := Socket_Type (Last);
1957 procedure Netdb_Lock is
1959 if Need_Netdb_Lock then
1960 System.Task_Lock.Lock;
1968 procedure Netdb_Unlock is
1970 if Need_Netdb_Lock then
1971 System.Task_Lock.Unlock;
1975 ----------------------------
1976 -- Network_Socket_Address --
1977 ----------------------------
1979 function Network_Socket_Address
1980 (Addr : Inet_Addr_Type; Port : Port_Type) return Sock_Addr_Type is
1982 return Result : Sock_Addr_Type (Addr.Family) do
1983 Result.Addr := Addr;
1984 Result.Port := Port;
1986 end Network_Socket_Address;
1988 --------------------------------
1989 -- Normalize_Empty_Socket_Set --
1990 --------------------------------
1992 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1994 if S.Last = No_Socket then
1995 Reset_Socket_Set (S.Set'Access);
1997 end Normalize_Empty_Socket_Set;
2003 function Official_Name (E : Host_Entry_Type) return String is
2005 return To_String (E.Official);
2012 function Official_Name (S : Service_Entry_Type) return String is
2014 return To_String (S.Official);
2017 --------------------
2018 -- Wait_On_Socket --
2019 --------------------
2021 procedure Wait_On_Socket
2022 (Socket : Socket_Type;
2024 Timeout : Selector_Duration;
2025 Selector : access Selector_Type := null;
2026 Status : out Selector_Status)
2028 type Local_Selector_Access is access Selector_Type;
2029 for Local_Selector_Access'Storage_Size use Selector_Type'Size;
2031 S : Selector_Access;
2032 -- Selector to use for waiting
2034 R_Fd_Set : Socket_Set_Type;
2035 W_Fd_Set : Socket_Set_Type;
2038 -- Create selector if not provided by the user
2040 if Selector = null then
2042 Local_S : constant Local_Selector_Access := new Selector_Type;
2044 S := Local_S.all'Unchecked_Access;
2045 Create_Selector (S.all);
2049 S := Selector.all'Access;
2053 Set (R_Fd_Set, Socket);
2055 Set (W_Fd_Set, Socket);
2058 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
2060 if Selector = null then
2061 Close_Selector (S.all);
2069 function Port_Number (S : Service_Entry_Type) return Port_Type is
2078 function Protocol_Name (S : Service_Entry_Type) return String is
2080 return To_String (S.Protocol);
2083 ----------------------
2084 -- Raise_Host_Error --
2085 ----------------------
2087 procedure Raise_Host_Error (H_Error : Integer; Name : String) is
2089 raise Host_Error with
2090 Err_Code_Image (H_Error)
2091 & Dedot (Host_Error_Messages.Host_Error_Message (H_Error))
2093 end Raise_Host_Error;
2095 ------------------------
2096 -- Raise_Socket_Error --
2097 ------------------------
2099 procedure Raise_Socket_Error (Error : Integer) is
2101 raise Socket_Error with
2102 Err_Code_Image (Error) & Socket_Error_Message (Error);
2103 end Raise_Socket_Error;
2110 (Stream : in out Datagram_Socket_Stream_Type;
2111 Item : out Ada.Streams.Stream_Element_Array;
2112 Last : out Ada.Streams.Stream_Element_Offset)
2127 (Stream : in out Stream_Socket_Stream_Type;
2128 Item : out Ada.Streams.Stream_Element_Array;
2129 Last : out Ada.Streams.Stream_Element_Offset)
2131 First : Ada.Streams.Stream_Element_Offset := Item'First;
2132 Index : Ada.Streams.Stream_Element_Offset := First - 1;
2133 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2137 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
2140 -- Exit when all or zero data received. Zero means that the socket
2143 exit when Index < First or else Index = Max;
2149 --------------------
2150 -- Receive_Socket --
2151 --------------------
2153 procedure Receive_Socket
2154 (Socket : Socket_Type;
2155 Item : out Ada.Streams.Stream_Element_Array;
2156 Last : out Ada.Streams.Stream_Element_Offset;
2157 Flags : Request_Flag_Type := No_Request_Flag)
2163 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
2165 if Res = Failure then
2166 Raise_Socket_Error (Socket_Errno);
2169 Last := Last_Index (First => Item'First, Count => size_t (Res));
2172 --------------------
2173 -- Receive_Socket --
2174 --------------------
2176 procedure Receive_Socket
2177 (Socket : Socket_Type;
2178 Item : out Ada.Streams.Stream_Element_Array;
2179 Last : out Ada.Streams.Stream_Element_Offset;
2180 From : out Sock_Addr_Type;
2181 Flags : Request_Flag_Type := No_Request_Flag)
2184 Sin : aliased Sockaddr;
2185 Len : aliased C.int := Sin'Size / 8;
2197 if Res = Failure then
2198 Raise_Socket_Error (Socket_Errno);
2201 Last := Last_Index (First => Item'First, Count => size_t (Res));
2203 From := Get_Address (Sin, Len);
2206 --------------------
2207 -- Receive_Vector --
2208 --------------------
2210 procedure Receive_Vector
2211 (Socket : Socket_Type;
2212 Vector : Vector_Type;
2213 Count : out Ada.Streams.Stream_Element_Count;
2214 Flags : Request_Flag_Type := No_Request_Flag)
2219 (Msg_Name => System.Null_Address,
2221 Msg_Iov => Vector'Address,
2223 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
2224 -- platforms) when the supplied vector is longer than IOV_MAX,
2225 -- so use minimum of the two lengths.
2227 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
2228 (Vector'Length, SOSC.IOV_MAX),
2230 Msg_Control => System.Null_Address,
2231 Msg_Controllen => 0,
2241 if Res = ssize_t (Failure) then
2242 Raise_Socket_Error (Socket_Errno);
2245 Count := Ada.Streams.Stream_Element_Count (Res);
2252 function Resolve_Error
2253 (Error_Value : Integer;
2254 From_Errno : Boolean := True) return Error_Type
2256 use GNAT.Sockets.SOSC;
2259 if not From_Errno then
2261 when SOSC.HOST_NOT_FOUND => return Unknown_Host;
2262 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
2263 when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
2264 when SOSC.NO_DATA => return Unknown_Server_Error;
2265 when others => return Cannot_Resolve_Error;
2269 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
2270 -- can't include it in the case statement below.
2272 pragma Warnings (Off);
2273 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
2275 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
2276 return Resource_Temporarily_Unavailable;
2279 -- This is not a case statement because if a particular error
2280 -- number constant is not defined, s-oscons-tmplt.c defines
2281 -- it to -1. If multiple constants are not defined, they
2282 -- would each be -1 and result in a "duplicate value in case" error.
2284 -- But we have to leave warnings off because the compiler is also
2285 -- smart enough to note that when two errnos have the same value,
2286 -- the second if condition is useless.
2287 if Error_Value = ENOERROR then
2289 elsif Error_Value = EACCES then
2290 return Permission_Denied;
2291 elsif Error_Value = EADDRINUSE then
2292 return Address_Already_In_Use;
2293 elsif Error_Value = EADDRNOTAVAIL then
2294 return Cannot_Assign_Requested_Address;
2295 elsif Error_Value = EAFNOSUPPORT then
2296 return Address_Family_Not_Supported_By_Protocol;
2297 elsif Error_Value = EALREADY then
2298 return Operation_Already_In_Progress;
2299 elsif Error_Value = EBADF then
2300 return Bad_File_Descriptor;
2301 elsif Error_Value = ECONNABORTED then
2302 return Software_Caused_Connection_Abort;
2303 elsif Error_Value = ECONNREFUSED then
2304 return Connection_Refused;
2305 elsif Error_Value = ECONNRESET then
2306 return Connection_Reset_By_Peer;
2307 elsif Error_Value = EDESTADDRREQ then
2308 return Destination_Address_Required;
2309 elsif Error_Value = EFAULT then
2311 elsif Error_Value = EHOSTDOWN then
2312 return Host_Is_Down;
2313 elsif Error_Value = EHOSTUNREACH then
2314 return No_Route_To_Host;
2315 elsif Error_Value = EINPROGRESS then
2316 return Operation_Now_In_Progress;
2317 elsif Error_Value = EINTR then
2318 return Interrupted_System_Call;
2319 elsif Error_Value = EINVAL then
2320 return Invalid_Argument;
2321 elsif Error_Value = EIO then
2322 return Input_Output_Error;
2323 elsif Error_Value = EISCONN then
2324 return Transport_Endpoint_Already_Connected;
2325 elsif Error_Value = ELOOP then
2326 return Too_Many_Symbolic_Links;
2327 elsif Error_Value = EMFILE then
2328 return Too_Many_Open_Files;
2329 elsif Error_Value = EMSGSIZE then
2330 return Message_Too_Long;
2331 elsif Error_Value = ENAMETOOLONG then
2332 return File_Name_Too_Long;
2333 elsif Error_Value = ENETDOWN then
2334 return Network_Is_Down;
2335 elsif Error_Value = ENETRESET then
2336 return Network_Dropped_Connection_Because_Of_Reset;
2337 elsif Error_Value = ENETUNREACH then
2338 return Network_Is_Unreachable;
2339 elsif Error_Value = ENOBUFS then
2340 return No_Buffer_Space_Available;
2341 elsif Error_Value = ENOPROTOOPT then
2342 return Protocol_Not_Available;
2343 elsif Error_Value = ENOTCONN then
2344 return Transport_Endpoint_Not_Connected;
2345 elsif Error_Value = ENOTSOCK then
2346 return Socket_Operation_On_Non_Socket;
2347 elsif Error_Value = EOPNOTSUPP then
2348 return Operation_Not_Supported;
2349 elsif Error_Value = EPFNOSUPPORT then
2350 return Protocol_Family_Not_Supported;
2351 elsif Error_Value = EPIPE then
2353 elsif Error_Value = EPROTONOSUPPORT then
2354 return Protocol_Not_Supported;
2355 elsif Error_Value = EPROTOTYPE then
2356 return Protocol_Wrong_Type_For_Socket;
2357 elsif Error_Value = ESHUTDOWN then
2358 return Cannot_Send_After_Transport_Endpoint_Shutdown;
2359 elsif Error_Value = ESOCKTNOSUPPORT then
2360 return Socket_Type_Not_Supported;
2361 elsif Error_Value = ETIMEDOUT then
2362 return Connection_Timed_Out;
2363 elsif Error_Value = ETOOMANYREFS then
2364 return Too_Many_References;
2365 elsif Error_Value = EWOULDBLOCK then
2366 return Resource_Temporarily_Unavailable;
2368 return Cannot_Resolve_Error;
2370 pragma Warnings (On);
2374 -----------------------
2375 -- Resolve_Exception --
2376 -----------------------
2378 function Resolve_Exception
2379 (Occurrence : Exception_Occurrence) return Error_Type
2381 Id : constant Exception_Id := Exception_Identity (Occurrence);
2382 Msg : constant String := Exception_Message (Occurrence);
2389 while First <= Msg'Last
2390 and then Msg (First) not in '0' .. '9'
2395 if First > Msg'Last then
2396 return Cannot_Resolve_Error;
2400 while Last < Msg'Last
2401 and then Msg (Last + 1) in '0' .. '9'
2406 Val := Integer'Value (Msg (First .. Last));
2408 if Id = Socket_Error_Id then
2409 return Resolve_Error (Val);
2411 elsif Id = Host_Error_Id then
2412 return Resolve_Error (Val, False);
2415 return Cannot_Resolve_Error;
2417 end Resolve_Exception;
2423 procedure Send_Socket
2424 (Socket : Socket_Type;
2425 Item : Ada.Streams.Stream_Element_Array;
2426 Last : out Ada.Streams.Stream_Element_Offset;
2427 Flags : Request_Flag_Type := No_Request_Flag)
2430 Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2437 procedure Send_Socket
2438 (Socket : Socket_Type;
2439 Item : Ada.Streams.Stream_Element_Array;
2440 Last : out Ada.Streams.Stream_Element_Offset;
2441 To : Sock_Addr_Type;
2442 Flags : Request_Flag_Type := No_Request_Flag)
2446 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2453 procedure Send_Socket
2454 (Socket : Socket_Type;
2455 Item : Ada.Streams.Stream_Element_Array;
2456 Last : out Ada.Streams.Stream_Element_Offset;
2457 To : access Sock_Addr_Type;
2458 Flags : Request_Flag_Type := No_Request_Flag)
2462 Sin : aliased Sockaddr;
2463 C_To : System.Address;
2468 Set_Address (Sin'Unchecked_Access, To.all, Len);
2469 C_To := Sin'Address;
2472 C_To := System.Null_Address;
2480 Set_Forced_Flags (To_Int (Flags)),
2484 if Res = Failure then
2485 Raise_Socket_Error (Socket_Errno);
2488 Last := Last_Index (First => Item'First, Count => size_t (Res));
2495 procedure Send_Vector
2496 (Socket : Socket_Type;
2497 Vector : Vector_Type;
2498 Count : out Ada.Streams.Stream_Element_Count;
2499 Flags : Request_Flag_Type := No_Request_Flag)
2504 Iov_Count : SOSC.Msg_Iovlen_T;
2505 This_Iov_Count : SOSC.Msg_Iovlen_T;
2511 while Iov_Count < Vector'Length loop
2513 pragma Warnings (Off);
2514 -- Following test may be compile time known on some targets
2517 (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2519 else Vector'Length - Iov_Count);
2521 pragma Warnings (On);
2524 (Msg_Name => System.Null_Address,
2527 (Vector'First + Integer (Iov_Count))'Address,
2528 Msg_Iovlen => This_Iov_Count,
2529 Msg_Control => System.Null_Address,
2530 Msg_Controllen => 0,
2537 Set_Forced_Flags (To_Int (Flags)));
2539 if Res = ssize_t (Failure) then
2540 Raise_Socket_Error (Socket_Errno);
2543 Count := Count + Ada.Streams.Stream_Element_Count (Res);
2544 Iov_Count := Iov_Count + This_Iov_Count;
2552 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2554 Check_For_Fd_Set (Socket);
2556 if Item.Last = No_Socket then
2558 -- Uninitialized socket set, make sure it is properly zeroed out
2560 Reset_Socket_Set (Item.Set'Access);
2561 Item.Last := Socket;
2563 elsif Item.Last < Socket then
2564 Item.Last := Socket;
2567 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2570 -----------------------
2571 -- Set_Close_On_Exec --
2572 -----------------------
2574 procedure Set_Close_On_Exec
2575 (Socket : Socket_Type;
2576 Close_On_Exec : Boolean;
2577 Status : out Boolean)
2579 function C_Set_Close_On_Exec
2580 (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
2581 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2583 Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
2584 end Set_Close_On_Exec;
2586 ----------------------
2587 -- Set_Forced_Flags --
2588 ----------------------
2590 function Set_Forced_Flags (F : C.int) return C.int is
2591 use type C.unsigned;
2592 function To_unsigned is
2593 new Ada.Unchecked_Conversion (C.int, C.unsigned);
2595 new Ada.Unchecked_Conversion (C.unsigned, C.int);
2597 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2598 end Set_Forced_Flags;
2600 -----------------------
2601 -- Set_Socket_Option --
2602 -----------------------
2604 procedure Set_Socket_Option
2605 (Socket : Socket_Type;
2607 Option : Option_Type)
2609 use type C.unsigned;
2611 MR : aliased IPV6_Mreq;
2612 V8 : aliased Two_Ints;
2614 U4 : aliased C.unsigned;
2615 V1 : aliased C.unsigned_char;
2616 VT : aliased Timeval;
2618 Add : System.Address := Null_Address;
2624 when Generic_Option =>
2625 V4 := Option.Optval;
2637 V4 := C.int (Boolean'Pos (Option.Enabled));
2641 when Busy_Polling =>
2642 V4 := C.int (Option.Microseconds);
2647 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2648 V8 (V8'Last) := C.int (Option.Seconds);
2655 V4 := C.int (Option.Size);
2660 V4 := C.int (Boolean'Pos (True));
2664 when Add_Membership_V4
2665 | Drop_Membership_V4
2667 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2668 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
2672 when Add_Membership_V6
2673 | Drop_Membership_V6 =>
2674 MR.ipv6mr_multiaddr := To_In6_Addr (Option.Multicast_Address);
2675 MR.ipv6mr_interface := C.unsigned (Option.Interface_Index);
2679 when Multicast_If_V4 =>
2680 V4 := To_Int (To_In_Addr (Option.Outgoing_If));
2684 when Multicast_If_V6 =>
2685 V4 := C.int (Option.Outgoing_If_Index);
2689 when Multicast_TTL =>
2690 V1 := C.unsigned_char (Option.Time_To_Live);
2694 when Multicast_Hops =>
2695 V4 := C.int (Option.Hop_Limit);
2699 when Receive_Packet_Info
2701 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
2705 when Receive_Timeout
2710 -- On Windows, the timeout is a DWORD in milliseconds
2715 U4 := C.unsigned (Option.Timeout / 0.001);
2717 if Option.Timeout > 0.0 and then U4 = 0 then
2718 -- Avoid round to zero. Zero timeout mean unlimited.
2722 -- Old windows versions actual timeout is 500 ms + the given
2723 -- value (unless it is 0).
2725 if Minus_500ms_Windows_Timeout /= 0 then
2735 VT := To_Timeval (Option.Timeout);
2741 if Option.Name in Specific_Option_Name then
2742 Onm := Options (Option.Name);
2744 elsif Option.Optname = -1 then
2745 raise Socket_Error with "optname must be specified";
2748 Onm := Option.Optname;
2757 if Res = Failure then
2758 Raise_Socket_Error (Socket_Errno);
2760 end Set_Socket_Option;
2762 ---------------------
2763 -- Shutdown_Socket --
2764 ---------------------
2766 procedure Shutdown_Socket
2767 (Socket : Socket_Type;
2768 How : Shutmode_Type := Shut_Read_Write)
2773 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2775 if Res = Failure then
2776 Raise_Socket_Error (Socket_Errno);
2778 end Shutdown_Socket;
2785 (Socket : Socket_Type;
2786 Send_To : Sock_Addr_Type) return Stream_Access
2788 S : Datagram_Socket_Stream_Access;
2791 S := new Datagram_Socket_Stream_Type;
2794 S.From := Get_Socket_Name (Socket);
2795 return Stream_Access (S);
2802 function Stream (Socket : Socket_Type) return Stream_Access is
2803 S : Stream_Socket_Stream_Access;
2805 S := new Stream_Socket_Stream_Type;
2807 return Stream_Access (S);
2814 function To_Ada (Fd : Integer) return Socket_Type is
2816 return Socket_Type (Fd);
2823 function To_C (Socket : Socket_Type) return Integer is
2825 return Integer (Socket);
2832 function To_Duration (Val : Timeval) return Timeval_Duration is
2833 Max_D : constant Long_Long_Integer := Long_Long_Integer (Forever - 0.5);
2834 Tv_sec_64 : constant Boolean := SOSC.SIZEOF_tv_sec = 8;
2835 -- Need to separate this condition into the constant declaration to
2836 -- avoid GNAT warning about "always true" or "always false".
2839 -- Check for possible Duration overflow when Tv_Sec field is 64 bit
2842 if Val.Tv_Sec > time_t (Max_D) or else
2843 (Val.Tv_Sec = time_t (Max_D) and then
2844 Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6))
2850 return Duration (Val.Tv_Sec) + Duration (Val.Tv_Usec) * 1.0E-6;
2857 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2858 Aliases_Count, Addresses_Count : Natural;
2860 Family : constant Family_Type :=
2861 (case Hostent_H_Addrtype (E) is
2862 when SOSC.AF_INET => Family_Inet,
2863 when SOSC.AF_INET6 => Family_Inet6,
2864 when others => Family_Unspec);
2866 Addr_Len : constant C.size_t := C.size_t (Hostent_H_Length (E));
2869 if Family = Family_Unspec then
2870 Raise_Socket_Error (SOSC.EPFNOSUPPORT);
2874 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2875 Aliases_Count := Aliases_Count + 1;
2878 Addresses_Count := 0;
2879 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2880 Addresses_Count := Addresses_Count + 1;
2883 return Result : Host_Entry_Type
2884 (Aliases_Length => Aliases_Count,
2885 Addresses_Length => Addresses_Count)
2887 Result.Official := To_Name (Value (Hostent_H_Name (E)));
2889 for J in Result.Aliases'Range loop
2890 Result.Aliases (J) :=
2891 To_Name (Value (Hostent_H_Alias
2892 (E, C.int (J - Result.Aliases'First))));
2895 for J in Result.Addresses'Range loop
2897 Ia : In_Addr_Union (Family);
2899 -- Hostent_H_Addr (E, <index>) may return an address that is
2900 -- not correctly aligned for In_Addr, so we need to use
2901 -- an intermediate copy operation on a type with an alignment
2902 -- of 1 to recover the value.
2904 subtype Addr_Buf_T is C.char_array (1 .. Addr_Len);
2905 Unaligned_Addr : Addr_Buf_T;
2906 for Unaligned_Addr'Address
2907 use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2908 pragma Import (Ada, Unaligned_Addr);
2910 Aligned_Addr : Addr_Buf_T;
2911 for Aligned_Addr'Address use Ia'Address;
2912 pragma Import (Ada, Aligned_Addr);
2915 Aligned_Addr := Unaligned_Addr;
2916 if Family = Family_Inet6 then
2917 To_Inet_Addr (Ia.In6, Result.Addresses (J));
2919 To_Inet_Addr (Ia.In4, Result.Addresses (J));
2930 function To_Int (F : Request_Flag_Type) return C.int is
2931 Current : Request_Flag_Type := F;
2932 Result : C.int := 0;
2935 for J in Flags'Range loop
2936 exit when Current = 0;
2938 if Current mod 2 /= 0 then
2939 if Flags (J) = -1 then
2941 (CodePeer, False_Positive,
2942 "test always false", "self fulfilling prophecy");
2944 Raise_Socket_Error (SOSC.EOPNOTSUPP);
2947 Result := Result + Flags (J);
2950 Current := Current / 2;
2960 function To_Name (N : String) return Name_Type is
2962 return Name_Type'(N'Length, N);
2965 ----------------------
2966 -- To_Service_Entry --
2967 ----------------------
2969 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2970 Aliases_Count : Natural;
2974 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2975 Aliases_Count := Aliases_Count + 1;
2978 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2979 Result.Official := To_Name (Value (Servent_S_Name (E)));
2981 for J in Result.Aliases'Range loop
2982 Result.Aliases (J) :=
2983 To_Name (Value (Servent_S_Alias
2984 (E, C.int (J - Result.Aliases'First))));
2987 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2989 Port_Type (Network_To_Short (Servent_S_Port (E)));
2991 end To_Service_Entry;
2997 function To_String (HN : Name_Type) return String is
2999 return HN.Name (1 .. HN.Length);
3006 function To_Timeval (Val : Timeval_Duration) return Timeval is
3011 -- If zero, set result as zero (otherwise it gets rounded down to -1)
3017 -- Normal case where we do round down
3020 S := time_t (Val - 0.5);
3021 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5);
3024 -- It happen on integer duration
3036 function Value (S : System.Address) return String is
3037 Str : String (1 .. Positive'Last);
3038 for Str'Address use S;
3039 pragma Import (Ada, Str);
3041 Terminator : Positive := Str'First;
3044 while Str (Terminator) /= ASCII.NUL loop
3045 Terminator := Terminator + 1;
3048 return Str (1 .. Terminator - 1);
3056 (Stream : in out Datagram_Socket_Stream_Type;
3057 Item : Ada.Streams.Stream_Element_Array)
3059 Last : Stream_Element_Offset;
3068 -- It is an error if not all of the data has been sent
3070 if Last /= Item'Last then
3071 Raise_Socket_Error (Socket_Errno);
3080 (Stream : in out Stream_Socket_Stream_Type;
3081 Item : Ada.Streams.Stream_Element_Array)
3083 First : Ada.Streams.Stream_Element_Offset;
3084 Index : Ada.Streams.Stream_Element_Offset;
3085 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
3088 First := Item'First;
3090 while First <= Max loop
3091 Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
3093 -- Exit when all or zero data sent. Zero means that the socket has
3094 -- been closed by peer.
3096 exit when Index < First or else Index = Max;
3101 -- For an empty array, we have First > Max, and hence Index >= Max (no
3102 -- error, the loop above is never executed). After a successful send,
3103 -- Index = Max. The only remaining case, Index < Max, is therefore
3104 -- always an actual send failure.
3107 Raise_Socket_Error (Socket_Errno);
3111 Sockets_Library_Controller_Object : Sockets_Library_Controller;
3112 pragma Unreferenced (Sockets_Library_Controller_Object);
3113 -- The elaboration and finalization of this object perform the required
3114 -- initialization and cleanup actions for the sockets library.
3116 --------------------
3117 -- Create_Address --
3118 --------------------
3120 function Create_Address
3121 (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
3124 when Family_Inet => (Family_Inet, Bytes),
3125 when Family_Inet6 => (Family_Inet6, Bytes));
3131 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is
3132 (case Addr.Family is
3133 when Family_Inet => Addr.Sin_V4,
3134 when Family_Inet6 => Addr.Sin_V6);
3141 (Family : Family_Inet_4_6;
3143 Host : Boolean := False) return Inet_Addr_Type
3145 Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family);
3147 if Length > 8 * Addr_Len then
3148 raise Constraint_Error with
3149 "invalid mask length for address family " & Family'Img;
3153 B : Inet_Addr_Bytes (1 .. Addr_Len);
3154 Part : Inet_Addr_Comp_Type;
3156 for J in 1 .. Length / 8 loop
3157 B (J) := (if Host then 0 else 255);
3160 if Length < 8 * Addr_Len then
3161 Part := 2 ** (8 - Length mod 8) - 1;
3162 B (Length / 8 + 1) := (if Host then Part else not Part);
3164 for J in Length / 8 + 2 .. B'Last loop
3165 B (J) := (if Host then 255 else 0);
3169 return Create_Address (Family, B);
3173 -------------------------
3174 -- Unix_Socket_Address --
3175 -------------------------
3177 function Unix_Socket_Address (Addr : String) return Sock_Addr_Type is
3179 return Sock_Addr_Type'(Family_Unix, ASU.To_Unbounded_String (Addr));
3180 end Unix_Socket_Address;
3186 function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is
3188 if Addr.Family /= Mask.Family then
3189 raise Constraint_Error with "incompatible address families";
3193 A : constant Inet_Addr_Bytes := Get_Bytes (Addr);
3194 M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
3195 R : Inet_Addr_Bytes (A'Range);
3198 for J in A'Range loop
3199 R (J) := A (J) and M (J);
3201 return Create_Address (Addr.Family, R);
3209 function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is
3211 if Net.Family /= Host.Family then
3212 raise Constraint_Error with "incompatible address families";
3216 N : constant Inet_Addr_Bytes := Get_Bytes (Net);
3217 H : constant Inet_Addr_Bytes := Get_Bytes (Host);
3218 R : Inet_Addr_Bytes (N'Range);
3221 for J in N'Range loop
3222 R (J) := N (J) or H (J);
3224 return Create_Address (Net.Family, R);
3232 function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is
3233 M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
3234 R : Inet_Addr_Bytes (M'Range);
3236 for J in R'Range loop
3239 return Create_Address (Mask.Family, R);