1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2016, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Streams
; use Ada
.Streams
;
33 with Ada
.Exceptions
; use Ada
.Exceptions
;
34 with Ada
.Finalization
;
35 with Ada
.Unchecked_Conversion
;
37 with GNAT
.Sockets
.Thin_Common
; use GNAT
.Sockets
.Thin_Common
;
38 with GNAT
.Sockets
.Thin
; use GNAT
.Sockets
.Thin
;
40 with GNAT
.Sockets
.Linker_Options
;
41 pragma Warnings
(Off
, GNAT
.Sockets
.Linker_Options
);
42 -- Need to include pragma Linker_Options which is platform dependent
44 with System
; use System
;
45 with System
.Communication
; use System
.Communication
;
46 with System
.CRTL
; use System
.CRTL
;
47 with System
.Task_Lock
;
49 package body GNAT
.Sockets
is
51 package C
renames Interfaces
.C
;
55 ENOERROR
: constant := 0;
57 Netdb_Buffer_Size
: constant := SOSC
.Need_Netdb_Buffer
* 1024;
58 Need_Netdb_Lock
: constant Boolean := SOSC
.Need_Netdb_Lock
/= 0;
59 -- The network database functions gethostbyname, gethostbyaddr,
60 -- getservbyname and getservbyport can either be guaranteed task safe by
61 -- the operating system, or else return data through a user-provided buffer
62 -- to ensure concurrent uses do not interfere.
64 -- Correspondence tables
66 Levels
: constant array (Level_Type
) of C
.int
:=
67 (Socket_Level
=> SOSC
.SOL_SOCKET
,
68 IP_Protocol_For_IP_Level
=> SOSC
.IPPROTO_IP
,
69 IP_Protocol_For_UDP_Level
=> SOSC
.IPPROTO_UDP
,
70 IP_Protocol_For_TCP_Level
=> SOSC
.IPPROTO_TCP
);
72 Modes
: constant array (Mode_Type
) of C
.int
:=
73 (Socket_Stream
=> SOSC
.SOCK_STREAM
,
74 Socket_Datagram
=> SOSC
.SOCK_DGRAM
);
76 Shutmodes
: constant array (Shutmode_Type
) of C
.int
:=
77 (Shut_Read
=> SOSC
.SHUT_RD
,
78 Shut_Write
=> SOSC
.SHUT_WR
,
79 Shut_Read_Write
=> SOSC
.SHUT_RDWR
);
81 Requests
: constant array (Request_Name
) of SOSC
.IOCTL_Req_T
:=
82 (Non_Blocking_IO
=> SOSC
.FIONBIO
,
83 N_Bytes_To_Read
=> SOSC
.FIONREAD
);
85 Options
: constant array (Option_Name
) of C
.int
:=
86 (Keep_Alive
=> SOSC
.SO_KEEPALIVE
,
87 Reuse_Address
=> SOSC
.SO_REUSEADDR
,
88 Broadcast
=> SOSC
.SO_BROADCAST
,
89 Send_Buffer
=> SOSC
.SO_SNDBUF
,
90 Receive_Buffer
=> SOSC
.SO_RCVBUF
,
91 Linger
=> SOSC
.SO_LINGER
,
92 Error
=> SOSC
.SO_ERROR
,
93 No_Delay
=> SOSC
.TCP_NODELAY
,
94 Add_Membership
=> SOSC
.IP_ADD_MEMBERSHIP
,
95 Drop_Membership
=> SOSC
.IP_DROP_MEMBERSHIP
,
96 Multicast_If
=> SOSC
.IP_MULTICAST_IF
,
97 Multicast_TTL
=> SOSC
.IP_MULTICAST_TTL
,
98 Multicast_Loop
=> SOSC
.IP_MULTICAST_LOOP
,
99 Receive_Packet_Info
=> SOSC
.IP_PKTINFO
,
100 Send_Timeout
=> SOSC
.SO_SNDTIMEO
,
101 Receive_Timeout
=> SOSC
.SO_RCVTIMEO
);
102 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
103 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
105 Flags
: constant array (0 .. 3) of C
.int
:=
106 (0 => SOSC
.MSG_OOB
, -- Process_Out_Of_Band_Data
107 1 => SOSC
.MSG_PEEK
, -- Peek_At_Incoming_Data
108 2 => SOSC
.MSG_WAITALL
, -- Wait_For_A_Full_Reception
109 3 => SOSC
.MSG_EOR
); -- Send_End_Of_Record
111 Socket_Error_Id
: constant Exception_Id
:= Socket_Error
'Identity;
112 Host_Error_Id
: constant Exception_Id
:= Host_Error
'Identity;
114 Hex_To_Char
: constant String (1 .. 16) := "0123456789ABCDEF";
115 -- Use to print in hexadecimal format
117 -----------------------
118 -- Local subprograms --
119 -----------------------
121 function Resolve_Error
122 (Error_Value
: Integer;
123 From_Errno
: Boolean := True) return Error_Type
;
124 -- Associate an enumeration value (error_type) to an error value (errno).
125 -- From_Errno prevents from mixing h_errno with errno.
127 function To_Name
(N
: String) return Name_Type
;
128 function To_String
(HN
: Name_Type
) return String;
129 -- Conversion functions
131 function To_Int
(F
: Request_Flag_Type
) return C
.int
;
132 -- Return the int value corresponding to the specified flags combination
134 function Set_Forced_Flags
(F
: C
.int
) return C
.int
;
135 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
137 function Short_To_Network
138 (S
: C
.unsigned_short
) return C
.unsigned_short
;
139 pragma Inline
(Short_To_Network
);
140 -- Convert a port number into a network port number
142 function Network_To_Short
143 (S
: C
.unsigned_short
) return C
.unsigned_short
144 renames Short_To_Network
;
145 -- Symmetric operation
148 (Val
: Inet_Addr_VN_Type
;
149 Hex
: Boolean := False) return String;
150 -- Output an array of inet address components in hex or decimal mode
152 function Is_IP_Address
(Name
: String) return Boolean;
153 -- Return true when Name is an IPv4 address in dotted quad notation
155 procedure Netdb_Lock
;
156 pragma Inline
(Netdb_Lock
);
157 procedure Netdb_Unlock
;
158 pragma Inline
(Netdb_Unlock
);
159 -- Lock/unlock operation used to protect netdb access for platforms that
160 -- require such protection.
162 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
;
163 procedure To_Inet_Addr
165 Result
: out Inet_Addr_Type
);
166 -- Conversion functions
168 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
;
169 -- Conversion function
171 function To_Service_Entry
(E
: Servent_Access
) return Service_Entry_Type
;
172 -- Conversion function
174 function Value
(S
: System
.Address
) return String;
175 -- Same as Interfaces.C.Strings.Value but taking a System.Address
177 function To_Timeval
(Val
: Timeval_Duration
) return Timeval
;
178 -- Separate Val in seconds and microseconds
180 function To_Duration
(Val
: Timeval
) return Timeval_Duration
;
181 -- Reconstruct a Duration value from a Timeval record (seconds and
184 procedure Raise_Socket_Error
(Error
: Integer);
185 -- Raise Socket_Error with an exception message describing the error code
188 procedure Raise_Host_Error
(H_Error
: Integer; Name
: String);
189 -- Raise Host_Error exception with message describing error code (note
190 -- hstrerror seems to be obsolete) from h_errno. Name is the name
191 -- or address that was being looked up.
193 procedure Narrow
(Item
: in out Socket_Set_Type
);
194 -- Update Last as it may be greater than the real last socket
196 procedure Check_For_Fd_Set
(Fd
: Socket_Type
);
197 pragma Inline
(Check_For_Fd_Set
);
198 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
199 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
201 function Connect_Socket
202 (Socket
: Socket_Type
;
203 Server
: Sock_Addr_Type
) return C
.int
;
204 pragma Inline
(Connect_Socket
);
205 -- Underlying implementation for the Connect_Socket procedures
207 -- Types needed for Datagram_Socket_Stream_Type
209 type Datagram_Socket_Stream_Type
is new Root_Stream_Type
with record
210 Socket
: Socket_Type
;
212 From
: Sock_Addr_Type
;
215 type Datagram_Socket_Stream_Access
is
216 access all Datagram_Socket_Stream_Type
;
219 (Stream
: in out Datagram_Socket_Stream_Type
;
220 Item
: out Ada
.Streams
.Stream_Element_Array
;
221 Last
: out Ada
.Streams
.Stream_Element_Offset
);
224 (Stream
: in out Datagram_Socket_Stream_Type
;
225 Item
: Ada
.Streams
.Stream_Element_Array
);
227 -- Types needed for Stream_Socket_Stream_Type
229 type Stream_Socket_Stream_Type
is new Root_Stream_Type
with record
230 Socket
: Socket_Type
;
233 type Stream_Socket_Stream_Access
is
234 access all Stream_Socket_Stream_Type
;
237 (Stream
: in out Stream_Socket_Stream_Type
;
238 Item
: out Ada
.Streams
.Stream_Element_Array
;
239 Last
: out Ada
.Streams
.Stream_Element_Offset
);
242 (Stream
: in out Stream_Socket_Stream_Type
;
243 Item
: Ada
.Streams
.Stream_Element_Array
);
245 procedure Wait_On_Socket
246 (Socket
: Socket_Type
;
248 Timeout
: Selector_Duration
;
249 Selector
: access Selector_Type
:= null;
250 Status
: out Selector_Status
);
251 -- Common code for variants of socket operations supporting a timeout:
252 -- block in Check_Selector on Socket for at most the indicated timeout.
253 -- If For_Read is True, Socket is added to the read set for this call, else
254 -- it is added to the write set. If no selector is provided, a local one is
255 -- created for this call and destroyed prior to returning.
257 type Sockets_Library_Controller
is new Ada
.Finalization
.Limited_Controlled
259 -- This type is used to generate automatic calls to Initialize and Finalize
260 -- during the elaboration and finalization of this package. A single object
261 -- of this type must exist at library level.
263 function Err_Code_Image
(E
: Integer) return String;
264 -- Return the value of E surrounded with brackets
266 procedure Initialize
(X
: in out Sockets_Library_Controller
);
267 procedure Finalize
(X
: in out Sockets_Library_Controller
);
269 procedure Normalize_Empty_Socket_Set
(S
: in out Socket_Set_Type
);
270 -- If S is the empty set (detected by Last = No_Socket), make sure its
271 -- fd_set component is actually cleared. Note that the case where it is
272 -- not can occur for an uninitialized Socket_Set_Type object.
274 function Is_Open
(S
: Selector_Type
) return Boolean;
275 -- Return True for an "open" Selector_Type object, i.e. one for which
276 -- Create_Selector has been called and Close_Selector has not been called,
277 -- or the null selector.
283 function "+" (L
, R
: Request_Flag_Type
) return Request_Flag_Type
is
292 procedure Abort_Selector
(Selector
: Selector_Type
) is
296 if not Is_Open
(Selector
) then
297 raise Program_Error
with "closed selector";
299 elsif Selector
.Is_Null
then
300 raise Program_Error
with "null selector";
304 -- Send one byte to unblock select system call
306 Res
:= Signalling_Fds
.Write
(C
.int
(Selector
.W_Sig_Socket
));
308 if Res
= Failure
then
309 Raise_Socket_Error
(Socket_Errno
);
317 procedure Accept_Socket
318 (Server
: Socket_Type
;
319 Socket
: out Socket_Type
;
320 Address
: out Sock_Addr_Type
)
323 Sin
: aliased Sockaddr_In
;
324 Len
: aliased C
.int
:= Sin
'Size / 8;
327 Res
:= C_Accept
(C
.int
(Server
), Sin
'Address, Len
'Access);
329 if Res
= Failure
then
330 Raise_Socket_Error
(Socket_Errno
);
333 Socket
:= Socket_Type
(Res
);
335 To_Inet_Addr
(Sin
.Sin_Addr
, Address
.Addr
);
336 Address
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
343 procedure Accept_Socket
344 (Server
: Socket_Type
;
345 Socket
: out Socket_Type
;
346 Address
: out Sock_Addr_Type
;
347 Timeout
: Selector_Duration
;
348 Selector
: access Selector_Type
:= null;
349 Status
: out Selector_Status
)
352 if Selector
/= null and then not Is_Open
(Selector
.all) then
353 raise Program_Error
with "closed selector";
356 -- Wait for socket to become available for reading
362 Selector
=> Selector
,
365 -- Accept connection if available
367 if Status
= Completed
then
368 Accept_Socket
(Server
, Socket
, Address
);
379 (E
: Host_Entry_Type
;
380 N
: Positive := 1) return Inet_Addr_Type
383 return E
.Addresses
(N
);
386 ----------------------
387 -- Addresses_Length --
388 ----------------------
390 function Addresses_Length
(E
: Host_Entry_Type
) return Natural is
392 return E
.Addresses_Length
;
393 end Addresses_Length
;
400 (E
: Host_Entry_Type
;
401 N
: Positive := 1) return String
404 return To_String
(E
.Aliases
(N
));
412 (S
: Service_Entry_Type
;
413 N
: Positive := 1) return String
416 return To_String
(S
.Aliases
(N
));
423 function Aliases_Length
(E
: Host_Entry_Type
) return Natural is
425 return E
.Aliases_Length
;
432 function Aliases_Length
(S
: Service_Entry_Type
) return Natural is
434 return S
.Aliases_Length
;
441 procedure Bind_Socket
442 (Socket
: Socket_Type
;
443 Address
: Sock_Addr_Type
)
446 Sin
: aliased Sockaddr_In
;
447 Len
: constant C
.int
:= Sin
'Size / 8;
448 -- This assumes that Address.Family = Family_Inet???
451 if Address
.Family
= Family_Inet6
then
452 raise Socket_Error
with "IPv6 not supported";
455 Set_Family
(Sin
.Sin_Family
, Address
.Family
);
456 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Address
.Addr
));
458 (Sin
'Unchecked_Access,
459 Short_To_Network
(C
.unsigned_short
(Address
.Port
)));
461 Res
:= C_Bind
(C
.int
(Socket
), Sin
'Address, Len
);
463 if Res
= Failure
then
464 Raise_Socket_Error
(Socket_Errno
);
468 ----------------------
469 -- Check_For_Fd_Set --
470 ----------------------
472 procedure Check_For_Fd_Set
(Fd
: Socket_Type
) is
476 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
477 -- no check required. Warnings suppressed because condition
478 -- is known at compile time.
480 if Target_OS
= Windows
then
484 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
485 -- that Fd is within range (otherwise behavior is undefined).
487 elsif Fd
< 0 or else Fd
>= SOSC
.FD_SETSIZE
then
488 raise Constraint_Error
489 with "invalid value for socket set: " & Image
(Fd
);
491 end Check_For_Fd_Set
;
497 procedure Check_Selector
498 (Selector
: Selector_Type
;
499 R_Socket_Set
: in out Socket_Set_Type
;
500 W_Socket_Set
: in out Socket_Set_Type
;
501 Status
: out Selector_Status
;
502 Timeout
: Selector_Duration
:= Forever
)
504 E_Socket_Set
: Socket_Set_Type
;
507 (Selector
, R_Socket_Set
, W_Socket_Set
, E_Socket_Set
, Status
, Timeout
);
510 procedure Check_Selector
511 (Selector
: Selector_Type
;
512 R_Socket_Set
: in out Socket_Set_Type
;
513 W_Socket_Set
: in out Socket_Set_Type
;
514 E_Socket_Set
: in out Socket_Set_Type
;
515 Status
: out Selector_Status
;
516 Timeout
: Selector_Duration
:= Forever
)
520 RSig
: Socket_Type
:= No_Socket
;
521 TVal
: aliased Timeval
;
522 TPtr
: Timeval_Access
;
525 if not Is_Open
(Selector
) then
526 raise Program_Error
with "closed selector";
531 -- No timeout or Forever is indicated by a null timeval pointer
533 if Timeout
= Forever
then
536 TVal
:= To_Timeval
(Timeout
);
537 TPtr
:= TVal
'Unchecked_Access;
540 -- Add read signalling socket, if present
542 if not Selector
.Is_Null
then
543 RSig
:= Selector
.R_Sig_Socket
;
544 Set
(R_Socket_Set
, RSig
);
547 Last
:= C
.int
'Max (C
.int
'Max (C
.int
(R_Socket_Set
.Last
),
548 C
.int
(W_Socket_Set
.Last
)),
549 C
.int
(E_Socket_Set
.Last
));
551 -- Zero out fd_set for empty Socket_Set_Type objects
553 Normalize_Empty_Socket_Set
(R_Socket_Set
);
554 Normalize_Empty_Socket_Set
(W_Socket_Set
);
555 Normalize_Empty_Socket_Set
(E_Socket_Set
);
560 R_Socket_Set
.Set
'Access,
561 W_Socket_Set
.Set
'Access,
562 E_Socket_Set
.Set
'Access,
565 if Res
= Failure
then
566 Raise_Socket_Error
(Socket_Errno
);
569 -- If Select was resumed because of read signalling socket, read this
570 -- data and remove socket from set.
572 if RSig
/= No_Socket
and then Is_Set
(R_Socket_Set
, RSig
) then
573 Clear
(R_Socket_Set
, RSig
);
575 Res
:= Signalling_Fds
.Read
(C
.int
(RSig
));
577 if Res
= Failure
then
578 Raise_Socket_Error
(Socket_Errno
);
587 -- Update socket sets in regard to their new contents
589 Narrow
(R_Socket_Set
);
590 Narrow
(W_Socket_Set
);
591 Narrow
(E_Socket_Set
);
599 (Item
: in out Socket_Set_Type
;
600 Socket
: Socket_Type
)
602 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
605 Check_For_Fd_Set
(Socket
);
607 if Item
.Last
/= No_Socket
then
608 Remove_Socket_From_Set
(Item
.Set
'Access, C
.int
(Socket
));
609 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
610 Item
.Last
:= Socket_Type
(Last
);
618 procedure Close_Selector
(Selector
: in out Selector_Type
) is
620 -- Nothing to do if selector already in closed state
622 if Selector
.Is_Null
or else not Is_Open
(Selector
) then
626 -- Close the signalling file descriptors used internally for the
627 -- implementation of Abort_Selector.
629 Signalling_Fds
.Close
(C
.int
(Selector
.R_Sig_Socket
));
630 Signalling_Fds
.Close
(C
.int
(Selector
.W_Sig_Socket
));
632 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
633 -- (erroneous) subsequent attempt to use this selector properly fails.
635 Selector
.R_Sig_Socket
:= No_Socket
;
636 Selector
.W_Sig_Socket
:= No_Socket
;
643 procedure Close_Socket
(Socket
: Socket_Type
) is
647 Res
:= C_Close
(C
.int
(Socket
));
649 if Res
= Failure
then
650 Raise_Socket_Error
(Socket_Errno
);
658 function Connect_Socket
659 (Socket
: Socket_Type
;
660 Server
: Sock_Addr_Type
) return C
.int
662 Sin
: aliased Sockaddr_In
;
663 Len
: constant C
.int
:= Sin
'Size / 8;
666 if Server
.Family
= Family_Inet6
then
667 raise Socket_Error
with "IPv6 not supported";
670 Set_Family
(Sin
.Sin_Family
, Server
.Family
);
671 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Server
.Addr
));
673 (Sin
'Unchecked_Access,
674 Short_To_Network
(C
.unsigned_short
(Server
.Port
)));
676 return C_Connect
(C
.int
(Socket
), Sin
'Address, Len
);
679 procedure Connect_Socket
680 (Socket
: Socket_Type
;
681 Server
: Sock_Addr_Type
)
684 if Connect_Socket
(Socket
, Server
) = Failure
then
685 Raise_Socket_Error
(Socket_Errno
);
689 procedure Connect_Socket
690 (Socket
: Socket_Type
;
691 Server
: Sock_Addr_Type
;
692 Timeout
: Selector_Duration
;
693 Selector
: access Selector_Type
:= null;
694 Status
: out Selector_Status
)
697 -- Used to set Socket to non-blocking I/O
699 Conn_Err
: aliased Integer;
700 -- Error status of the socket after completion of select(2)
703 Conn_Err_Size
: aliased C
.int
:= Conn_Err
'Size / 8;
704 -- For getsockopt(2) call
707 if Selector
/= null and then not Is_Open
(Selector
.all) then
708 raise Program_Error
with "closed selector";
711 -- Set the socket to non-blocking I/O
713 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> True);
714 Control_Socket
(Socket
, Request
=> Req
);
716 -- Start operation (non-blocking), will return Failure with errno set
719 Res
:= Connect_Socket
(Socket
, Server
);
720 if Res
= Failure
then
721 Conn_Err
:= Socket_Errno
;
722 if Conn_Err
/= SOSC
.EINPROGRESS
then
723 Raise_Socket_Error
(Conn_Err
);
727 -- Wait for socket to become available for writing (unless the Timeout
728 -- is zero, in which case we consider that it has already expired, and
729 -- we do not need to wait at all).
731 if Timeout
= 0.0 then
739 Selector
=> Selector
,
743 -- Check error condition (the asynchronous connect may have terminated
744 -- with an error, e.g. ECONNREFUSED) if select(2) completed.
746 if Status
= Completed
then
748 (C
.int
(Socket
), SOSC
.SOL_SOCKET
, SOSC
.SO_ERROR
,
749 Conn_Err
'Address, Conn_Err_Size
'Access);
752 Conn_Err
:= Socket_Errno
;
759 -- Reset the socket to blocking I/O
761 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> False);
762 Control_Socket
(Socket
, Request
=> Req
);
764 -- Report error condition if any
766 if Conn_Err
/= 0 then
767 Raise_Socket_Error
(Conn_Err
);
775 procedure Control_Socket
776 (Socket
: Socket_Type
;
777 Request
: in out Request_Type
)
784 when Non_Blocking_IO
=>
785 Arg
:= C
.int
(Boolean'Pos (Request
.Enabled
));
787 when N_Bytes_To_Read
=>
792 (C
.int
(Socket
), Requests
(Request
.Name
), Arg
'Unchecked_Access);
794 if Res
= Failure
then
795 Raise_Socket_Error
(Socket_Errno
);
799 when Non_Blocking_IO
=>
802 when N_Bytes_To_Read
=>
803 Request
.Size
:= Natural (Arg
);
812 (Source
: Socket_Set_Type
;
813 Target
: out Socket_Set_Type
)
819 ---------------------
820 -- Create_Selector --
821 ---------------------
823 procedure Create_Selector
(Selector
: out Selector_Type
) is
824 Two_Fds
: aliased Fd_Pair
;
828 if Is_Open
(Selector
) then
829 -- Raise exception to prevent socket descriptor leak
831 raise Program_Error
with "selector already open";
834 -- We open two signalling file descriptors. One of them is used to send
835 -- data to the other, which is included in a C_Select socket set. The
836 -- communication is used to force a call to C_Select to complete, and
837 -- the waiting task to resume its execution.
839 Res
:= Signalling_Fds
.Create
(Two_Fds
'Access);
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
)
861 Res
:= C_Socket
(Families
(Family
), Modes
(Mode
), 0);
863 if Res
= Failure
then
864 Raise_Socket_Error
(Socket_Errno
);
867 Socket
:= Socket_Type
(Res
);
874 procedure Empty
(Item
: out Socket_Set_Type
) is
876 Reset_Socket_Set
(Item
.Set
'Access);
877 Item
.Last
:= No_Socket
;
884 function Err_Code_Image
(E
: Integer) return String is
885 Msg
: String := E
'Img & "] ";
887 Msg
(Msg
'First) := '[';
895 procedure Finalize
(X
: in out Sockets_Library_Controller
) is
896 pragma Unreferenced
(X
);
899 -- Finalization operation for the GNAT.Sockets package
908 procedure Finalize
is
910 -- This is a dummy placeholder for an obsolete API.
911 -- The real finalization actions are in Initialize primitive operation
912 -- of Sockets_Library_Controller.
922 (Item
: in out Socket_Set_Type
;
923 Socket
: out Socket_Type
)
926 L
: aliased C
.int
:= C
.int
(Item
.Last
);
929 if Item
.Last
/= No_Socket
then
931 (Item
.Set
'Access, Last
=> L
'Access, Socket
=> S
'Access);
932 Item
.Last
:= Socket_Type
(L
);
933 Socket
:= Socket_Type
(S
);
944 (Stream
: not null Stream_Access
) return Sock_Addr_Type
947 if Stream
.all in Datagram_Socket_Stream_Type
then
948 return Datagram_Socket_Stream_Type
(Stream
.all).From
;
950 return Get_Peer_Name
(Stream_Socket_Stream_Type
(Stream
.all).Socket
);
954 -------------------------
955 -- Get_Host_By_Address --
956 -------------------------
958 function Get_Host_By_Address
959 (Address
: Inet_Addr_Type
;
960 Family
: Family_Type
:= Family_Inet
) return Host_Entry_Type
962 pragma Unreferenced
(Family
);
964 HA
: aliased In_Addr
:= To_In_Addr
(Address
);
965 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
966 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
967 Res
: aliased Hostent
;
973 if C_Gethostbyaddr
(HA
'Address, HA
'Size / 8, SOSC
.AF_INET
,
974 Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
977 Raise_Host_Error
(Integer (Err
), Image
(Address
));
981 return H
: constant Host_Entry_Type
:=
982 To_Host_Entry
(Res
'Unchecked_Access)
991 end Get_Host_By_Address
;
993 ----------------------
994 -- Get_Host_By_Name --
995 ----------------------
997 function Get_Host_By_Name
(Name
: String) return Host_Entry_Type
is
999 -- If the given name actually is the string representation of
1000 -- an IP address, use Get_Host_By_Address instead.
1002 if Is_IP_Address
(Name
) then
1003 return Get_Host_By_Address
(Inet_Addr
(Name
));
1007 HN
: constant C
.char_array
:= C
.To_C
(Name
);
1008 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1009 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1010 Res
: aliased Hostent
;
1011 Err
: aliased C
.int
;
1017 (HN
, Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
1020 Raise_Host_Error
(Integer (Err
), Name
);
1023 return H
: constant Host_Entry_Type
:=
1024 To_Host_Entry
(Res
'Unchecked_Access)
1029 end Get_Host_By_Name
;
1035 function Get_Peer_Name
(Socket
: Socket_Type
) return Sock_Addr_Type
is
1036 Sin
: aliased Sockaddr_In
;
1037 Len
: aliased C
.int
:= Sin
'Size / 8;
1038 Res
: Sock_Addr_Type
(Family_Inet
);
1041 if C_Getpeername
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
1042 Raise_Socket_Error
(Socket_Errno
);
1045 To_Inet_Addr
(Sin
.Sin_Addr
, Res
.Addr
);
1046 Res
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1051 -------------------------
1052 -- Get_Service_By_Name --
1053 -------------------------
1055 function Get_Service_By_Name
1057 Protocol
: String) return Service_Entry_Type
1059 SN
: constant C
.char_array
:= C
.To_C
(Name
);
1060 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
1061 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1062 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1063 Res
: aliased Servent
;
1068 if C_Getservbyname
(SN
, SP
, Res
'Access, Buf
'Address, Buflen
) /= 0 then
1070 raise Service_Error
with "Service not found";
1073 -- Translate from the C format to the API format
1075 return S
: constant Service_Entry_Type
:=
1076 To_Service_Entry
(Res
'Unchecked_Access)
1080 end Get_Service_By_Name
;
1082 -------------------------
1083 -- Get_Service_By_Port --
1084 -------------------------
1086 function Get_Service_By_Port
1088 Protocol
: String) return Service_Entry_Type
1090 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
1091 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1092 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1093 Res
: aliased Servent
;
1099 (C
.int
(Short_To_Network
(C
.unsigned_short
(Port
))), SP
,
1100 Res
'Access, Buf
'Address, Buflen
) /= 0
1103 raise Service_Error
with "Service not found";
1106 -- Translate from the C format to the API format
1108 return S
: constant Service_Entry_Type
:=
1109 To_Service_Entry
(Res
'Unchecked_Access)
1113 end Get_Service_By_Port
;
1115 ---------------------
1116 -- Get_Socket_Name --
1117 ---------------------
1119 function Get_Socket_Name
1120 (Socket
: Socket_Type
) return Sock_Addr_Type
1122 Sin
: aliased Sockaddr_In
;
1123 Len
: aliased C
.int
:= Sin
'Size / 8;
1125 Addr
: Sock_Addr_Type
:= No_Sock_Addr
;
1128 Res
:= C_Getsockname
(C
.int
(Socket
), Sin
'Address, Len
'Access);
1130 if Res
/= Failure
then
1131 To_Inet_Addr
(Sin
.Sin_Addr
, Addr
.Addr
);
1132 Addr
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1136 end Get_Socket_Name
;
1138 -----------------------
1139 -- Get_Socket_Option --
1140 -----------------------
1142 function Get_Socket_Option
1143 (Socket
: Socket_Type
;
1144 Level
: Level_Type
:= Socket_Level
;
1145 Name
: Option_Name
) return Option_Type
1148 use type C
.unsigned_char
;
1150 V8
: aliased Two_Ints
;
1152 V1
: aliased C
.unsigned_char
;
1153 VT
: aliased Timeval
;
1154 Len
: aliased C
.int
;
1155 Add
: System
.Address
;
1157 Opt
: Option_Type
(Name
);
1161 when Multicast_Loop |
1163 Receive_Packet_Info
=>
1181 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1182 -- struct timeval, but on Windows it is a milliseconds count in
1185 if Target_OS
= Windows
then
1209 if Res
= Failure
then
1210 Raise_Socket_Error
(Socket_Errno
);
1218 Opt
.Enabled
:= (V4
/= 0);
1221 Opt
.Enabled
:= (V8
(V8
'First) /= 0);
1222 Opt
.Seconds
:= Natural (V8
(V8
'Last));
1226 Opt
.Size
:= Natural (V4
);
1229 Opt
.Error
:= Resolve_Error
(Integer (V4
));
1231 when Add_Membership |
1233 To_Inet_Addr
(To_In_Addr
(V8
(V8
'First)), Opt
.Multicast_Address
);
1234 To_Inet_Addr
(To_In_Addr
(V8
(V8
'Last)), Opt
.Local_Interface
);
1236 when Multicast_If
=>
1237 To_Inet_Addr
(To_In_Addr
(V4
), Opt
.Outgoing_If
);
1239 when Multicast_TTL
=>
1240 Opt
.Time_To_Live
:= Integer (V1
);
1242 when Multicast_Loop |
1243 Receive_Packet_Info
=>
1244 Opt
.Enabled
:= (V1
/= 0);
1249 if Target_OS
= Windows
then
1251 -- Timeout is in milliseconds, actual value is 500 ms +
1252 -- returned value (unless it is 0).
1257 Opt
.Timeout
:= Natural (V4
) * 0.001 + 0.500;
1261 Opt
.Timeout
:= To_Duration
(VT
);
1266 end Get_Socket_Option
;
1272 function Host_Name
return String is
1273 Name
: aliased C
.char_array
(1 .. 64);
1277 Res
:= C_Gethostname
(Name
'Address, Name
'Length);
1279 if Res
= Failure
then
1280 Raise_Socket_Error
(Socket_Errno
);
1283 return C
.To_Ada
(Name
);
1291 (Val
: Inet_Addr_VN_Type
;
1292 Hex
: Boolean := False) return String
1294 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1295 -- has at most a length of 3 plus one '.' character.
1297 Buffer
: String (1 .. 4 * Val
'Length);
1298 Length
: Natural := 1;
1299 Separator
: Character;
1301 procedure Img10
(V
: Inet_Addr_Comp_Type
);
1302 -- Append to Buffer image of V in decimal format
1304 procedure Img16
(V
: Inet_Addr_Comp_Type
);
1305 -- Append to Buffer image of V in hexadecimal format
1311 procedure Img10
(V
: Inet_Addr_Comp_Type
) is
1312 Img
: constant String := V
'Img;
1313 Len
: constant Natural := Img
'Length - 1;
1315 Buffer
(Length
.. Length
+ Len
- 1) := Img
(2 .. Img
'Last);
1316 Length
:= Length
+ Len
;
1323 procedure Img16
(V
: Inet_Addr_Comp_Type
) is
1325 Buffer
(Length
) := Hex_To_Char
(Natural (V
/ 16) + 1);
1326 Buffer
(Length
+ 1) := Hex_To_Char
(Natural (V
mod 16) + 1);
1327 Length
:= Length
+ 2;
1330 -- Start of processing for Image
1333 Separator
:= (if Hex
then ':' else '.');
1335 for J
in Val
'Range loop
1342 if J
/= Val
'Last then
1343 Buffer
(Length
) := Separator
;
1344 Length
:= Length
+ 1;
1348 return Buffer
(1 .. Length
- 1);
1355 function Image
(Value
: Inet_Addr_Type
) return String is
1357 if Value
.Family
= Family_Inet
then
1358 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V4
), Hex
=> False);
1360 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V6
), Hex
=> True);
1368 function Image
(Value
: Sock_Addr_Type
) return String is
1369 Port
: constant String := Value
.Port
'Img;
1371 return Image
(Value
.Addr
) & ':' & Port
(2 .. Port
'Last);
1378 function Image
(Socket
: Socket_Type
) return String is
1387 function Image
(Item
: Socket_Set_Type
) return String is
1388 Socket_Set
: Socket_Set_Type
:= Item
;
1392 Last_Img
: constant String := Socket_Set
.Last
'Img;
1394 (1 .. (Integer (Socket_Set
.Last
) + 1) * Last_Img
'Length);
1395 Index
: Positive := 1;
1396 Socket
: Socket_Type
;
1399 while not Is_Empty
(Socket_Set
) loop
1400 Get
(Socket_Set
, Socket
);
1403 Socket_Img
: constant String := Socket
'Img;
1405 Buffer
(Index
.. Index
+ Socket_Img
'Length - 1) := Socket_Img
;
1406 Index
:= Index
+ Socket_Img
'Length;
1410 return "[" & Last_Img
& "]" & Buffer
(1 .. Index
- 1);
1418 function Inet_Addr
(Image
: String) return Inet_Addr_Type
is
1421 Img
: aliased char_array
:= To_C
(Image
);
1422 Addr
: aliased C
.int
;
1424 Result
: Inet_Addr_Type
;
1427 -- Special case for an empty Image as on some platforms (e.g. Windows)
1428 -- calling Inet_Addr("") will not return an error.
1431 Raise_Socket_Error
(SOSC
.EINVAL
);
1434 Res
:= Inet_Pton
(SOSC
.AF_INET
, Img
'Address, Addr
'Address);
1437 Raise_Socket_Error
(Socket_Errno
);
1440 Raise_Socket_Error
(SOSC
.EINVAL
);
1443 To_Inet_Addr
(To_In_Addr
(Addr
), Result
);
1451 procedure Initialize
(X
: in out Sockets_Library_Controller
) is
1452 pragma Unreferenced
(X
);
1462 procedure Initialize
(Process_Blocking_IO
: Boolean) is
1463 Expected
: constant Boolean := not SOSC
.Thread_Blocking_IO
;
1466 if Process_Blocking_IO
/= Expected
then
1467 raise Socket_Error
with
1468 "incorrect Process_Blocking_IO setting, expected " & Expected
'Img;
1471 -- This is a dummy placeholder for an obsolete API
1473 -- Real initialization actions are in Initialize primitive operation
1474 -- of Sockets_Library_Controller.
1483 procedure Initialize
is
1485 -- This is a dummy placeholder for an obsolete API
1487 -- Real initialization actions are in Initialize primitive operation
1488 -- of Sockets_Library_Controller.
1497 function Is_Empty
(Item
: Socket_Set_Type
) return Boolean is
1499 return Item
.Last
= No_Socket
;
1506 function Is_IP_Address
(Name
: String) return Boolean is
1507 Dots
: Natural := 0;
1510 -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
1511 -- and there must be at least one digit around each.
1513 for J
in Name
'Range loop
1514 if Name
(J
) = '.' then
1516 -- Check that the dot is not in first or last position, and that
1517 -- it is followed by a digit. Note that we already know that it is
1518 -- preceded by a digit, or we would have returned earlier on.
1520 if J
in Name
'First + 1 .. Name
'Last - 1
1521 and then Name
(J
+ 1) in '0' .. '9'
1525 -- Definitely not a proper dotted quad
1531 elsif Name
(J
) not in '0' .. '9' then
1536 return Dots
in 1 .. 3;
1543 function Is_Open
(S
: Selector_Type
) return Boolean is
1549 -- Either both controlling socket descriptors are valid (case of an
1550 -- open selector) or neither (case of a closed selector).
1552 pragma Assert
((S
.R_Sig_Socket
/= No_Socket
)
1554 (S
.W_Sig_Socket
/= No_Socket
));
1556 return S
.R_Sig_Socket
/= No_Socket
;
1565 (Item
: Socket_Set_Type
;
1566 Socket
: Socket_Type
) return Boolean
1569 Check_For_Fd_Set
(Socket
);
1571 return Item
.Last
/= No_Socket
1572 and then Socket
<= Item
.Last
1573 and then Is_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
)) /= 0;
1580 procedure Listen_Socket
1581 (Socket
: Socket_Type
;
1582 Length
: Natural := 15)
1584 Res
: constant C
.int
:= C_Listen
(C
.int
(Socket
), C
.int
(Length
));
1586 if Res
= Failure
then
1587 Raise_Socket_Error
(Socket_Errno
);
1595 procedure Narrow
(Item
: in out Socket_Set_Type
) is
1596 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
1598 if Item
.Last
/= No_Socket
then
1599 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
1600 Item
.Last
:= Socket_Type
(Last
);
1608 procedure Netdb_Lock
is
1610 if Need_Netdb_Lock
then
1611 System
.Task_Lock
.Lock
;
1619 procedure Netdb_Unlock
is
1621 if Need_Netdb_Lock
then
1622 System
.Task_Lock
.Unlock
;
1626 --------------------------------
1627 -- Normalize_Empty_Socket_Set --
1628 --------------------------------
1630 procedure Normalize_Empty_Socket_Set
(S
: in out Socket_Set_Type
) is
1632 if S
.Last
= No_Socket
then
1633 Reset_Socket_Set
(S
.Set
'Access);
1635 end Normalize_Empty_Socket_Set
;
1641 function Official_Name
(E
: Host_Entry_Type
) return String is
1643 return To_String
(E
.Official
);
1650 function Official_Name
(S
: Service_Entry_Type
) return String is
1652 return To_String
(S
.Official
);
1655 --------------------
1656 -- Wait_On_Socket --
1657 --------------------
1659 procedure Wait_On_Socket
1660 (Socket
: Socket_Type
;
1662 Timeout
: Selector_Duration
;
1663 Selector
: access Selector_Type
:= null;
1664 Status
: out Selector_Status
)
1666 type Local_Selector_Access
is access Selector_Type
;
1667 for Local_Selector_Access
'Storage_Size use Selector_Type
'Size;
1669 S
: Selector_Access
;
1670 -- Selector to use for waiting
1672 R_Fd_Set
: Socket_Set_Type
;
1673 W_Fd_Set
: Socket_Set_Type
;
1676 -- Create selector if not provided by the user
1678 if Selector
= null then
1680 Local_S
: constant Local_Selector_Access
:= new Selector_Type
;
1682 S
:= Local_S
.all'Unchecked_Access;
1683 Create_Selector
(S
.all);
1687 S
:= Selector
.all'Access;
1691 Set
(R_Fd_Set
, Socket
);
1693 Set
(W_Fd_Set
, Socket
);
1696 Check_Selector
(S
.all, R_Fd_Set
, W_Fd_Set
, Status
, Timeout
);
1698 if Selector
= null then
1699 Close_Selector
(S
.all);
1707 function Port_Number
(S
: Service_Entry_Type
) return Port_Type
is
1716 function Protocol_Name
(S
: Service_Entry_Type
) return String is
1718 return To_String
(S
.Protocol
);
1721 ----------------------
1722 -- Raise_Host_Error --
1723 ----------------------
1725 procedure Raise_Host_Error
(H_Error
: Integer; Name
: String) is
1726 function Dedot
(Value
: String) return String is
1727 (if Value
/= "" and then Value
(Value
'Last) = '.' then
1728 Value
(Value
'First .. Value
'Last - 1)
1731 -- Removes dot at the end of error message
1734 raise Host_Error
with
1735 Err_Code_Image
(H_Error
)
1736 & Dedot
(Host_Error_Messages
.Host_Error_Message
(H_Error
))
1738 end Raise_Host_Error
;
1740 ------------------------
1741 -- Raise_Socket_Error --
1742 ------------------------
1744 procedure Raise_Socket_Error
(Error
: Integer) is
1746 raise Socket_Error
with
1747 Err_Code_Image
(Error
) & Socket_Error_Message
(Error
);
1748 end Raise_Socket_Error
;
1755 (Stream
: in out Datagram_Socket_Stream_Type
;
1756 Item
: out Ada
.Streams
.Stream_Element_Array
;
1757 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1772 (Stream
: in out Stream_Socket_Stream_Type
;
1773 Item
: out Ada
.Streams
.Stream_Element_Array
;
1774 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1776 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1777 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1778 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1782 Receive_Socket
(Stream
.Socket
, Item
(First
.. Max
), Index
);
1785 -- Exit when all or zero data received. Zero means that the socket
1788 exit when Index
< First
or else Index
= Max
;
1794 --------------------
1795 -- Receive_Socket --
1796 --------------------
1798 procedure Receive_Socket
1799 (Socket
: Socket_Type
;
1800 Item
: out Ada
.Streams
.Stream_Element_Array
;
1801 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1802 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1808 C_Recv
(C
.int
(Socket
), Item
'Address, Item
'Length, To_Int
(Flags
));
1810 if Res
= Failure
then
1811 Raise_Socket_Error
(Socket_Errno
);
1814 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1817 --------------------
1818 -- Receive_Socket --
1819 --------------------
1821 procedure Receive_Socket
1822 (Socket
: Socket_Type
;
1823 Item
: out Ada
.Streams
.Stream_Element_Array
;
1824 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1825 From
: out Sock_Addr_Type
;
1826 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1829 Sin
: aliased Sockaddr_In
;
1830 Len
: aliased C
.int
:= Sin
'Size / 8;
1842 if Res
= Failure
then
1843 Raise_Socket_Error
(Socket_Errno
);
1846 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1848 To_Inet_Addr
(Sin
.Sin_Addr
, From
.Addr
);
1849 From
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1852 --------------------
1853 -- Receive_Vector --
1854 --------------------
1856 procedure Receive_Vector
1857 (Socket
: Socket_Type
;
1858 Vector
: Vector_Type
;
1859 Count
: out Ada
.Streams
.Stream_Element_Count
;
1860 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1865 (Msg_Name
=> System
.Null_Address
,
1867 Msg_Iov
=> Vector
'Address,
1869 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1870 -- platforms) when the supplied vector is longer than IOV_MAX,
1871 -- so use minimum of the two lengths.
1873 Msg_Iovlen
=> SOSC
.Msg_Iovlen_T
'Min
1874 (Vector
'Length, SOSC
.IOV_MAX
),
1876 Msg_Control
=> System
.Null_Address
,
1877 Msg_Controllen
=> 0,
1887 if Res
= ssize_t
(Failure
) then
1888 Raise_Socket_Error
(Socket_Errno
);
1891 Count
:= Ada
.Streams
.Stream_Element_Count
(Res
);
1898 function Resolve_Error
1899 (Error_Value
: Integer;
1900 From_Errno
: Boolean := True) return Error_Type
1902 use GNAT
.Sockets
.SOSC
;
1905 if not From_Errno
then
1907 when SOSC
.HOST_NOT_FOUND
=> return Unknown_Host
;
1908 when SOSC
.TRY_AGAIN
=> return Host_Name_Lookup_Failure
;
1909 when SOSC
.NO_RECOVERY
=> return Non_Recoverable_Error
;
1910 when SOSC
.NO_DATA
=> return Unknown_Server_Error
;
1911 when others => return Cannot_Resolve_Error
;
1915 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1916 -- can't include it in the case statement below.
1918 pragma Warnings
(Off
);
1919 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1921 if EAGAIN
/= EWOULDBLOCK
and then Error_Value
= EAGAIN
then
1922 return Resource_Temporarily_Unavailable
;
1925 -- This is not a case statement because if a particular error
1926 -- number constant is not defined, s-oscons-tmplt.c defines
1927 -- it to -1. If multiple constants are not defined, they
1928 -- would each be -1 and result in a "duplicate value in case" error.
1930 -- But we have to leave warnings off because the compiler is also
1931 -- smart enough to note that when two errnos have the same value,
1932 -- the second if condition is useless.
1933 if Error_Value
= ENOERROR
then
1935 elsif Error_Value
= EACCES
then
1936 return Permission_Denied
;
1937 elsif Error_Value
= EADDRINUSE
then
1938 return Address_Already_In_Use
;
1939 elsif Error_Value
= EADDRNOTAVAIL
then
1940 return Cannot_Assign_Requested_Address
;
1941 elsif Error_Value
= EAFNOSUPPORT
then
1942 return Address_Family_Not_Supported_By_Protocol
;
1943 elsif Error_Value
= EALREADY
then
1944 return Operation_Already_In_Progress
;
1945 elsif Error_Value
= EBADF
then
1946 return Bad_File_Descriptor
;
1947 elsif Error_Value
= ECONNABORTED
then
1948 return Software_Caused_Connection_Abort
;
1949 elsif Error_Value
= ECONNREFUSED
then
1950 return Connection_Refused
;
1951 elsif Error_Value
= ECONNRESET
then
1952 return Connection_Reset_By_Peer
;
1953 elsif Error_Value
= EDESTADDRREQ
then
1954 return Destination_Address_Required
;
1955 elsif Error_Value
= EFAULT
then
1957 elsif Error_Value
= EHOSTDOWN
then
1958 return Host_Is_Down
;
1959 elsif Error_Value
= EHOSTUNREACH
then
1960 return No_Route_To_Host
;
1961 elsif Error_Value
= EINPROGRESS
then
1962 return Operation_Now_In_Progress
;
1963 elsif Error_Value
= EINTR
then
1964 return Interrupted_System_Call
;
1965 elsif Error_Value
= EINVAL
then
1966 return Invalid_Argument
;
1967 elsif Error_Value
= EIO
then
1968 return Input_Output_Error
;
1969 elsif Error_Value
= EISCONN
then
1970 return Transport_Endpoint_Already_Connected
;
1971 elsif Error_Value
= ELOOP
then
1972 return Too_Many_Symbolic_Links
;
1973 elsif Error_Value
= EMFILE
then
1974 return Too_Many_Open_Files
;
1975 elsif Error_Value
= EMSGSIZE
then
1976 return Message_Too_Long
;
1977 elsif Error_Value
= ENAMETOOLONG
then
1978 return File_Name_Too_Long
;
1979 elsif Error_Value
= ENETDOWN
then
1980 return Network_Is_Down
;
1981 elsif Error_Value
= ENETRESET
then
1982 return Network_Dropped_Connection_Because_Of_Reset
;
1983 elsif Error_Value
= ENETUNREACH
then
1984 return Network_Is_Unreachable
;
1985 elsif Error_Value
= ENOBUFS
then
1986 return No_Buffer_Space_Available
;
1987 elsif Error_Value
= ENOPROTOOPT
then
1988 return Protocol_Not_Available
;
1989 elsif Error_Value
= ENOTCONN
then
1990 return Transport_Endpoint_Not_Connected
;
1991 elsif Error_Value
= ENOTSOCK
then
1992 return Socket_Operation_On_Non_Socket
;
1993 elsif Error_Value
= EOPNOTSUPP
then
1994 return Operation_Not_Supported
;
1995 elsif Error_Value
= EPFNOSUPPORT
then
1996 return Protocol_Family_Not_Supported
;
1997 elsif Error_Value
= EPIPE
then
1999 elsif Error_Value
= EPROTONOSUPPORT
then
2000 return Protocol_Not_Supported
;
2001 elsif Error_Value
= EPROTOTYPE
then
2002 return Protocol_Wrong_Type_For_Socket
;
2003 elsif Error_Value
= ESHUTDOWN
then
2004 return Cannot_Send_After_Transport_Endpoint_Shutdown
;
2005 elsif Error_Value
= ESOCKTNOSUPPORT
then
2006 return Socket_Type_Not_Supported
;
2007 elsif Error_Value
= ETIMEDOUT
then
2008 return Connection_Timed_Out
;
2009 elsif Error_Value
= ETOOMANYREFS
then
2010 return Too_Many_References
;
2011 elsif Error_Value
= EWOULDBLOCK
then
2012 return Resource_Temporarily_Unavailable
;
2014 return Cannot_Resolve_Error
;
2016 pragma Warnings
(On
);
2020 -----------------------
2021 -- Resolve_Exception --
2022 -----------------------
2024 function Resolve_Exception
2025 (Occurrence
: Exception_Occurrence
) return Error_Type
2027 Id
: constant Exception_Id
:= Exception_Identity
(Occurrence
);
2028 Msg
: constant String := Exception_Message
(Occurrence
);
2035 while First
<= Msg
'Last
2036 and then Msg
(First
) not in '0' .. '9'
2041 if First
> Msg
'Last then
2042 return Cannot_Resolve_Error
;
2046 while Last
< Msg
'Last
2047 and then Msg
(Last
+ 1) in '0' .. '9'
2052 Val
:= Integer'Value (Msg
(First
.. Last
));
2054 if Id
= Socket_Error_Id
then
2055 return Resolve_Error
(Val
);
2057 elsif Id
= Host_Error_Id
then
2058 return Resolve_Error
(Val
, False);
2061 return Cannot_Resolve_Error
;
2063 end Resolve_Exception
;
2069 procedure Send_Socket
2070 (Socket
: Socket_Type
;
2071 Item
: Ada
.Streams
.Stream_Element_Array
;
2072 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2073 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2076 Send_Socket
(Socket
, Item
, Last
, To
=> null, Flags
=> Flags
);
2083 procedure Send_Socket
2084 (Socket
: Socket_Type
;
2085 Item
: Ada
.Streams
.Stream_Element_Array
;
2086 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2087 To
: Sock_Addr_Type
;
2088 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2092 (Socket
, Item
, Last
, To
=> To
'Unrestricted_Access, Flags
=> Flags
);
2099 procedure Send_Socket
2100 (Socket
: Socket_Type
;
2101 Item
: Ada
.Streams
.Stream_Element_Array
;
2102 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2103 To
: access Sock_Addr_Type
;
2104 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2108 Sin
: aliased Sockaddr_In
;
2109 C_To
: System
.Address
;
2114 Set_Family
(Sin
.Sin_Family
, To
.Family
);
2115 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(To
.Addr
));
2117 (Sin
'Unchecked_Access,
2118 Short_To_Network
(C
.unsigned_short
(To
.Port
)));
2119 C_To
:= Sin
'Address;
2120 Len
:= Sin
'Size / 8;
2123 C_To
:= System
.Null_Address
;
2131 Set_Forced_Flags
(To_Int
(Flags
)),
2135 if Res
= Failure
then
2136 Raise_Socket_Error
(Socket_Errno
);
2139 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
2146 procedure Send_Vector
2147 (Socket
: Socket_Type
;
2148 Vector
: Vector_Type
;
2149 Count
: out Ada
.Streams
.Stream_Element_Count
;
2150 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2156 Iov_Count
: SOSC
.Msg_Iovlen_T
;
2157 This_Iov_Count
: SOSC
.Msg_Iovlen_T
;
2163 while Iov_Count
< Vector
'Length loop
2165 pragma Warnings
(Off
);
2166 -- Following test may be compile time known on some targets
2169 (if Vector
'Length - Iov_Count
> SOSC
.IOV_MAX
2171 else Vector
'Length - Iov_Count
);
2173 pragma Warnings
(On
);
2176 (Msg_Name
=> System
.Null_Address
,
2179 (Vector
'First + Integer (Iov_Count
))'Address,
2180 Msg_Iovlen
=> This_Iov_Count
,
2181 Msg_Control
=> System
.Null_Address
,
2182 Msg_Controllen
=> 0,
2189 Set_Forced_Flags
(To_Int
(Flags
)));
2191 if Res
= ssize_t
(Failure
) then
2192 Raise_Socket_Error
(Socket_Errno
);
2195 Count
:= Count
+ Ada
.Streams
.Stream_Element_Count
(Res
);
2196 Iov_Count
:= Iov_Count
+ This_Iov_Count
;
2204 procedure Set
(Item
: in out Socket_Set_Type
; Socket
: Socket_Type
) is
2206 Check_For_Fd_Set
(Socket
);
2208 if Item
.Last
= No_Socket
then
2210 -- Uninitialized socket set, make sure it is properly zeroed out
2212 Reset_Socket_Set
(Item
.Set
'Access);
2213 Item
.Last
:= Socket
;
2215 elsif Item
.Last
< Socket
then
2216 Item
.Last
:= Socket
;
2219 Insert_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
));
2222 -----------------------
2223 -- Set_Close_On_Exec --
2224 -----------------------
2226 procedure Set_Close_On_Exec
2227 (Socket
: Socket_Type
;
2228 Close_On_Exec
: Boolean;
2229 Status
: out Boolean)
2231 function C_Set_Close_On_Exec
2232 (Socket
: Socket_Type
; Close_On_Exec
: C
.int
) return C
.int
;
2233 pragma Import
(C
, C_Set_Close_On_Exec
, "__gnat_set_close_on_exec");
2235 Status
:= C_Set_Close_On_Exec
(Socket
, Boolean'Pos (Close_On_Exec
)) = 0;
2236 end Set_Close_On_Exec
;
2238 ----------------------
2239 -- Set_Forced_Flags --
2240 ----------------------
2242 function Set_Forced_Flags
(F
: C
.int
) return C
.int
is
2243 use type C
.unsigned
;
2244 function To_unsigned
is
2245 new Ada
.Unchecked_Conversion
(C
.int
, C
.unsigned
);
2247 new Ada
.Unchecked_Conversion
(C
.unsigned
, C
.int
);
2249 return To_int
(To_unsigned
(F
) or SOSC
.MSG_Forced_Flags
);
2250 end Set_Forced_Flags
;
2252 -----------------------
2253 -- Set_Socket_Option --
2254 -----------------------
2256 procedure Set_Socket_Option
2257 (Socket
: Socket_Type
;
2258 Level
: Level_Type
:= Socket_Level
;
2259 Option
: Option_Type
)
2263 V8
: aliased Two_Ints
;
2265 V1
: aliased C
.unsigned_char
;
2266 VT
: aliased Timeval
;
2268 Add
: System
.Address
:= Null_Address
;
2277 V4
:= C
.int
(Boolean'Pos (Option
.Enabled
));
2282 V8
(V8
'First) := C
.int
(Boolean'Pos (Option
.Enabled
));
2283 V8
(V8
'Last) := C
.int
(Option
.Seconds
);
2289 V4
:= C
.int
(Option
.Size
);
2294 V4
:= C
.int
(Boolean'Pos (True));
2298 when Add_Membership |
2300 V8
(V8
'First) := To_Int
(To_In_Addr
(Option
.Multicast_Address
));
2301 V8
(V8
'Last) := To_Int
(To_In_Addr
(Option
.Local_Interface
));
2305 when Multicast_If
=>
2306 V4
:= To_Int
(To_In_Addr
(Option
.Outgoing_If
));
2310 when Multicast_TTL
=>
2311 V1
:= C
.unsigned_char
(Option
.Time_To_Live
);
2315 when Multicast_Loop |
2316 Receive_Packet_Info
=>
2317 V1
:= C
.unsigned_char
(Boolean'Pos (Option
.Enabled
));
2324 if Target_OS
= Windows
then
2326 -- On Windows, the timeout is a DWORD in milliseconds, and
2327 -- the actual timeout is 500 ms + the given value (unless it
2330 V4
:= C
.int
(Option
.Timeout
/ 0.001);
2343 VT
:= To_Timeval
(Option
.Timeout
);
2353 Options
(Option
.Name
),
2356 if Res
= Failure
then
2357 Raise_Socket_Error
(Socket_Errno
);
2359 end Set_Socket_Option
;
2361 ----------------------
2362 -- Short_To_Network --
2363 ----------------------
2365 function Short_To_Network
(S
: C
.unsigned_short
) return C
.unsigned_short
is
2366 use type C
.unsigned_short
;
2369 -- Big-endian case. No conversion needed. On these platforms, htons()
2370 -- defaults to a null procedure.
2372 if Default_Bit_Order
= High_Order_First
then
2375 -- Little-endian case. We must swap the high and low bytes of this
2376 -- short to make the port number network compliant.
2379 return (S
/ 256) + (S
mod 256) * 256;
2381 end Short_To_Network
;
2383 ---------------------
2384 -- Shutdown_Socket --
2385 ---------------------
2387 procedure Shutdown_Socket
2388 (Socket
: Socket_Type
;
2389 How
: Shutmode_Type
:= Shut_Read_Write
)
2394 Res
:= C_Shutdown
(C
.int
(Socket
), Shutmodes
(How
));
2396 if Res
= Failure
then
2397 Raise_Socket_Error
(Socket_Errno
);
2399 end Shutdown_Socket
;
2406 (Socket
: Socket_Type
;
2407 Send_To
: Sock_Addr_Type
) return Stream_Access
2409 S
: Datagram_Socket_Stream_Access
;
2412 S
:= new Datagram_Socket_Stream_Type
;
2415 S
.From
:= Get_Socket_Name
(Socket
);
2416 return Stream_Access
(S
);
2423 function Stream
(Socket
: Socket_Type
) return Stream_Access
is
2424 S
: Stream_Socket_Stream_Access
;
2426 S
:= new Stream_Socket_Stream_Type
;
2428 return Stream_Access
(S
);
2435 function To_C
(Socket
: Socket_Type
) return Integer is
2437 return Integer (Socket
);
2444 function To_Duration
(Val
: Timeval
) return Timeval_Duration
is
2446 return Natural (Val
.Tv_Sec
) * 1.0 + Natural (Val
.Tv_Usec
) * 1.0E-6;
2453 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
is
2456 Aliases_Count
, Addresses_Count
: Natural;
2458 -- H_Length is not used because it is currently only ever set to 4, as
2459 -- we only handle the case of H_Addrtype being AF_INET.
2462 if Hostent_H_Addrtype
(E
) /= SOSC
.AF_INET
then
2463 Raise_Socket_Error
(SOSC
.EPFNOSUPPORT
);
2467 while Hostent_H_Alias
(E
, C
.int
(Aliases_Count
)) /= Null_Address
loop
2468 Aliases_Count
:= Aliases_Count
+ 1;
2471 Addresses_Count
:= 0;
2472 while Hostent_H_Addr
(E
, C
.int
(Addresses_Count
)) /= Null_Address
loop
2473 Addresses_Count
:= Addresses_Count
+ 1;
2476 return Result
: Host_Entry_Type
2477 (Aliases_Length
=> Aliases_Count
,
2478 Addresses_Length
=> Addresses_Count
)
2480 Result
.Official
:= To_Name
(Value
(Hostent_H_Name
(E
)));
2482 for J
in Result
.Aliases
'Range loop
2483 Result
.Aliases
(J
) :=
2484 To_Name
(Value
(Hostent_H_Alias
2485 (E
, C
.int
(J
- Result
.Aliases
'First))));
2488 for J
in Result
.Addresses
'Range loop
2492 -- Hostent_H_Addr (E, <index>) may return an address that is
2493 -- not correctly aligned for In_Addr, so we need to use
2494 -- an intermediate copy operation on a type with an alignemnt
2495 -- of 1 to recover the value.
2497 subtype Addr_Buf_T
is C
.char_array
(1 .. Addr
'Size / 8);
2498 Unaligned_Addr
: Addr_Buf_T
;
2499 for Unaligned_Addr
'Address
2500 use Hostent_H_Addr
(E
, C
.int
(J
- Result
.Addresses
'First));
2501 pragma Import
(Ada
, Unaligned_Addr
);
2503 Aligned_Addr
: Addr_Buf_T
;
2504 for Aligned_Addr
'Address use Addr
'Address;
2505 pragma Import
(Ada
, Aligned_Addr
);
2508 Aligned_Addr
:= Unaligned_Addr
;
2509 To_Inet_Addr
(Addr
, Result
.Addresses
(J
));
2519 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
is
2521 if Addr
.Family
= Family_Inet
then
2522 return (S_B1
=> C
.unsigned_char
(Addr
.Sin_V4
(1)),
2523 S_B2
=> C
.unsigned_char
(Addr
.Sin_V4
(2)),
2524 S_B3
=> C
.unsigned_char
(Addr
.Sin_V4
(3)),
2525 S_B4
=> C
.unsigned_char
(Addr
.Sin_V4
(4)));
2528 raise Socket_Error
with "IPv6 not supported";
2535 procedure To_Inet_Addr
2537 Result
: out Inet_Addr_Type
) is
2539 Result
.Sin_V4
(1) := Inet_Addr_Comp_Type
(Addr
.S_B1
);
2540 Result
.Sin_V4
(2) := Inet_Addr_Comp_Type
(Addr
.S_B2
);
2541 Result
.Sin_V4
(3) := Inet_Addr_Comp_Type
(Addr
.S_B3
);
2542 Result
.Sin_V4
(4) := Inet_Addr_Comp_Type
(Addr
.S_B4
);
2549 function To_Int
(F
: Request_Flag_Type
) return C
.int
2551 Current
: Request_Flag_Type
:= F
;
2552 Result
: C
.int
:= 0;
2555 for J
in Flags
'Range loop
2556 exit when Current
= 0;
2558 if Current
mod 2 /= 0 then
2559 if Flags
(J
) = -1 then
2560 Raise_Socket_Error
(SOSC
.EOPNOTSUPP
);
2563 Result
:= Result
+ Flags
(J
);
2566 Current
:= Current
/ 2;
2576 function To_Name
(N
: String) return Name_Type
is
2578 return Name_Type
'(N'Length, N);
2581 ----------------------
2582 -- To_Service_Entry --
2583 ----------------------
2585 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2588 Aliases_Count : Natural;
2592 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2593 Aliases_Count := Aliases_Count + 1;
2596 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2597 Result.Official := To_Name (Value (Servent_S_Name (E)));
2599 for J in Result.Aliases'Range loop
2600 Result.Aliases (J) :=
2601 To_Name (Value (Servent_S_Alias
2602 (E, C.int (J - Result.Aliases'First))));
2605 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2607 Port_Type (Network_To_Short (Servent_S_Port (E)));
2609 end To_Service_Entry;
2615 function To_String (HN : Name_Type) return String is
2617 return HN.Name (1 .. HN.Length);
2624 function To_Timeval (Val : Timeval_Duration) return Timeval is
2629 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2635 -- Normal case where we do round down
2638 S := time_t (Val - 0.5);
2639 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2649 function Value (S : System.Address) return String is
2650 Str : String (1 .. Positive'Last);
2651 for Str'Address use S;
2652 pragma Import (Ada, Str);
2654 Terminator : Positive := Str'First;
2657 while Str (Terminator) /= ASCII.NUL loop
2658 Terminator := Terminator + 1;
2661 return Str (1 .. Terminator - 1);
2669 (Stream : in out Datagram_Socket_Stream_Type;
2670 Item : Ada.Streams.Stream_Element_Array)
2672 Last : Stream_Element_Offset;
2681 -- It is an error if not all of the data has been sent
2683 if Last /= Item'Last then
2684 Raise_Socket_Error (Socket_Errno);
2693 (Stream : in out Stream_Socket_Stream_Type;
2694 Item : Ada.Streams.Stream_Element_Array)
2696 First : Ada.Streams.Stream_Element_Offset;
2697 Index : Ada.Streams.Stream_Element_Offset;
2698 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2701 First := Item'First;
2703 while First <= Max loop
2704 Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
2706 -- Exit when all or zero data sent. Zero means that the socket has
2707 -- been closed by peer.
2709 exit when Index < First or else Index = Max;
2714 -- For an empty array, we have First > Max, and hence Index >= Max (no
2715 -- error, the loop above is never executed). After a successful send,
2716 -- Index = Max. The only remaining case, Index < Max, is therefore
2717 -- always an actual send failure.
2720 Raise_Socket_Error (Socket_Errno);
2724 Sockets_Library_Controller_Object : Sockets_Library_Controller;
2725 pragma Unreferenced (Sockets_Library_Controller_Object);
2726 -- The elaboration and finalization of this object perform the required
2727 -- initialization and cleanup actions for the sockets library.