1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2014, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Streams
; use Ada
.Streams
;
33 with Ada
.Exceptions
; use Ada
.Exceptions
;
34 with Ada
.Finalization
;
35 with Ada
.Unchecked_Conversion
;
37 with Interfaces
.C
.Strings
;
39 with GNAT
.Sockets
.Thin_Common
; use GNAT
.Sockets
.Thin_Common
;
40 with GNAT
.Sockets
.Thin
; use GNAT
.Sockets
.Thin
;
42 with GNAT
.Sockets
.Linker_Options
;
43 pragma Warnings
(Off
, GNAT
.Sockets
.Linker_Options
);
44 -- Need to include pragma Linker_Options which is platform dependent
46 with System
; use System
;
47 with System
.Communication
; use System
.Communication
;
48 with System
.CRTL
; use System
.CRTL
;
49 with System
.Task_Lock
;
51 package body GNAT
.Sockets
is
53 package C
renames Interfaces
.C
;
57 ENOERROR
: constant := 0;
59 Netdb_Buffer_Size
: constant := SOSC
.Need_Netdb_Buffer
* 1024;
60 Need_Netdb_Lock
: constant Boolean := SOSC
.Need_Netdb_Lock
/= 0;
61 -- The network database functions gethostbyname, gethostbyaddr,
62 -- getservbyname and getservbyport can either be guaranteed task safe by
63 -- the operating system, or else return data through a user-provided buffer
64 -- to ensure concurrent uses do not interfere.
66 -- Correspondence tables
68 Levels
: constant array (Level_Type
) of C
.int
:=
69 (Socket_Level
=> SOSC
.SOL_SOCKET
,
70 IP_Protocol_For_IP_Level
=> SOSC
.IPPROTO_IP
,
71 IP_Protocol_For_UDP_Level
=> SOSC
.IPPROTO_UDP
,
72 IP_Protocol_For_TCP_Level
=> SOSC
.IPPROTO_TCP
);
74 Modes
: constant array (Mode_Type
) of C
.int
:=
75 (Socket_Stream
=> SOSC
.SOCK_STREAM
,
76 Socket_Datagram
=> SOSC
.SOCK_DGRAM
);
78 Shutmodes
: constant array (Shutmode_Type
) of C
.int
:=
79 (Shut_Read
=> SOSC
.SHUT_RD
,
80 Shut_Write
=> SOSC
.SHUT_WR
,
81 Shut_Read_Write
=> SOSC
.SHUT_RDWR
);
83 Requests
: constant array (Request_Name
) of SOSC
.IOCTL_Req_T
:=
84 (Non_Blocking_IO
=> SOSC
.FIONBIO
,
85 N_Bytes_To_Read
=> SOSC
.FIONREAD
);
87 Options
: constant array (Option_Name
) of C
.int
:=
88 (Keep_Alive
=> SOSC
.SO_KEEPALIVE
,
89 Reuse_Address
=> SOSC
.SO_REUSEADDR
,
90 Broadcast
=> SOSC
.SO_BROADCAST
,
91 Send_Buffer
=> SOSC
.SO_SNDBUF
,
92 Receive_Buffer
=> SOSC
.SO_RCVBUF
,
93 Linger
=> SOSC
.SO_LINGER
,
94 Error
=> SOSC
.SO_ERROR
,
95 No_Delay
=> SOSC
.TCP_NODELAY
,
96 Add_Membership
=> SOSC
.IP_ADD_MEMBERSHIP
,
97 Drop_Membership
=> SOSC
.IP_DROP_MEMBERSHIP
,
98 Multicast_If
=> SOSC
.IP_MULTICAST_IF
,
99 Multicast_TTL
=> SOSC
.IP_MULTICAST_TTL
,
100 Multicast_Loop
=> SOSC
.IP_MULTICAST_LOOP
,
101 Receive_Packet_Info
=> SOSC
.IP_PKTINFO
,
102 Send_Timeout
=> SOSC
.SO_SNDTIMEO
,
103 Receive_Timeout
=> SOSC
.SO_RCVTIMEO
);
104 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
105 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
107 Flags
: constant array (0 .. 3) of C
.int
:=
108 (0 => SOSC
.MSG_OOB
, -- Process_Out_Of_Band_Data
109 1 => SOSC
.MSG_PEEK
, -- Peek_At_Incoming_Data
110 2 => SOSC
.MSG_WAITALL
, -- Wait_For_A_Full_Reception
111 3 => SOSC
.MSG_EOR
); -- Send_End_Of_Record
113 Socket_Error_Id
: constant Exception_Id
:= Socket_Error
'Identity;
114 Host_Error_Id
: constant Exception_Id
:= Host_Error
'Identity;
116 Hex_To_Char
: constant String (1 .. 16) := "0123456789ABCDEF";
117 -- Use to print in hexadecimal format
119 -----------------------
120 -- Local subprograms --
121 -----------------------
123 function Resolve_Error
124 (Error_Value
: Integer;
125 From_Errno
: Boolean := True) return Error_Type
;
126 -- Associate an enumeration value (error_type) to an error value (errno).
127 -- From_Errno prevents from mixing h_errno with errno.
129 function To_Name
(N
: String) return Name_Type
;
130 function To_String
(HN
: Name_Type
) return String;
131 -- Conversion functions
133 function To_Int
(F
: Request_Flag_Type
) return C
.int
;
134 -- Return the int value corresponding to the specified flags combination
136 function Set_Forced_Flags
(F
: C
.int
) return C
.int
;
137 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
139 function Short_To_Network
140 (S
: C
.unsigned_short
) return C
.unsigned_short
;
141 pragma Inline
(Short_To_Network
);
142 -- Convert a port number into a network port number
144 function Network_To_Short
145 (S
: C
.unsigned_short
) return C
.unsigned_short
146 renames Short_To_Network
;
147 -- Symmetric operation
150 (Val
: Inet_Addr_VN_Type
;
151 Hex
: Boolean := False) return String;
152 -- Output an array of inet address components in hex or decimal mode
154 function Is_IP_Address
(Name
: String) return Boolean;
155 -- Return true when Name is an IP address in standard dot notation
157 procedure Netdb_Lock
;
158 pragma Inline
(Netdb_Lock
);
159 procedure Netdb_Unlock
;
160 pragma Inline
(Netdb_Unlock
);
161 -- Lock/unlock operation used to protect netdb access for platforms that
162 -- require such protection.
164 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
;
165 procedure To_Inet_Addr
167 Result
: out Inet_Addr_Type
);
168 -- Conversion functions
170 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
;
171 -- Conversion function
173 function To_Service_Entry
(E
: Servent_Access
) return Service_Entry_Type
;
174 -- Conversion function
176 function Value
(S
: System
.Address
) return String;
177 -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS,
178 -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
180 function To_Timeval
(Val
: Timeval_Duration
) return Timeval
;
181 -- Separate Val in seconds and microseconds
183 function To_Duration
(Val
: Timeval
) return Timeval_Duration
;
184 -- Reconstruct a Duration value from a Timeval record (seconds and
187 procedure Raise_Socket_Error
(Error
: Integer);
188 -- Raise Socket_Error with an exception message describing the error code
191 procedure Raise_Host_Error
(H_Error
: Integer);
192 -- Raise Host_Error exception with message describing error code (note
193 -- hstrerror seems to be obsolete) from h_errno.
195 procedure Narrow
(Item
: in out Socket_Set_Type
);
196 -- Update Last as it may be greater than the real last socket
198 procedure Check_For_Fd_Set
(Fd
: Socket_Type
);
199 pragma Inline
(Check_For_Fd_Set
);
200 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
201 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
203 function Connect_Socket
204 (Socket
: Socket_Type
;
205 Server
: Sock_Addr_Type
) return C
.int
;
206 pragma Inline
(Connect_Socket
);
207 -- Underlying implementation for the Connect_Socket procedures
209 -- Types needed for Datagram_Socket_Stream_Type
211 type Datagram_Socket_Stream_Type
is new Root_Stream_Type
with record
212 Socket
: Socket_Type
;
214 From
: Sock_Addr_Type
;
217 type Datagram_Socket_Stream_Access
is
218 access all Datagram_Socket_Stream_Type
;
221 (Stream
: in out Datagram_Socket_Stream_Type
;
222 Item
: out Ada
.Streams
.Stream_Element_Array
;
223 Last
: out Ada
.Streams
.Stream_Element_Offset
);
226 (Stream
: in out Datagram_Socket_Stream_Type
;
227 Item
: Ada
.Streams
.Stream_Element_Array
);
229 -- Types needed for Stream_Socket_Stream_Type
231 type Stream_Socket_Stream_Type
is new Root_Stream_Type
with record
232 Socket
: Socket_Type
;
235 type Stream_Socket_Stream_Access
is
236 access all Stream_Socket_Stream_Type
;
239 (Stream
: in out Stream_Socket_Stream_Type
;
240 Item
: out Ada
.Streams
.Stream_Element_Array
;
241 Last
: out Ada
.Streams
.Stream_Element_Offset
);
244 (Stream
: in out Stream_Socket_Stream_Type
;
245 Item
: Ada
.Streams
.Stream_Element_Array
);
247 procedure Wait_On_Socket
248 (Socket
: Socket_Type
;
250 Timeout
: Selector_Duration
;
251 Selector
: access Selector_Type
:= null;
252 Status
: out Selector_Status
);
253 -- Common code for variants of socket operations supporting a timeout:
254 -- block in Check_Selector on Socket for at most the indicated timeout.
255 -- If For_Read is True, Socket is added to the read set for this call, else
256 -- it is added to the write set. If no selector is provided, a local one is
257 -- created for this call and destroyed prior to returning.
259 type Sockets_Library_Controller
is new Ada
.Finalization
.Limited_Controlled
261 -- This type is used to generate automatic calls to Initialize and Finalize
262 -- during the elaboration and finalization of this package. A single object
263 -- of this type must exist at library level.
265 function Err_Code_Image
(E
: Integer) return String;
266 -- Return the value of E surrounded with brackets
268 procedure Initialize
(X
: in out Sockets_Library_Controller
);
269 procedure Finalize
(X
: in out Sockets_Library_Controller
);
271 procedure Normalize_Empty_Socket_Set
(S
: in out Socket_Set_Type
);
272 -- If S is the empty set (detected by Last = No_Socket), make sure its
273 -- fd_set component is actually cleared. Note that the case where it is
274 -- not can occur for an uninitialized Socket_Set_Type object.
276 function Is_Open
(S
: Selector_Type
) return Boolean;
277 -- Return True for an "open" Selector_Type object, i.e. one for which
278 -- Create_Selector has been called and Close_Selector has not been called,
279 -- or the null selector.
285 function "+" (L
, R
: Request_Flag_Type
) return Request_Flag_Type
is
294 procedure Abort_Selector
(Selector
: Selector_Type
) is
298 if not Is_Open
(Selector
) then
299 raise Program_Error
with "closed selector";
301 elsif Selector
.Is_Null
then
302 raise Program_Error
with "null selector";
306 -- Send one byte to unblock select system call
308 Res
:= Signalling_Fds
.Write
(C
.int
(Selector
.W_Sig_Socket
));
310 if Res
= Failure
then
311 Raise_Socket_Error
(Socket_Errno
);
319 procedure Accept_Socket
320 (Server
: Socket_Type
;
321 Socket
: out Socket_Type
;
322 Address
: out Sock_Addr_Type
)
325 Sin
: aliased Sockaddr_In
;
326 Len
: aliased C
.int
:= Sin
'Size / 8;
329 Res
:= C_Accept
(C
.int
(Server
), Sin
'Address, Len
'Access);
331 if Res
= Failure
then
332 Raise_Socket_Error
(Socket_Errno
);
335 Socket
:= Socket_Type
(Res
);
337 To_Inet_Addr
(Sin
.Sin_Addr
, Address
.Addr
);
338 Address
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
345 procedure Accept_Socket
346 (Server
: Socket_Type
;
347 Socket
: out Socket_Type
;
348 Address
: out Sock_Addr_Type
;
349 Timeout
: Selector_Duration
;
350 Selector
: access Selector_Type
:= null;
351 Status
: out Selector_Status
)
354 if Selector
/= null and then not Is_Open
(Selector
.all) then
355 raise Program_Error
with "closed selector";
358 -- Wait for socket to become available for reading
364 Selector
=> Selector
,
367 -- Accept connection if available
369 if Status
= Completed
then
370 Accept_Socket
(Server
, Socket
, Address
);
381 (E
: Host_Entry_Type
;
382 N
: Positive := 1) return Inet_Addr_Type
385 return E
.Addresses
(N
);
388 ----------------------
389 -- Addresses_Length --
390 ----------------------
392 function Addresses_Length
(E
: Host_Entry_Type
) return Natural is
394 return E
.Addresses_Length
;
395 end Addresses_Length
;
402 (E
: Host_Entry_Type
;
403 N
: Positive := 1) return String
406 return To_String
(E
.Aliases
(N
));
414 (S
: Service_Entry_Type
;
415 N
: Positive := 1) return String
418 return To_String
(S
.Aliases
(N
));
425 function Aliases_Length
(E
: Host_Entry_Type
) return Natural is
427 return E
.Aliases_Length
;
434 function Aliases_Length
(S
: Service_Entry_Type
) return Natural is
436 return S
.Aliases_Length
;
443 procedure Bind_Socket
444 (Socket
: Socket_Type
;
445 Address
: Sock_Addr_Type
)
448 Sin
: aliased Sockaddr_In
;
449 Len
: constant C
.int
:= Sin
'Size / 8;
450 -- This assumes that Address.Family = Family_Inet???
453 if Address
.Family
= Family_Inet6
then
454 raise Socket_Error
with "IPv6 not supported";
457 Set_Family
(Sin
.Sin_Family
, Address
.Family
);
458 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Address
.Addr
));
460 (Sin
'Unchecked_Access,
461 Short_To_Network
(C
.unsigned_short
(Address
.Port
)));
463 Res
:= C_Bind
(C
.int
(Socket
), Sin
'Address, Len
);
465 if Res
= Failure
then
466 Raise_Socket_Error
(Socket_Errno
);
470 ----------------------
471 -- Check_For_Fd_Set --
472 ----------------------
474 procedure Check_For_Fd_Set
(Fd
: Socket_Type
) is
478 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
479 -- no check required. Warnings suppressed because condition
480 -- is known at compile time.
482 if Target_OS
= Windows
then
486 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
487 -- that Fd is within range (otherwise behaviour is undefined).
489 elsif Fd
< 0 or else Fd
>= SOSC
.FD_SETSIZE
then
490 raise Constraint_Error
491 with "invalid value for socket set: " & Image
(Fd
);
493 end Check_For_Fd_Set
;
499 procedure Check_Selector
500 (Selector
: Selector_Type
;
501 R_Socket_Set
: in out Socket_Set_Type
;
502 W_Socket_Set
: in out Socket_Set_Type
;
503 Status
: out Selector_Status
;
504 Timeout
: Selector_Duration
:= Forever
)
506 E_Socket_Set
: Socket_Set_Type
;
509 (Selector
, R_Socket_Set
, W_Socket_Set
, E_Socket_Set
, Status
, Timeout
);
512 procedure Check_Selector
513 (Selector
: Selector_Type
;
514 R_Socket_Set
: in out Socket_Set_Type
;
515 W_Socket_Set
: in out Socket_Set_Type
;
516 E_Socket_Set
: in out Socket_Set_Type
;
517 Status
: out Selector_Status
;
518 Timeout
: Selector_Duration
:= Forever
)
522 RSig
: Socket_Type
:= No_Socket
;
523 TVal
: aliased Timeval
;
524 TPtr
: Timeval_Access
;
527 if not Is_Open
(Selector
) then
528 raise Program_Error
with "closed selector";
533 -- No timeout or Forever is indicated by a null timeval pointer
535 if Timeout
= Forever
then
538 TVal
:= To_Timeval
(Timeout
);
539 TPtr
:= TVal
'Unchecked_Access;
542 -- Add read signalling socket, if present
544 if not Selector
.Is_Null
then
545 RSig
:= Selector
.R_Sig_Socket
;
546 Set
(R_Socket_Set
, RSig
);
549 Last
:= C
.int
'Max (C
.int
'Max (C
.int
(R_Socket_Set
.Last
),
550 C
.int
(W_Socket_Set
.Last
)),
551 C
.int
(E_Socket_Set
.Last
));
553 -- Zero out fd_set for empty Socket_Set_Type objects
555 Normalize_Empty_Socket_Set
(R_Socket_Set
);
556 Normalize_Empty_Socket_Set
(W_Socket_Set
);
557 Normalize_Empty_Socket_Set
(E_Socket_Set
);
562 R_Socket_Set
.Set
'Access,
563 W_Socket_Set
.Set
'Access,
564 E_Socket_Set
.Set
'Access,
567 if Res
= Failure
then
568 Raise_Socket_Error
(Socket_Errno
);
571 -- If Select was resumed because of read signalling socket, read this
572 -- data and remove socket from set.
574 if RSig
/= No_Socket
and then Is_Set
(R_Socket_Set
, RSig
) then
575 Clear
(R_Socket_Set
, RSig
);
577 Res
:= Signalling_Fds
.Read
(C
.int
(RSig
));
579 if Res
= Failure
then
580 Raise_Socket_Error
(Socket_Errno
);
589 -- Update socket sets in regard to their new contents
591 Narrow
(R_Socket_Set
);
592 Narrow
(W_Socket_Set
);
593 Narrow
(E_Socket_Set
);
601 (Item
: in out Socket_Set_Type
;
602 Socket
: Socket_Type
)
604 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
607 Check_For_Fd_Set
(Socket
);
609 if Item
.Last
/= No_Socket
then
610 Remove_Socket_From_Set
(Item
.Set
'Access, C
.int
(Socket
));
611 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
612 Item
.Last
:= Socket_Type
(Last
);
620 procedure Close_Selector
(Selector
: in out Selector_Type
) is
622 -- Nothing to do if selector already in closed state
624 if Selector
.Is_Null
or else not Is_Open
(Selector
) then
628 -- Close the signalling file descriptors used internally for the
629 -- implementation of Abort_Selector.
631 Signalling_Fds
.Close
(C
.int
(Selector
.R_Sig_Socket
));
632 Signalling_Fds
.Close
(C
.int
(Selector
.W_Sig_Socket
));
634 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
635 -- (erroneous) subsequent attempt to use this selector properly fails.
637 Selector
.R_Sig_Socket
:= No_Socket
;
638 Selector
.W_Sig_Socket
:= No_Socket
;
645 procedure Close_Socket
(Socket
: Socket_Type
) is
649 Res
:= C_Close
(C
.int
(Socket
));
651 if Res
= Failure
then
652 Raise_Socket_Error
(Socket_Errno
);
660 function Connect_Socket
661 (Socket
: Socket_Type
;
662 Server
: Sock_Addr_Type
) return C
.int
664 Sin
: aliased Sockaddr_In
;
665 Len
: constant C
.int
:= Sin
'Size / 8;
668 if Server
.Family
= Family_Inet6
then
669 raise Socket_Error
with "IPv6 not supported";
672 Set_Family
(Sin
.Sin_Family
, Server
.Family
);
673 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Server
.Addr
));
675 (Sin
'Unchecked_Access,
676 Short_To_Network
(C
.unsigned_short
(Server
.Port
)));
678 return C_Connect
(C
.int
(Socket
), Sin
'Address, Len
);
681 procedure Connect_Socket
682 (Socket
: Socket_Type
;
683 Server
: Sock_Addr_Type
)
686 if Connect_Socket
(Socket
, Server
) = Failure
then
687 Raise_Socket_Error
(Socket_Errno
);
691 procedure Connect_Socket
692 (Socket
: Socket_Type
;
693 Server
: Sock_Addr_Type
;
694 Timeout
: Selector_Duration
;
695 Selector
: access Selector_Type
:= null;
696 Status
: out Selector_Status
)
699 -- Used to set Socket to non-blocking I/O
701 Conn_Err
: aliased Integer;
702 -- Error status of the socket after completion of select(2)
705 Conn_Err_Size
: aliased C
.int
:= Conn_Err
'Size / 8;
706 -- For getsockopt(2) call
709 if Selector
/= null and then not Is_Open
(Selector
.all) then
710 raise Program_Error
with "closed selector";
713 -- Set the socket to non-blocking I/O
715 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> True);
716 Control_Socket
(Socket
, Request
=> Req
);
718 -- Start operation (non-blocking), will return Failure with errno set
721 Res
:= Connect_Socket
(Socket
, Server
);
722 if Res
= Failure
then
723 Conn_Err
:= Socket_Errno
;
724 if Conn_Err
/= SOSC
.EINPROGRESS
then
725 Raise_Socket_Error
(Conn_Err
);
729 -- Wait for socket to become available for writing (unless the Timeout
730 -- is zero, in which case we consider that it has already expired, and
731 -- we do not need to wait at all).
733 if Timeout
= 0.0 then
741 Selector
=> Selector
,
745 -- Check error condition (the asynchronous connect may have terminated
746 -- with an error, e.g. ECONNREFUSED) if select(2) completed.
748 if Status
= Completed
then
750 (C
.int
(Socket
), SOSC
.SOL_SOCKET
, SOSC
.SO_ERROR
,
751 Conn_Err
'Address, Conn_Err_Size
'Access);
754 Conn_Err
:= Socket_Errno
;
761 -- Reset the socket to blocking I/O
763 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> False);
764 Control_Socket
(Socket
, Request
=> Req
);
766 -- Report error condition if any
768 if Conn_Err
/= 0 then
769 Raise_Socket_Error
(Conn_Err
);
777 procedure Control_Socket
778 (Socket
: Socket_Type
;
779 Request
: in out Request_Type
)
786 when Non_Blocking_IO
=>
787 Arg
:= C
.int
(Boolean'Pos (Request
.Enabled
));
789 when N_Bytes_To_Read
=>
794 (C
.int
(Socket
), Requests
(Request
.Name
), Arg
'Unchecked_Access);
796 if Res
= Failure
then
797 Raise_Socket_Error
(Socket_Errno
);
801 when Non_Blocking_IO
=>
804 when N_Bytes_To_Read
=>
805 Request
.Size
:= Natural (Arg
);
814 (Source
: Socket_Set_Type
;
815 Target
: out Socket_Set_Type
)
821 ---------------------
822 -- Create_Selector --
823 ---------------------
825 procedure Create_Selector
(Selector
: out Selector_Type
) is
826 Two_Fds
: aliased Fd_Pair
;
830 if Is_Open
(Selector
) then
831 -- Raise exception to prevent socket descriptor leak
833 raise Program_Error
with "selector already open";
836 -- We open two signalling file descriptors. One of them is used to send
837 -- data to the other, which is included in a C_Select socket set. The
838 -- communication is used to force a call to C_Select to complete, and
839 -- the waiting task to resume its execution.
841 Res
:= Signalling_Fds
.Create
(Two_Fds
'Access);
843 if Res
= Failure
then
844 Raise_Socket_Error
(Socket_Errno
);
847 Selector
.R_Sig_Socket
:= Socket_Type
(Two_Fds
(Read_End
));
848 Selector
.W_Sig_Socket
:= Socket_Type
(Two_Fds
(Write_End
));
855 procedure Create_Socket
856 (Socket
: out Socket_Type
;
857 Family
: Family_Type
:= Family_Inet
;
858 Mode
: Mode_Type
:= Socket_Stream
)
863 Res
:= C_Socket
(Families
(Family
), Modes
(Mode
), 0);
865 if Res
= Failure
then
866 Raise_Socket_Error
(Socket_Errno
);
869 Socket
:= Socket_Type
(Res
);
876 procedure Empty
(Item
: out Socket_Set_Type
) is
878 Reset_Socket_Set
(Item
.Set
'Access);
879 Item
.Last
:= No_Socket
;
886 function Err_Code_Image
(E
: Integer) return String is
887 Msg
: String := E
'Img & "] ";
889 Msg
(Msg
'First) := '[';
897 procedure Finalize
(X
: in out Sockets_Library_Controller
) is
898 pragma Unreferenced
(X
);
901 -- Finalization operation for the GNAT.Sockets package
910 procedure Finalize
is
912 -- This is a dummy placeholder for an obsolete API.
913 -- The real finalization actions are in Initialize primitive operation
914 -- of Sockets_Library_Controller.
924 (Item
: in out Socket_Set_Type
;
925 Socket
: out Socket_Type
)
928 L
: aliased C
.int
:= C
.int
(Item
.Last
);
931 if Item
.Last
/= No_Socket
then
933 (Item
.Set
'Access, Last
=> L
'Access, Socket
=> S
'Access);
934 Item
.Last
:= Socket_Type
(L
);
935 Socket
:= Socket_Type
(S
);
946 (Stream
: not null Stream_Access
) return Sock_Addr_Type
949 if Stream
.all in Datagram_Socket_Stream_Type
then
950 return Datagram_Socket_Stream_Type
(Stream
.all).From
;
952 return Get_Peer_Name
(Stream_Socket_Stream_Type
(Stream
.all).Socket
);
956 -------------------------
957 -- Get_Host_By_Address --
958 -------------------------
960 function Get_Host_By_Address
961 (Address
: Inet_Addr_Type
;
962 Family
: Family_Type
:= Family_Inet
) return Host_Entry_Type
964 pragma Unreferenced
(Family
);
966 HA
: aliased In_Addr
:= To_In_Addr
(Address
);
967 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
968 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
969 Res
: aliased Hostent
;
975 if C_Gethostbyaddr
(HA
'Address, HA
'Size / 8, SOSC
.AF_INET
,
976 Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
979 Raise_Host_Error
(Integer (Err
));
982 return H
: constant Host_Entry_Type
:=
983 To_Host_Entry
(Res
'Unchecked_Access)
987 end Get_Host_By_Address
;
989 ----------------------
990 -- Get_Host_By_Name --
991 ----------------------
993 function Get_Host_By_Name
(Name
: String) return Host_Entry_Type
is
995 -- Detect IP address name and redirect to Inet_Addr
997 if Is_IP_Address
(Name
) then
998 return Get_Host_By_Address
(Inet_Addr
(Name
));
1002 HN
: constant C
.char_array
:= C
.To_C
(Name
);
1003 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1004 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1005 Res
: aliased Hostent
;
1006 Err
: aliased C
.int
;
1012 (HN
, Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
1015 Raise_Host_Error
(Integer (Err
));
1018 return H
: constant Host_Entry_Type
:=
1019 To_Host_Entry
(Res
'Unchecked_Access)
1024 end Get_Host_By_Name
;
1030 function Get_Peer_Name
(Socket
: Socket_Type
) return Sock_Addr_Type
is
1031 Sin
: aliased Sockaddr_In
;
1032 Len
: aliased C
.int
:= Sin
'Size / 8;
1033 Res
: Sock_Addr_Type
(Family_Inet
);
1036 if C_Getpeername
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
1037 Raise_Socket_Error
(Socket_Errno
);
1040 To_Inet_Addr
(Sin
.Sin_Addr
, Res
.Addr
);
1041 Res
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1046 -------------------------
1047 -- Get_Service_By_Name --
1048 -------------------------
1050 function Get_Service_By_Name
1052 Protocol
: String) return Service_Entry_Type
1054 SN
: constant C
.char_array
:= C
.To_C
(Name
);
1055 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
1056 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1057 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1058 Res
: aliased Servent
;
1063 if C_Getservbyname
(SN
, SP
, Res
'Access, Buf
'Address, Buflen
) /= 0 then
1065 raise Service_Error
with "Service not found";
1068 -- Translate from the C format to the API format
1070 return S
: constant Service_Entry_Type
:=
1071 To_Service_Entry
(Res
'Unchecked_Access)
1075 end Get_Service_By_Name
;
1077 -------------------------
1078 -- Get_Service_By_Port --
1079 -------------------------
1081 function Get_Service_By_Port
1083 Protocol
: String) return Service_Entry_Type
1085 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
1086 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1087 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1088 Res
: aliased Servent
;
1094 (C
.int
(Short_To_Network
(C
.unsigned_short
(Port
))), SP
,
1095 Res
'Access, Buf
'Address, Buflen
) /= 0
1098 raise Service_Error
with "Service not found";
1101 -- Translate from the C format to the API format
1103 return S
: constant Service_Entry_Type
:=
1104 To_Service_Entry
(Res
'Unchecked_Access)
1108 end Get_Service_By_Port
;
1110 ---------------------
1111 -- Get_Socket_Name --
1112 ---------------------
1114 function Get_Socket_Name
1115 (Socket
: Socket_Type
) return Sock_Addr_Type
1117 Sin
: aliased Sockaddr_In
;
1118 Len
: aliased C
.int
:= Sin
'Size / 8;
1120 Addr
: Sock_Addr_Type
:= No_Sock_Addr
;
1123 Res
:= C_Getsockname
(C
.int
(Socket
), Sin
'Address, Len
'Access);
1125 if Res
/= Failure
then
1126 To_Inet_Addr
(Sin
.Sin_Addr
, Addr
.Addr
);
1127 Addr
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1131 end Get_Socket_Name
;
1133 -----------------------
1134 -- Get_Socket_Option --
1135 -----------------------
1137 function Get_Socket_Option
1138 (Socket
: Socket_Type
;
1139 Level
: Level_Type
:= Socket_Level
;
1140 Name
: Option_Name
) return Option_Type
1143 use type C
.unsigned_char
;
1145 V8
: aliased Two_Ints
;
1147 V1
: aliased C
.unsigned_char
;
1148 VT
: aliased Timeval
;
1149 Len
: aliased C
.int
;
1150 Add
: System
.Address
;
1152 Opt
: Option_Type
(Name
);
1156 when Multicast_Loop |
1158 Receive_Packet_Info
=>
1176 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1177 -- struct timeval, but on Windows it is a milliseconds count in
1180 if Target_OS
= Windows
then
1204 if Res
= Failure
then
1205 Raise_Socket_Error
(Socket_Errno
);
1213 Opt
.Enabled
:= (V4
/= 0);
1216 Opt
.Enabled
:= (V8
(V8
'First) /= 0);
1217 Opt
.Seconds
:= Natural (V8
(V8
'Last));
1221 Opt
.Size
:= Natural (V4
);
1224 Opt
.Error
:= Resolve_Error
(Integer (V4
));
1226 when Add_Membership |
1228 To_Inet_Addr
(To_In_Addr
(V8
(V8
'First)), Opt
.Multicast_Address
);
1229 To_Inet_Addr
(To_In_Addr
(V8
(V8
'Last)), Opt
.Local_Interface
);
1231 when Multicast_If
=>
1232 To_Inet_Addr
(To_In_Addr
(V4
), Opt
.Outgoing_If
);
1234 when Multicast_TTL
=>
1235 Opt
.Time_To_Live
:= Integer (V1
);
1237 when Multicast_Loop |
1238 Receive_Packet_Info
=>
1239 Opt
.Enabled
:= (V1
/= 0);
1244 if Target_OS
= Windows
then
1246 -- Timeout is in milliseconds, actual value is 500 ms +
1247 -- returned value (unless it is 0).
1252 Opt
.Timeout
:= Natural (V4
) * 0.001 + 0.500;
1256 Opt
.Timeout
:= To_Duration
(VT
);
1261 end Get_Socket_Option
;
1267 function Host_Name
return String is
1268 Name
: aliased C
.char_array
(1 .. 64);
1272 Res
:= C_Gethostname
(Name
'Address, Name
'Length);
1274 if Res
= Failure
then
1275 Raise_Socket_Error
(Socket_Errno
);
1278 return C
.To_Ada
(Name
);
1286 (Val
: Inet_Addr_VN_Type
;
1287 Hex
: Boolean := False) return String
1289 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1290 -- has at most a length of 3 plus one '.' character.
1292 Buffer
: String (1 .. 4 * Val
'Length);
1293 Length
: Natural := 1;
1294 Separator
: Character;
1296 procedure Img10
(V
: Inet_Addr_Comp_Type
);
1297 -- Append to Buffer image of V in decimal format
1299 procedure Img16
(V
: Inet_Addr_Comp_Type
);
1300 -- Append to Buffer image of V in hexadecimal format
1306 procedure Img10
(V
: Inet_Addr_Comp_Type
) is
1307 Img
: constant String := V
'Img;
1308 Len
: constant Natural := Img
'Length - 1;
1310 Buffer
(Length
.. Length
+ Len
- 1) := Img
(2 .. Img
'Last);
1311 Length
:= Length
+ Len
;
1318 procedure Img16
(V
: Inet_Addr_Comp_Type
) is
1320 Buffer
(Length
) := Hex_To_Char
(Natural (V
/ 16) + 1);
1321 Buffer
(Length
+ 1) := Hex_To_Char
(Natural (V
mod 16) + 1);
1322 Length
:= Length
+ 2;
1325 -- Start of processing for Image
1328 Separator
:= (if Hex
then ':' else '.');
1330 for J
in Val
'Range loop
1337 if J
/= Val
'Last then
1338 Buffer
(Length
) := Separator
;
1339 Length
:= Length
+ 1;
1343 return Buffer
(1 .. Length
- 1);
1350 function Image
(Value
: Inet_Addr_Type
) return String is
1352 if Value
.Family
= Family_Inet
then
1353 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V4
), Hex
=> False);
1355 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V6
), Hex
=> True);
1363 function Image
(Value
: Sock_Addr_Type
) return String is
1364 Port
: constant String := Value
.Port
'Img;
1366 return Image
(Value
.Addr
) & ':' & Port
(2 .. Port
'Last);
1373 function Image
(Socket
: Socket_Type
) return String is
1382 function Image
(Item
: Socket_Set_Type
) return String is
1383 Socket_Set
: Socket_Set_Type
:= Item
;
1387 Last_Img
: constant String := Socket_Set
.Last
'Img;
1389 (1 .. (Integer (Socket_Set
.Last
) + 1) * Last_Img
'Length);
1390 Index
: Positive := 1;
1391 Socket
: Socket_Type
;
1394 while not Is_Empty
(Socket_Set
) loop
1395 Get
(Socket_Set
, Socket
);
1398 Socket_Img
: constant String := Socket
'Img;
1400 Buffer
(Index
.. Index
+ Socket_Img
'Length - 1) := Socket_Img
;
1401 Index
:= Index
+ Socket_Img
'Length;
1405 return "[" & Last_Img
& "]" & Buffer
(1 .. Index
- 1);
1413 function Inet_Addr
(Image
: String) return Inet_Addr_Type
is
1415 use Interfaces
.C
.Strings
;
1417 Img
: aliased char_array
:= To_C
(Image
);
1418 Addr
: aliased C
.int
;
1420 Result
: Inet_Addr_Type
;
1423 -- Special case for an empty Image as on some platforms (e.g. Windows)
1424 -- calling Inet_Addr("") will not return an error.
1427 Raise_Socket_Error
(SOSC
.EINVAL
);
1430 Res
:= Inet_Pton
(SOSC
.AF_INET
, Img
'Address, Addr
'Address);
1433 Raise_Socket_Error
(Socket_Errno
);
1436 Raise_Socket_Error
(SOSC
.EINVAL
);
1439 To_Inet_Addr
(To_In_Addr
(Addr
), Result
);
1447 procedure Initialize
(X
: in out Sockets_Library_Controller
) is
1448 pragma Unreferenced
(X
);
1458 procedure Initialize
(Process_Blocking_IO
: Boolean) is
1459 Expected
: constant Boolean := not SOSC
.Thread_Blocking_IO
;
1462 if Process_Blocking_IO
/= Expected
then
1463 raise Socket_Error
with
1464 "incorrect Process_Blocking_IO setting, expected " & Expected
'Img;
1467 -- This is a dummy placeholder for an obsolete API
1469 -- Real initialization actions are in Initialize primitive operation
1470 -- of Sockets_Library_Controller.
1479 procedure Initialize
is
1481 -- This is a dummy placeholder for an obsolete API
1483 -- Real initialization actions are in Initialize primitive operation
1484 -- of Sockets_Library_Controller.
1493 function Is_Empty
(Item
: Socket_Set_Type
) return Boolean is
1495 return Item
.Last
= No_Socket
;
1502 function Is_IP_Address
(Name
: String) return Boolean is
1504 for J
in Name
'Range loop
1506 and then Name
(J
) not in '0' .. '9'
1519 function Is_Open
(S
: Selector_Type
) return Boolean is
1525 -- Either both controlling socket descriptors are valid (case of an
1526 -- open selector) or neither (case of a closed selector).
1528 pragma Assert
((S
.R_Sig_Socket
/= No_Socket
)
1530 (S
.W_Sig_Socket
/= No_Socket
));
1532 return S
.R_Sig_Socket
/= No_Socket
;
1541 (Item
: Socket_Set_Type
;
1542 Socket
: Socket_Type
) return Boolean
1545 Check_For_Fd_Set
(Socket
);
1547 return Item
.Last
/= No_Socket
1548 and then Socket
<= Item
.Last
1549 and then Is_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
)) /= 0;
1556 procedure Listen_Socket
1557 (Socket
: Socket_Type
;
1558 Length
: Natural := 15)
1560 Res
: constant C
.int
:= C_Listen
(C
.int
(Socket
), C
.int
(Length
));
1562 if Res
= Failure
then
1563 Raise_Socket_Error
(Socket_Errno
);
1571 procedure Narrow
(Item
: in out Socket_Set_Type
) is
1572 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
1574 if Item
.Last
/= No_Socket
then
1575 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
1576 Item
.Last
:= Socket_Type
(Last
);
1584 procedure Netdb_Lock
is
1586 if Need_Netdb_Lock
then
1587 System
.Task_Lock
.Lock
;
1595 procedure Netdb_Unlock
is
1597 if Need_Netdb_Lock
then
1598 System
.Task_Lock
.Unlock
;
1602 --------------------------------
1603 -- Normalize_Empty_Socket_Set --
1604 --------------------------------
1606 procedure Normalize_Empty_Socket_Set
(S
: in out Socket_Set_Type
) is
1608 if S
.Last
= No_Socket
then
1609 Reset_Socket_Set
(S
.Set
'Access);
1611 end Normalize_Empty_Socket_Set
;
1617 function Official_Name
(E
: Host_Entry_Type
) return String is
1619 return To_String
(E
.Official
);
1626 function Official_Name
(S
: Service_Entry_Type
) return String is
1628 return To_String
(S
.Official
);
1631 --------------------
1632 -- Wait_On_Socket --
1633 --------------------
1635 procedure Wait_On_Socket
1636 (Socket
: Socket_Type
;
1638 Timeout
: Selector_Duration
;
1639 Selector
: access Selector_Type
:= null;
1640 Status
: out Selector_Status
)
1642 type Local_Selector_Access
is access Selector_Type
;
1643 for Local_Selector_Access
'Storage_Size use Selector_Type
'Size;
1645 S
: Selector_Access
;
1646 -- Selector to use for waiting
1648 R_Fd_Set
: Socket_Set_Type
;
1649 W_Fd_Set
: Socket_Set_Type
;
1652 -- Create selector if not provided by the user
1654 if Selector
= null then
1656 Local_S
: constant Local_Selector_Access
:= new Selector_Type
;
1658 S
:= Local_S
.all'Unchecked_Access;
1659 Create_Selector
(S
.all);
1663 S
:= Selector
.all'Access;
1667 Set
(R_Fd_Set
, Socket
);
1669 Set
(W_Fd_Set
, Socket
);
1672 Check_Selector
(S
.all, R_Fd_Set
, W_Fd_Set
, Status
, Timeout
);
1674 if Selector
= null then
1675 Close_Selector
(S
.all);
1683 function Port_Number
(S
: Service_Entry_Type
) return Port_Type
is
1692 function Protocol_Name
(S
: Service_Entry_Type
) return String is
1694 return To_String
(S
.Protocol
);
1697 ----------------------
1698 -- Raise_Host_Error --
1699 ----------------------
1701 procedure Raise_Host_Error
(H_Error
: Integer) is
1703 raise Host_Error
with
1704 Err_Code_Image
(H_Error
)
1705 & Host_Error_Messages
.Host_Error_Message
(H_Error
);
1706 end Raise_Host_Error
;
1708 ------------------------
1709 -- Raise_Socket_Error --
1710 ------------------------
1712 procedure Raise_Socket_Error
(Error
: Integer) is
1713 use type C
.Strings
.chars_ptr
;
1715 raise Socket_Error
with
1716 Err_Code_Image
(Error
) & Socket_Error_Message
(Error
);
1717 end Raise_Socket_Error
;
1724 (Stream
: in out Datagram_Socket_Stream_Type
;
1725 Item
: out Ada
.Streams
.Stream_Element_Array
;
1726 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1741 (Stream
: in out Stream_Socket_Stream_Type
;
1742 Item
: out Ada
.Streams
.Stream_Element_Array
;
1743 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1745 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1746 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1747 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1751 Receive_Socket
(Stream
.Socket
, Item
(First
.. Max
), Index
);
1754 -- Exit when all or zero data received. Zero means that the socket
1757 exit when Index
< First
or else Index
= Max
;
1763 --------------------
1764 -- Receive_Socket --
1765 --------------------
1767 procedure Receive_Socket
1768 (Socket
: Socket_Type
;
1769 Item
: out Ada
.Streams
.Stream_Element_Array
;
1770 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1771 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1777 C_Recv
(C
.int
(Socket
), Item
'Address, Item
'Length, To_Int
(Flags
));
1779 if Res
= Failure
then
1780 Raise_Socket_Error
(Socket_Errno
);
1783 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1786 --------------------
1787 -- Receive_Socket --
1788 --------------------
1790 procedure Receive_Socket
1791 (Socket
: Socket_Type
;
1792 Item
: out Ada
.Streams
.Stream_Element_Array
;
1793 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1794 From
: out Sock_Addr_Type
;
1795 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1798 Sin
: aliased Sockaddr_In
;
1799 Len
: aliased C
.int
:= Sin
'Size / 8;
1811 if Res
= Failure
then
1812 Raise_Socket_Error
(Socket_Errno
);
1815 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1817 To_Inet_Addr
(Sin
.Sin_Addr
, From
.Addr
);
1818 From
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1821 --------------------
1822 -- Receive_Vector --
1823 --------------------
1825 procedure Receive_Vector
1826 (Socket
: Socket_Type
;
1827 Vector
: Vector_Type
;
1828 Count
: out Ada
.Streams
.Stream_Element_Count
;
1829 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1834 (Msg_Name
=> System
.Null_Address
,
1836 Msg_Iov
=> Vector
'Address,
1838 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1839 -- platforms) when the supplied vector is longer than IOV_MAX,
1840 -- so use minimum of the two lengths.
1842 Msg_Iovlen
=> SOSC
.Msg_Iovlen_T
'Min
1843 (Vector
'Length, SOSC
.IOV_MAX
),
1845 Msg_Control
=> System
.Null_Address
,
1846 Msg_Controllen
=> 0,
1856 if Res
= ssize_t
(Failure
) then
1857 Raise_Socket_Error
(Socket_Errno
);
1860 Count
:= Ada
.Streams
.Stream_Element_Count
(Res
);
1867 function Resolve_Error
1868 (Error_Value
: Integer;
1869 From_Errno
: Boolean := True) return Error_Type
1871 use GNAT
.Sockets
.SOSC
;
1874 if not From_Errno
then
1876 when SOSC
.HOST_NOT_FOUND
=> return Unknown_Host
;
1877 when SOSC
.TRY_AGAIN
=> return Host_Name_Lookup_Failure
;
1878 when SOSC
.NO_RECOVERY
=> return Non_Recoverable_Error
;
1879 when SOSC
.NO_DATA
=> return Unknown_Server_Error
;
1880 when others => return Cannot_Resolve_Error
;
1884 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1885 -- can't include it in the case statement below.
1887 pragma Warnings
(Off
);
1888 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1890 if EAGAIN
/= EWOULDBLOCK
and then Error_Value
= EAGAIN
then
1891 return Resource_Temporarily_Unavailable
;
1894 -- This is not a case statement because if a particular error
1895 -- number constant is not defined, s-oscons-tmplt.c defines
1896 -- it to -1. If multiple constants are not defined, they
1897 -- would each be -1 and result in a "duplicate value in case" error.
1899 -- But we have to leave warnings off because the compiler is also
1900 -- smart enough to note that when two errnos have the same value,
1901 -- the second if condition is useless.
1902 if Error_Value
= ENOERROR
then
1904 elsif Error_Value
= EACCES
then
1905 return Permission_Denied
;
1906 elsif Error_Value
= EADDRINUSE
then
1907 return Address_Already_In_Use
;
1908 elsif Error_Value
= EADDRNOTAVAIL
then
1909 return Cannot_Assign_Requested_Address
;
1910 elsif Error_Value
= EAFNOSUPPORT
then
1911 return Address_Family_Not_Supported_By_Protocol
;
1912 elsif Error_Value
= EALREADY
then
1913 return Operation_Already_In_Progress
;
1914 elsif Error_Value
= EBADF
then
1915 return Bad_File_Descriptor
;
1916 elsif Error_Value
= ECONNABORTED
then
1917 return Software_Caused_Connection_Abort
;
1918 elsif Error_Value
= ECONNREFUSED
then
1919 return Connection_Refused
;
1920 elsif Error_Value
= ECONNRESET
then
1921 return Connection_Reset_By_Peer
;
1922 elsif Error_Value
= EDESTADDRREQ
then
1923 return Destination_Address_Required
;
1924 elsif Error_Value
= EFAULT
then
1926 elsif Error_Value
= EHOSTDOWN
then
1927 return Host_Is_Down
;
1928 elsif Error_Value
= EHOSTUNREACH
then
1929 return No_Route_To_Host
;
1930 elsif Error_Value
= EINPROGRESS
then
1931 return Operation_Now_In_Progress
;
1932 elsif Error_Value
= EINTR
then
1933 return Interrupted_System_Call
;
1934 elsif Error_Value
= EINVAL
then
1935 return Invalid_Argument
;
1936 elsif Error_Value
= EIO
then
1937 return Input_Output_Error
;
1938 elsif Error_Value
= EISCONN
then
1939 return Transport_Endpoint_Already_Connected
;
1940 elsif Error_Value
= ELOOP
then
1941 return Too_Many_Symbolic_Links
;
1942 elsif Error_Value
= EMFILE
then
1943 return Too_Many_Open_Files
;
1944 elsif Error_Value
= EMSGSIZE
then
1945 return Message_Too_Long
;
1946 elsif Error_Value
= ENAMETOOLONG
then
1947 return File_Name_Too_Long
;
1948 elsif Error_Value
= ENETDOWN
then
1949 return Network_Is_Down
;
1950 elsif Error_Value
= ENETRESET
then
1951 return Network_Dropped_Connection_Because_Of_Reset
;
1952 elsif Error_Value
= ENETUNREACH
then
1953 return Network_Is_Unreachable
;
1954 elsif Error_Value
= ENOBUFS
then
1955 return No_Buffer_Space_Available
;
1956 elsif Error_Value
= ENOPROTOOPT
then
1957 return Protocol_Not_Available
;
1958 elsif Error_Value
= ENOTCONN
then
1959 return Transport_Endpoint_Not_Connected
;
1960 elsif Error_Value
= ENOTSOCK
then
1961 return Socket_Operation_On_Non_Socket
;
1962 elsif Error_Value
= EOPNOTSUPP
then
1963 return Operation_Not_Supported
;
1964 elsif Error_Value
= EPFNOSUPPORT
then
1965 return Protocol_Family_Not_Supported
;
1966 elsif Error_Value
= EPIPE
then
1968 elsif Error_Value
= EPROTONOSUPPORT
then
1969 return Protocol_Not_Supported
;
1970 elsif Error_Value
= EPROTOTYPE
then
1971 return Protocol_Wrong_Type_For_Socket
;
1972 elsif Error_Value
= ESHUTDOWN
then
1973 return Cannot_Send_After_Transport_Endpoint_Shutdown
;
1974 elsif Error_Value
= ESOCKTNOSUPPORT
then
1975 return Socket_Type_Not_Supported
;
1976 elsif Error_Value
= ETIMEDOUT
then
1977 return Connection_Timed_Out
;
1978 elsif Error_Value
= ETOOMANYREFS
then
1979 return Too_Many_References
;
1980 elsif Error_Value
= EWOULDBLOCK
then
1981 return Resource_Temporarily_Unavailable
;
1983 return Cannot_Resolve_Error
;
1985 pragma Warnings
(On
);
1989 -----------------------
1990 -- Resolve_Exception --
1991 -----------------------
1993 function Resolve_Exception
1994 (Occurrence
: Exception_Occurrence
) return Error_Type
1996 Id
: constant Exception_Id
:= Exception_Identity
(Occurrence
);
1997 Msg
: constant String := Exception_Message
(Occurrence
);
2004 while First
<= Msg
'Last
2005 and then Msg
(First
) not in '0' .. '9'
2010 if First
> Msg
'Last then
2011 return Cannot_Resolve_Error
;
2015 while Last
< Msg
'Last
2016 and then Msg
(Last
+ 1) in '0' .. '9'
2021 Val
:= Integer'Value (Msg
(First
.. Last
));
2023 if Id
= Socket_Error_Id
then
2024 return Resolve_Error
(Val
);
2026 elsif Id
= Host_Error_Id
then
2027 return Resolve_Error
(Val
, False);
2030 return Cannot_Resolve_Error
;
2032 end Resolve_Exception
;
2038 procedure Send_Socket
2039 (Socket
: Socket_Type
;
2040 Item
: Ada
.Streams
.Stream_Element_Array
;
2041 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2042 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2045 Send_Socket
(Socket
, Item
, Last
, To
=> null, Flags
=> Flags
);
2052 procedure Send_Socket
2053 (Socket
: Socket_Type
;
2054 Item
: Ada
.Streams
.Stream_Element_Array
;
2055 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2056 To
: Sock_Addr_Type
;
2057 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2061 (Socket
, Item
, Last
, To
=> To
'Unrestricted_Access, Flags
=> Flags
);
2068 procedure Send_Socket
2069 (Socket
: Socket_Type
;
2070 Item
: Ada
.Streams
.Stream_Element_Array
;
2071 Last
: out Ada
.Streams
.Stream_Element_Offset
;
2072 To
: access Sock_Addr_Type
;
2073 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2077 Sin
: aliased Sockaddr_In
;
2078 C_To
: System
.Address
;
2083 Set_Family
(Sin
.Sin_Family
, To
.Family
);
2084 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(To
.Addr
));
2086 (Sin
'Unchecked_Access,
2087 Short_To_Network
(C
.unsigned_short
(To
.Port
)));
2088 C_To
:= Sin
'Address;
2089 Len
:= Sin
'Size / 8;
2092 C_To
:= System
.Null_Address
;
2100 Set_Forced_Flags
(To_Int
(Flags
)),
2104 if Res
= Failure
then
2105 Raise_Socket_Error
(Socket_Errno
);
2108 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
2115 procedure Send_Vector
2116 (Socket
: Socket_Type
;
2117 Vector
: Vector_Type
;
2118 Count
: out Ada
.Streams
.Stream_Element_Count
;
2119 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2125 Iov_Count
: SOSC
.Msg_Iovlen_T
;
2126 This_Iov_Count
: SOSC
.Msg_Iovlen_T
;
2132 while Iov_Count
< Vector
'Length loop
2134 pragma Warnings
(Off
);
2135 -- Following test may be compile time known on some targets
2138 (if Vector
'Length - Iov_Count
> SOSC
.IOV_MAX
2140 else Vector
'Length - Iov_Count
);
2142 pragma Warnings
(On
);
2145 (Msg_Name
=> System
.Null_Address
,
2148 (Vector
'First + Integer (Iov_Count
))'Address,
2149 Msg_Iovlen
=> This_Iov_Count
,
2150 Msg_Control
=> System
.Null_Address
,
2151 Msg_Controllen
=> 0,
2158 Set_Forced_Flags
(To_Int
(Flags
)));
2160 if Res
= ssize_t
(Failure
) then
2161 Raise_Socket_Error
(Socket_Errno
);
2164 Count
:= Count
+ Ada
.Streams
.Stream_Element_Count
(Res
);
2165 Iov_Count
:= Iov_Count
+ This_Iov_Count
;
2173 procedure Set
(Item
: in out Socket_Set_Type
; Socket
: Socket_Type
) is
2175 Check_For_Fd_Set
(Socket
);
2177 if Item
.Last
= No_Socket
then
2179 -- Uninitialized socket set, make sure it is properly zeroed out
2181 Reset_Socket_Set
(Item
.Set
'Access);
2182 Item
.Last
:= Socket
;
2184 elsif Item
.Last
< Socket
then
2185 Item
.Last
:= Socket
;
2188 Insert_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
));
2191 -----------------------
2192 -- Set_Close_On_Exec --
2193 -----------------------
2195 procedure Set_Close_On_Exec
2196 (Socket
: Socket_Type
;
2197 Close_On_Exec
: Boolean;
2198 Status
: out Boolean)
2200 function C_Set_Close_On_Exec
2201 (Socket
: Socket_Type
; Close_On_Exec
: C
.int
) return C
.int
;
2202 pragma Import
(C
, C_Set_Close_On_Exec
, "__gnat_set_close_on_exec");
2204 Status
:= C_Set_Close_On_Exec
(Socket
, Boolean'Pos (Close_On_Exec
)) = 0;
2205 end Set_Close_On_Exec
;
2207 ----------------------
2208 -- Set_Forced_Flags --
2209 ----------------------
2211 function Set_Forced_Flags
(F
: C
.int
) return C
.int
is
2212 use type C
.unsigned
;
2213 function To_unsigned
is
2214 new Ada
.Unchecked_Conversion
(C
.int
, C
.unsigned
);
2216 new Ada
.Unchecked_Conversion
(C
.unsigned
, C
.int
);
2218 return To_int
(To_unsigned
(F
) or SOSC
.MSG_Forced_Flags
);
2219 end Set_Forced_Flags
;
2221 -----------------------
2222 -- Set_Socket_Option --
2223 -----------------------
2225 procedure Set_Socket_Option
2226 (Socket
: Socket_Type
;
2227 Level
: Level_Type
:= Socket_Level
;
2228 Option
: Option_Type
)
2232 V8
: aliased Two_Ints
;
2234 V1
: aliased C
.unsigned_char
;
2235 VT
: aliased Timeval
;
2237 Add
: System
.Address
:= Null_Address
;
2246 V4
:= C
.int
(Boolean'Pos (Option
.Enabled
));
2251 V8
(V8
'First) := C
.int
(Boolean'Pos (Option
.Enabled
));
2252 V8
(V8
'Last) := C
.int
(Option
.Seconds
);
2258 V4
:= C
.int
(Option
.Size
);
2263 V4
:= C
.int
(Boolean'Pos (True));
2267 when Add_Membership |
2269 V8
(V8
'First) := To_Int
(To_In_Addr
(Option
.Multicast_Address
));
2270 V8
(V8
'Last) := To_Int
(To_In_Addr
(Option
.Local_Interface
));
2274 when Multicast_If
=>
2275 V4
:= To_Int
(To_In_Addr
(Option
.Outgoing_If
));
2279 when Multicast_TTL
=>
2280 V1
:= C
.unsigned_char
(Option
.Time_To_Live
);
2284 when Multicast_Loop |
2285 Receive_Packet_Info
=>
2286 V1
:= C
.unsigned_char
(Boolean'Pos (Option
.Enabled
));
2293 if Target_OS
= Windows
then
2295 -- On Windows, the timeout is a DWORD in milliseconds, and
2296 -- the actual timeout is 500 ms + the given value (unless it
2299 V4
:= C
.int
(Option
.Timeout
/ 0.001);
2312 VT
:= To_Timeval
(Option
.Timeout
);
2322 Options
(Option
.Name
),
2325 if Res
= Failure
then
2326 Raise_Socket_Error
(Socket_Errno
);
2328 end Set_Socket_Option
;
2330 ----------------------
2331 -- Short_To_Network --
2332 ----------------------
2334 function Short_To_Network
(S
: C
.unsigned_short
) return C
.unsigned_short
is
2335 use type C
.unsigned_short
;
2338 -- Big-endian case. No conversion needed. On these platforms, htons()
2339 -- defaults to a null procedure.
2341 if Default_Bit_Order
= High_Order_First
then
2344 -- Little-endian case. We must swap the high and low bytes of this
2345 -- short to make the port number network compliant.
2348 return (S
/ 256) + (S
mod 256) * 256;
2350 end Short_To_Network
;
2352 ---------------------
2353 -- Shutdown_Socket --
2354 ---------------------
2356 procedure Shutdown_Socket
2357 (Socket
: Socket_Type
;
2358 How
: Shutmode_Type
:= Shut_Read_Write
)
2363 Res
:= C_Shutdown
(C
.int
(Socket
), Shutmodes
(How
));
2365 if Res
= Failure
then
2366 Raise_Socket_Error
(Socket_Errno
);
2368 end Shutdown_Socket
;
2375 (Socket
: Socket_Type
;
2376 Send_To
: Sock_Addr_Type
) return Stream_Access
2378 S
: Datagram_Socket_Stream_Access
;
2381 S
:= new Datagram_Socket_Stream_Type
;
2384 S
.From
:= Get_Socket_Name
(Socket
);
2385 return Stream_Access
(S
);
2392 function Stream
(Socket
: Socket_Type
) return Stream_Access
is
2393 S
: Stream_Socket_Stream_Access
;
2395 S
:= new Stream_Socket_Stream_Type
;
2397 return Stream_Access
(S
);
2404 function To_C
(Socket
: Socket_Type
) return Integer is
2406 return Integer (Socket
);
2413 function To_Duration
(Val
: Timeval
) return Timeval_Duration
is
2415 return Natural (Val
.Tv_Sec
) * 1.0 + Natural (Val
.Tv_Usec
) * 1.0E-6;
2422 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
is
2426 Aliases_Count
, Addresses_Count
: Natural;
2428 -- H_Length is not used because it is currently only ever set to 4, as
2429 -- H_Addrtype is always AF_INET.
2433 while Hostent_H_Alias
(E
, C
.int
(Aliases_Count
)) /= Null_Address
loop
2434 Aliases_Count
:= Aliases_Count
+ 1;
2437 Addresses_Count
:= 0;
2438 while Hostent_H_Addr
(E
, C
.int
(Addresses_Count
)) /= Null_Address
loop
2439 Addresses_Count
:= Addresses_Count
+ 1;
2442 return Result
: Host_Entry_Type
2443 (Aliases_Length
=> Aliases_Count
,
2444 Addresses_Length
=> Addresses_Count
)
2446 Result
.Official
:= To_Name
(Value
(Hostent_H_Name
(E
)));
2448 for J
in Result
.Aliases
'Range loop
2449 Result
.Aliases
(J
) :=
2450 To_Name
(Value
(Hostent_H_Alias
2451 (E
, C
.int
(J
- Result
.Aliases
'First))));
2454 for J
in Result
.Addresses
'Range loop
2458 -- Hostent_H_Addr (E, <index>) may return an address that is
2459 -- not correctly aligned for In_Addr, so we need to use
2460 -- an intermediate copy operation on a type with an alignemnt
2461 -- of 1 to recover the value.
2463 subtype Addr_Buf_T
is C
.char_array
(1 .. Addr
'Size / 8);
2464 Unaligned_Addr
: Addr_Buf_T
;
2465 for Unaligned_Addr
'Address
2466 use Hostent_H_Addr
(E
, C
.int
(J
- Result
.Addresses
'First));
2467 pragma Import
(Ada
, Unaligned_Addr
);
2469 Aligned_Addr
: Addr_Buf_T
;
2470 for Aligned_Addr
'Address use Addr
'Address;
2471 pragma Import
(Ada
, Aligned_Addr
);
2474 Aligned_Addr
:= Unaligned_Addr
;
2475 To_Inet_Addr
(Addr
, Result
.Addresses
(J
));
2485 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
is
2487 if Addr
.Family
= Family_Inet
then
2488 return (S_B1
=> C
.unsigned_char
(Addr
.Sin_V4
(1)),
2489 S_B2
=> C
.unsigned_char
(Addr
.Sin_V4
(2)),
2490 S_B3
=> C
.unsigned_char
(Addr
.Sin_V4
(3)),
2491 S_B4
=> C
.unsigned_char
(Addr
.Sin_V4
(4)));
2494 raise Socket_Error
with "IPv6 not supported";
2501 procedure To_Inet_Addr
2503 Result
: out Inet_Addr_Type
) is
2505 Result
.Sin_V4
(1) := Inet_Addr_Comp_Type
(Addr
.S_B1
);
2506 Result
.Sin_V4
(2) := Inet_Addr_Comp_Type
(Addr
.S_B2
);
2507 Result
.Sin_V4
(3) := Inet_Addr_Comp_Type
(Addr
.S_B3
);
2508 Result
.Sin_V4
(4) := Inet_Addr_Comp_Type
(Addr
.S_B4
);
2515 function To_Int
(F
: Request_Flag_Type
) return C
.int
2517 Current
: Request_Flag_Type
:= F
;
2518 Result
: C
.int
:= 0;
2521 for J
in Flags
'Range loop
2522 exit when Current
= 0;
2524 if Current
mod 2 /= 0 then
2525 if Flags
(J
) = -1 then
2526 Raise_Socket_Error
(SOSC
.EOPNOTSUPP
);
2529 Result
:= Result
+ Flags
(J
);
2532 Current
:= Current
/ 2;
2542 function To_Name
(N
: String) return Name_Type
is
2544 return Name_Type
'(N'Length, N);
2547 ----------------------
2548 -- To_Service_Entry --
2549 ----------------------
2551 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2555 Aliases_Count : Natural;
2559 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2560 Aliases_Count := Aliases_Count + 1;
2563 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2564 Result.Official := To_Name (Value (Servent_S_Name (E)));
2566 for J in Result.Aliases'Range loop
2567 Result.Aliases (J) :=
2568 To_Name (Value (Servent_S_Alias
2569 (E, C.int (J - Result.Aliases'First))));
2572 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2574 Port_Type (Network_To_Short (Servent_S_Port (E)));
2576 end To_Service_Entry;
2582 function To_String (HN : Name_Type) return String is
2584 return HN.Name (1 .. HN.Length);
2591 function To_Timeval (Val : Timeval_Duration) return Timeval is
2596 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2602 -- Normal case where we do round down
2605 S := time_t (Val - 0.5);
2606 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2616 function Value (S : System.Address) return String is
2617 Str : String (1 .. Positive'Last);
2618 for Str'Address use S;
2619 pragma Import (Ada, Str);
2621 Terminator : Positive := Str'First;
2624 while Str (Terminator) /= ASCII.NUL loop
2625 Terminator := Terminator + 1;
2628 return Str (1 .. Terminator - 1);
2636 (Stream : in out Datagram_Socket_Stream_Type;
2637 Item : Ada.Streams.Stream_Element_Array)
2639 Last : Stream_Element_Offset;
2648 -- It is an error if not all of the data has been sent
2650 if Last /= Item'Last then
2651 Raise_Socket_Error (Socket_Errno);
2660 (Stream : in out Stream_Socket_Stream_Type;
2661 Item : Ada.Streams.Stream_Element_Array)
2663 First : Ada.Streams.Stream_Element_Offset;
2664 Index : Ada.Streams.Stream_Element_Offset;
2665 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2668 First := Item'First;
2670 while First <= Max loop
2671 Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
2673 -- Exit when all or zero data sent. Zero means that the socket has
2674 -- been closed by peer.
2676 exit when Index < First or else Index = Max;
2681 -- For an empty array, we have First > Max, and hence Index >= Max (no
2682 -- error, the loop above is never executed). After a successful send,
2683 -- Index = Max. The only remaining case, Index < Max, is therefore
2684 -- always an actual send failure.
2687 Raise_Socket_Error (Socket_Errno);
2691 Sockets_Library_Controller_Object : Sockets_Library_Controller;
2692 pragma Unreferenced (Sockets_Library_Controller_Object);
2693 -- The elaboration and finalization of this object perform the required
2694 -- initialization and cleanup actions for the sockets library.