1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2010, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Streams
; use Ada
.Streams
;
35 with Ada
.Exceptions
; use Ada
.Exceptions
;
36 with Ada
.Finalization
;
37 with Ada
.Unchecked_Conversion
;
39 with Interfaces
.C
.Strings
;
41 with GNAT
.Sockets
.Thin_Common
; use GNAT
.Sockets
.Thin_Common
;
42 with GNAT
.Sockets
.Thin
; use GNAT
.Sockets
.Thin
;
44 with GNAT
.Sockets
.Linker_Options
;
45 pragma Warnings
(Off
, GNAT
.Sockets
.Linker_Options
);
46 -- Need to include pragma Linker_Options which is platform dependent
48 with System
; use System
;
49 with System
.Communication
; use System
.Communication
;
50 with System
.CRTL
; use System
.CRTL
;
51 with System
.Task_Lock
;
53 package body GNAT
.Sockets
is
55 package C
renames Interfaces
.C
;
59 ENOERROR
: constant := 0;
61 Netdb_Buffer_Size
: constant := SOSC
.Need_Netdb_Buffer
* 1024;
62 Need_Netdb_Lock
: constant Boolean := SOSC
.Need_Netdb_Lock
/= 0;
63 -- The network database functions gethostbyname, gethostbyaddr,
64 -- getservbyname and getservbyport can either be guaranteed task safe by
65 -- the operating system, or else return data through a user-provided buffer
66 -- to ensure concurrent uses do not interfere.
68 -- Correspondence tables
70 Levels
: constant array (Level_Type
) of C
.int
:=
71 (Socket_Level
=> SOSC
.SOL_SOCKET
,
72 IP_Protocol_For_IP_Level
=> SOSC
.IPPROTO_IP
,
73 IP_Protocol_For_UDP_Level
=> SOSC
.IPPROTO_UDP
,
74 IP_Protocol_For_TCP_Level
=> SOSC
.IPPROTO_TCP
);
76 Modes
: constant array (Mode_Type
) of C
.int
:=
77 (Socket_Stream
=> SOSC
.SOCK_STREAM
,
78 Socket_Datagram
=> SOSC
.SOCK_DGRAM
);
80 Shutmodes
: constant array (Shutmode_Type
) of C
.int
:=
81 (Shut_Read
=> SOSC
.SHUT_RD
,
82 Shut_Write
=> SOSC
.SHUT_WR
,
83 Shut_Read_Write
=> SOSC
.SHUT_RDWR
);
85 Requests
: constant array (Request_Name
) of C
.int
:=
86 (Non_Blocking_IO
=> SOSC
.FIONBIO
,
87 N_Bytes_To_Read
=> SOSC
.FIONREAD
);
89 Options
: constant array (Option_Name
) of C
.int
:=
90 (Keep_Alive
=> SOSC
.SO_KEEPALIVE
,
91 Reuse_Address
=> SOSC
.SO_REUSEADDR
,
92 Broadcast
=> SOSC
.SO_BROADCAST
,
93 Send_Buffer
=> SOSC
.SO_SNDBUF
,
94 Receive_Buffer
=> SOSC
.SO_RCVBUF
,
95 Linger
=> SOSC
.SO_LINGER
,
96 Error
=> SOSC
.SO_ERROR
,
97 No_Delay
=> SOSC
.TCP_NODELAY
,
98 Add_Membership
=> SOSC
.IP_ADD_MEMBERSHIP
,
99 Drop_Membership
=> SOSC
.IP_DROP_MEMBERSHIP
,
100 Multicast_If
=> SOSC
.IP_MULTICAST_IF
,
101 Multicast_TTL
=> SOSC
.IP_MULTICAST_TTL
,
102 Multicast_Loop
=> SOSC
.IP_MULTICAST_LOOP
,
103 Receive_Packet_Info
=> SOSC
.IP_PKTINFO
,
104 Send_Timeout
=> SOSC
.SO_SNDTIMEO
,
105 Receive_Timeout
=> SOSC
.SO_RCVTIMEO
);
106 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
107 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
109 Flags
: constant array (0 .. 3) of C
.int
:=
110 (0 => SOSC
.MSG_OOB
, -- Process_Out_Of_Band_Data
111 1 => SOSC
.MSG_PEEK
, -- Peek_At_Incoming_Data
112 2 => SOSC
.MSG_WAITALL
, -- Wait_For_A_Full_Reception
113 3 => SOSC
.MSG_EOR
); -- Send_End_Of_Record
115 Socket_Error_Id
: constant Exception_Id
:= Socket_Error
'Identity;
116 Host_Error_Id
: constant Exception_Id
:= Host_Error
'Identity;
118 Hex_To_Char
: constant String (1 .. 16) := "0123456789ABCDEF";
119 -- Use to print in hexadecimal format
121 -----------------------
122 -- Local subprograms --
123 -----------------------
125 function Resolve_Error
126 (Error_Value
: Integer;
127 From_Errno
: Boolean := True) return Error_Type
;
128 -- Associate an enumeration value (error_type) to en error value (errno).
129 -- From_Errno prevents from mixing h_errno with errno.
131 function To_Name
(N
: String) return Name_Type
;
132 function To_String
(HN
: Name_Type
) return String;
133 -- Conversion functions
135 function To_Int
(F
: Request_Flag_Type
) return C
.int
;
136 -- Return the int value corresponding to the specified flags combination
138 function Set_Forced_Flags
(F
: C
.int
) return C
.int
;
139 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
141 function Short_To_Network
142 (S
: C
.unsigned_short
) return C
.unsigned_short
;
143 pragma Inline
(Short_To_Network
);
144 -- Convert a port number into a network port number
146 function Network_To_Short
147 (S
: C
.unsigned_short
) return C
.unsigned_short
148 renames Short_To_Network
;
149 -- Symmetric operation
152 (Val
: Inet_Addr_VN_Type
;
153 Hex
: Boolean := False) return String;
154 -- Output an array of inet address components in hex or decimal mode
156 function Is_IP_Address
(Name
: String) return Boolean;
157 -- Return true when Name is an IP address in standard dot notation
159 procedure Netdb_Lock
;
160 pragma Inline
(Netdb_Lock
);
161 procedure Netdb_Unlock
;
162 pragma Inline
(Netdb_Unlock
);
163 -- Lock/unlock operation used to protect netdb access for platforms that
164 -- require such protection.
166 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
;
167 procedure To_Inet_Addr
169 Result
: out Inet_Addr_Type
);
170 -- Conversion functions
172 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
;
173 -- Conversion function
175 function To_Service_Entry
(E
: Servent_Access
) return Service_Entry_Type
;
176 -- Conversion function
178 function Value
(S
: System
.Address
) return String;
179 -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS,
180 -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
182 function To_Timeval
(Val
: Timeval_Duration
) return Timeval
;
183 -- Separate Val in seconds and microseconds
185 function To_Duration
(Val
: Timeval
) return Timeval_Duration
;
186 -- Reconstruct a Duration value from a Timeval record (seconds and
189 procedure Raise_Socket_Error
(Error
: Integer);
190 -- Raise Socket_Error with an exception message describing the error code
193 procedure Raise_Host_Error
(H_Error
: Integer);
194 -- Raise Host_Error exception with message describing error code (note
195 -- hstrerror seems to be obsolete) from h_errno.
197 procedure Narrow
(Item
: in out Socket_Set_Type
);
198 -- Update Last as it may be greater than the real last socket
200 -- Types needed for Datagram_Socket_Stream_Type
202 type Datagram_Socket_Stream_Type
is new Root_Stream_Type
with record
203 Socket
: Socket_Type
;
205 From
: Sock_Addr_Type
;
208 type Datagram_Socket_Stream_Access
is
209 access all Datagram_Socket_Stream_Type
;
212 (Stream
: in out Datagram_Socket_Stream_Type
;
213 Item
: out Ada
.Streams
.Stream_Element_Array
;
214 Last
: out Ada
.Streams
.Stream_Element_Offset
);
217 (Stream
: in out Datagram_Socket_Stream_Type
;
218 Item
: Ada
.Streams
.Stream_Element_Array
);
220 -- Types needed for Stream_Socket_Stream_Type
222 type Stream_Socket_Stream_Type
is new Root_Stream_Type
with record
223 Socket
: Socket_Type
;
226 type Stream_Socket_Stream_Access
is
227 access all Stream_Socket_Stream_Type
;
230 (Stream
: in out Stream_Socket_Stream_Type
;
231 Item
: out Ada
.Streams
.Stream_Element_Array
;
232 Last
: out Ada
.Streams
.Stream_Element_Offset
);
235 (Stream
: in out Stream_Socket_Stream_Type
;
236 Item
: Ada
.Streams
.Stream_Element_Array
);
238 procedure Stream_Write
239 (Socket
: Socket_Type
;
240 Item
: Ada
.Streams
.Stream_Element_Array
;
241 To
: access Sock_Addr_Type
);
242 -- Common implementation for the Write operation of Datagram_Socket_Stream_
243 -- Type and Stream_Socket_Stream_Type.
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
);
472 procedure Check_Selector
473 (Selector
: Selector_Type
;
474 R_Socket_Set
: in out Socket_Set_Type
;
475 W_Socket_Set
: in out Socket_Set_Type
;
476 Status
: out Selector_Status
;
477 Timeout
: Selector_Duration
:= Forever
)
479 E_Socket_Set
: Socket_Set_Type
;
482 (Selector
, R_Socket_Set
, W_Socket_Set
, E_Socket_Set
, Status
, Timeout
);
489 procedure Check_Selector
490 (Selector
: Selector_Type
;
491 R_Socket_Set
: in out Socket_Set_Type
;
492 W_Socket_Set
: in out Socket_Set_Type
;
493 E_Socket_Set
: in out Socket_Set_Type
;
494 Status
: out Selector_Status
;
495 Timeout
: Selector_Duration
:= Forever
)
499 RSig
: Socket_Type
:= No_Socket
;
500 TVal
: aliased Timeval
;
501 TPtr
: Timeval_Access
;
504 if not Is_Open
(Selector
) then
505 raise Program_Error
with "closed selector";
510 -- No timeout or Forever is indicated by a null timeval pointer
512 if Timeout
= Forever
then
515 TVal
:= To_Timeval
(Timeout
);
516 TPtr
:= TVal
'Unchecked_Access;
519 -- Add read signalling socket, if present
521 if not Selector
.Is_Null
then
522 RSig
:= Selector
.R_Sig_Socket
;
523 Set
(R_Socket_Set
, RSig
);
526 Last
:= C
.int
'Max (C
.int
'Max (C
.int
(R_Socket_Set
.Last
),
527 C
.int
(W_Socket_Set
.Last
)),
528 C
.int
(E_Socket_Set
.Last
));
530 -- Zero out fd_set for empty Socket_Set_Type objects
532 Normalize_Empty_Socket_Set
(R_Socket_Set
);
533 Normalize_Empty_Socket_Set
(W_Socket_Set
);
534 Normalize_Empty_Socket_Set
(E_Socket_Set
);
539 R_Socket_Set
.Set
'Access,
540 W_Socket_Set
.Set
'Access,
541 E_Socket_Set
.Set
'Access,
544 if Res
= Failure
then
545 Raise_Socket_Error
(Socket_Errno
);
548 -- If Select was resumed because of read signalling socket, read this
549 -- data and remove socket from set.
551 if RSig
/= No_Socket
and then Is_Set
(R_Socket_Set
, RSig
) then
552 Clear
(R_Socket_Set
, RSig
);
554 Res
:= Signalling_Fds
.Read
(C
.int
(RSig
));
556 if Res
= Failure
then
557 Raise_Socket_Error
(Socket_Errno
);
566 -- Update socket sets in regard to their new contents
568 Narrow
(R_Socket_Set
);
569 Narrow
(W_Socket_Set
);
570 Narrow
(E_Socket_Set
);
578 (Item
: in out Socket_Set_Type
;
579 Socket
: Socket_Type
)
581 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
583 if Item
.Last
/= No_Socket
then
584 Remove_Socket_From_Set
(Item
.Set
'Access, C
.int
(Socket
));
585 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
586 Item
.Last
:= Socket_Type
(Last
);
594 procedure Close_Selector
(Selector
: in out Selector_Type
) is
596 -- Nothing to do if selector already in closed state
598 if Selector
.Is_Null
or else not Is_Open
(Selector
) then
602 -- Close the signalling file descriptors used internally for the
603 -- implementation of Abort_Selector.
605 Signalling_Fds
.Close
(C
.int
(Selector
.R_Sig_Socket
));
606 Signalling_Fds
.Close
(C
.int
(Selector
.W_Sig_Socket
));
608 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
609 -- (erroneous) subsequent attempt to use this selector properly fails.
611 Selector
.R_Sig_Socket
:= No_Socket
;
612 Selector
.W_Sig_Socket
:= No_Socket
;
619 procedure Close_Socket
(Socket
: Socket_Type
) is
623 Res
:= C_Close
(C
.int
(Socket
));
625 if Res
= Failure
then
626 Raise_Socket_Error
(Socket_Errno
);
634 procedure Connect_Socket
635 (Socket
: Socket_Type
;
636 Server
: Sock_Addr_Type
)
639 Sin
: aliased Sockaddr_In
;
640 Len
: constant C
.int
:= Sin
'Size / 8;
643 if Server
.Family
= Family_Inet6
then
644 raise Socket_Error
with "IPv6 not supported";
647 Set_Family
(Sin
.Sin_Family
, Server
.Family
);
648 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Server
.Addr
));
650 (Sin
'Unchecked_Access,
651 Short_To_Network
(C
.unsigned_short
(Server
.Port
)));
653 Res
:= C_Connect
(C
.int
(Socket
), Sin
'Address, Len
);
655 if Res
= Failure
then
656 Raise_Socket_Error
(Socket_Errno
);
664 procedure Connect_Socket
665 (Socket
: Socket_Type
;
666 Server
: Sock_Addr_Type
;
667 Timeout
: Selector_Duration
;
668 Selector
: access Selector_Type
:= null;
669 Status
: out Selector_Status
)
672 -- Used to set Socket to non-blocking I/O
675 if Selector
/= null and then not Is_Open
(Selector
.all) then
676 raise Program_Error
with "closed selector";
679 -- Set the socket to non-blocking I/O
681 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> True);
682 Control_Socket
(Socket
, Request
=> Req
);
684 -- Start operation (non-blocking), will raise Socket_Error with
688 Connect_Socket
(Socket
, Server
);
690 when E
: Socket_Error
=>
691 if Resolve_Exception
(E
) = Operation_Now_In_Progress
then
698 -- Wait for socket to become available for writing
704 Selector
=> Selector
,
707 -- Reset the socket to blocking I/O
709 Req
:= (Name
=> Non_Blocking_IO
, Enabled
=> False);
710 Control_Socket
(Socket
, Request
=> Req
);
717 procedure Control_Socket
718 (Socket
: Socket_Type
;
719 Request
: in out Request_Type
)
726 when Non_Blocking_IO
=>
727 Arg
:= C
.int
(Boolean'Pos (Request
.Enabled
));
729 when N_Bytes_To_Read
=>
734 (C
.int
(Socket
), Requests
(Request
.Name
), Arg
'Unchecked_Access);
736 if Res
= Failure
then
737 Raise_Socket_Error
(Socket_Errno
);
741 when Non_Blocking_IO
=>
744 when N_Bytes_To_Read
=>
745 Request
.Size
:= Natural (Arg
);
754 (Source
: Socket_Set_Type
;
755 Target
: out Socket_Set_Type
)
761 ---------------------
762 -- Create_Selector --
763 ---------------------
765 procedure Create_Selector
(Selector
: out Selector_Type
) is
766 Two_Fds
: aliased Fd_Pair
;
770 if Is_Open
(Selector
) then
771 -- Raise exception to prevent socket descriptor leak
773 raise Program_Error
with "selector already open";
776 -- We open two signalling file descriptors. One of them is used to send
777 -- data to the other, which is included in a C_Select socket set. The
778 -- communication is used to force a call to C_Select to complete, and
779 -- the waiting task to resume its execution.
781 Res
:= Signalling_Fds
.Create
(Two_Fds
'Access);
783 if Res
= Failure
then
784 Raise_Socket_Error
(Socket_Errno
);
787 Selector
.R_Sig_Socket
:= Socket_Type
(Two_Fds
(Read_End
));
788 Selector
.W_Sig_Socket
:= Socket_Type
(Two_Fds
(Write_End
));
795 procedure Create_Socket
796 (Socket
: out Socket_Type
;
797 Family
: Family_Type
:= Family_Inet
;
798 Mode
: Mode_Type
:= Socket_Stream
)
803 Res
:= C_Socket
(Families
(Family
), Modes
(Mode
), 0);
805 if Res
= Failure
then
806 Raise_Socket_Error
(Socket_Errno
);
809 Socket
:= Socket_Type
(Res
);
816 procedure Empty
(Item
: out Socket_Set_Type
) is
818 Reset_Socket_Set
(Item
.Set
'Access);
819 Item
.Last
:= No_Socket
;
826 function Err_Code_Image
(E
: Integer) return String is
827 Msg
: String := E
'Img & "] ";
829 Msg
(Msg
'First) := '[';
837 procedure Finalize
(X
: in out Sockets_Library_Controller
) is
838 pragma Unreferenced
(X
);
841 -- Finalization operation for the GNAT.Sockets package
850 procedure Finalize
is
852 -- This is a dummy placeholder for an obsolete API.
853 -- The real finalization actions are in Initialize primitive operation
854 -- of Sockets_Library_Controller.
864 (Item
: in out Socket_Set_Type
;
865 Socket
: out Socket_Type
)
868 L
: aliased C
.int
:= C
.int
(Item
.Last
);
871 if Item
.Last
/= No_Socket
then
873 (Item
.Set
'Access, Last
=> L
'Access, Socket
=> S
'Access);
874 Item
.Last
:= Socket_Type
(L
);
875 Socket
:= Socket_Type
(S
);
886 (Stream
: not null Stream_Access
) return Sock_Addr_Type
889 if Stream
.all in Datagram_Socket_Stream_Type
then
890 return Datagram_Socket_Stream_Type
(Stream
.all).From
;
892 return Get_Peer_Name
(Stream_Socket_Stream_Type
(Stream
.all).Socket
);
896 -------------------------
897 -- Get_Host_By_Address --
898 -------------------------
900 function Get_Host_By_Address
901 (Address
: Inet_Addr_Type
;
902 Family
: Family_Type
:= Family_Inet
) return Host_Entry_Type
904 pragma Unreferenced
(Family
);
906 HA
: aliased In_Addr
:= To_In_Addr
(Address
);
907 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
908 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
909 Res
: aliased Hostent
;
915 if C_Gethostbyaddr
(HA
'Address, HA
'Size / 8, SOSC
.AF_INET
,
916 Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
919 Raise_Host_Error
(Integer (Err
));
922 return H
: constant Host_Entry_Type
:=
923 To_Host_Entry
(Res
'Unchecked_Access)
927 end Get_Host_By_Address
;
929 ----------------------
930 -- Get_Host_By_Name --
931 ----------------------
933 function Get_Host_By_Name
(Name
: String) return Host_Entry_Type
is
935 -- Detect IP address name and redirect to Inet_Addr
937 if Is_IP_Address
(Name
) then
938 return Get_Host_By_Address
(Inet_Addr
(Name
));
942 HN
: constant C
.char_array
:= C
.To_C
(Name
);
943 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
944 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
945 Res
: aliased Hostent
;
952 (HN
, Res
'Access, Buf
'Address, Buflen
, Err
'Access) /= 0
955 Raise_Host_Error
(Integer (Err
));
958 return H
: constant Host_Entry_Type
:=
959 To_Host_Entry
(Res
'Unchecked_Access)
964 end Get_Host_By_Name
;
970 function Get_Peer_Name
(Socket
: Socket_Type
) return Sock_Addr_Type
is
971 Sin
: aliased Sockaddr_In
;
972 Len
: aliased C
.int
:= Sin
'Size / 8;
973 Res
: Sock_Addr_Type
(Family_Inet
);
976 if C_Getpeername
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
977 Raise_Socket_Error
(Socket_Errno
);
980 To_Inet_Addr
(Sin
.Sin_Addr
, Res
.Addr
);
981 Res
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
986 -------------------------
987 -- Get_Service_By_Name --
988 -------------------------
990 function Get_Service_By_Name
992 Protocol
: String) return Service_Entry_Type
994 SN
: constant C
.char_array
:= C
.To_C
(Name
);
995 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
996 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
997 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
998 Res
: aliased Servent
;
1003 if C_Getservbyname
(SN
, SP
, Res
'Access, Buf
'Address, Buflen
) /= 0 then
1005 raise Service_Error
with "Service not found";
1008 -- Translate from the C format to the API format
1010 return S
: constant Service_Entry_Type
:=
1011 To_Service_Entry
(Res
'Unchecked_Access)
1015 end Get_Service_By_Name
;
1017 -------------------------
1018 -- Get_Service_By_Port --
1019 -------------------------
1021 function Get_Service_By_Port
1023 Protocol
: String) return Service_Entry_Type
1025 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
1026 Buflen
: constant C
.int
:= Netdb_Buffer_Size
;
1027 Buf
: aliased C
.char_array
(1 .. Netdb_Buffer_Size
);
1028 Res
: aliased Servent
;
1034 (C
.int
(Short_To_Network
(C
.unsigned_short
(Port
))), SP
,
1035 Res
'Access, Buf
'Address, Buflen
) /= 0
1038 raise Service_Error
with "Service not found";
1041 -- Translate from the C format to the API format
1043 return S
: constant Service_Entry_Type
:=
1044 To_Service_Entry
(Res
'Unchecked_Access)
1048 end Get_Service_By_Port
;
1050 ---------------------
1051 -- Get_Socket_Name --
1052 ---------------------
1054 function Get_Socket_Name
1055 (Socket
: Socket_Type
) return Sock_Addr_Type
1057 Sin
: aliased Sockaddr_In
;
1058 Len
: aliased C
.int
:= Sin
'Size / 8;
1060 Addr
: Sock_Addr_Type
:= No_Sock_Addr
;
1063 Res
:= C_Getsockname
(C
.int
(Socket
), Sin
'Address, Len
'Access);
1065 if Res
/= Failure
then
1066 To_Inet_Addr
(Sin
.Sin_Addr
, Addr
.Addr
);
1067 Addr
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1071 end Get_Socket_Name
;
1073 -----------------------
1074 -- Get_Socket_Option --
1075 -----------------------
1077 function Get_Socket_Option
1078 (Socket
: Socket_Type
;
1079 Level
: Level_Type
:= Socket_Level
;
1080 Name
: Option_Name
) return Option_Type
1082 use type C
.unsigned_char
;
1084 V8
: aliased Two_Ints
;
1086 V1
: aliased C
.unsigned_char
;
1087 VT
: aliased Timeval
;
1088 Len
: aliased C
.int
;
1089 Add
: System
.Address
;
1091 Opt
: Option_Type
(Name
);
1095 when Multicast_Loop |
1097 Receive_Packet_Info
=>
1132 if Res
= Failure
then
1133 Raise_Socket_Error
(Socket_Errno
);
1141 Opt
.Enabled
:= (V4
/= 0);
1144 Opt
.Enabled
:= (V8
(V8
'First) /= 0);
1145 Opt
.Seconds
:= Natural (V8
(V8
'Last));
1149 Opt
.Size
:= Natural (V4
);
1152 Opt
.Error
:= Resolve_Error
(Integer (V4
));
1154 when Add_Membership |
1156 To_Inet_Addr
(To_In_Addr
(V8
(V8
'First)), Opt
.Multicast_Address
);
1157 To_Inet_Addr
(To_In_Addr
(V8
(V8
'Last)), Opt
.Local_Interface
);
1159 when Multicast_If
=>
1160 To_Inet_Addr
(To_In_Addr
(V4
), Opt
.Outgoing_If
);
1162 when Multicast_TTL
=>
1163 Opt
.Time_To_Live
:= Integer (V1
);
1165 when Multicast_Loop |
1166 Receive_Packet_Info
=>
1167 Opt
.Enabled
:= (V1
/= 0);
1171 Opt
.Timeout
:= To_Duration
(VT
);
1175 end Get_Socket_Option
;
1181 function Host_Name
return String is
1182 Name
: aliased C
.char_array
(1 .. 64);
1186 Res
:= C_Gethostname
(Name
'Address, Name
'Length);
1188 if Res
= Failure
then
1189 Raise_Socket_Error
(Socket_Errno
);
1192 return C
.To_Ada
(Name
);
1200 (Val
: Inet_Addr_VN_Type
;
1201 Hex
: Boolean := False) return String
1203 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1204 -- has at most a length of 3 plus one '.' character.
1206 Buffer
: String (1 .. 4 * Val
'Length);
1207 Length
: Natural := 1;
1208 Separator
: Character;
1210 procedure Img10
(V
: Inet_Addr_Comp_Type
);
1211 -- Append to Buffer image of V in decimal format
1213 procedure Img16
(V
: Inet_Addr_Comp_Type
);
1214 -- Append to Buffer image of V in hexadecimal format
1220 procedure Img10
(V
: Inet_Addr_Comp_Type
) is
1221 Img
: constant String := V
'Img;
1222 Len
: constant Natural := Img
'Length - 1;
1224 Buffer
(Length
.. Length
+ Len
- 1) := Img
(2 .. Img
'Last);
1225 Length
:= Length
+ Len
;
1232 procedure Img16
(V
: Inet_Addr_Comp_Type
) is
1234 Buffer
(Length
) := Hex_To_Char
(Natural (V
/ 16) + 1);
1235 Buffer
(Length
+ 1) := Hex_To_Char
(Natural (V
mod 16) + 1);
1236 Length
:= Length
+ 2;
1239 -- Start of processing for Image
1242 Separator
:= (if Hex
then ':' else '.');
1244 for J
in Val
'Range loop
1251 if J
/= Val
'Last then
1252 Buffer
(Length
) := Separator
;
1253 Length
:= Length
+ 1;
1257 return Buffer
(1 .. Length
- 1);
1264 function Image
(Value
: Inet_Addr_Type
) return String is
1266 if Value
.Family
= Family_Inet
then
1267 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V4
), Hex
=> False);
1269 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V6
), Hex
=> True);
1277 function Image
(Value
: Sock_Addr_Type
) return String is
1278 Port
: constant String := Value
.Port
'Img;
1280 return Image
(Value
.Addr
) & ':' & Port
(2 .. Port
'Last);
1287 function Image
(Socket
: Socket_Type
) return String is
1296 function Image
(Item
: Socket_Set_Type
) return String is
1297 Socket_Set
: Socket_Set_Type
:= Item
;
1301 Last_Img
: constant String := Socket_Set
.Last
'Img;
1303 (1 .. (Integer (Socket_Set
.Last
) + 1) * Last_Img
'Length);
1304 Index
: Positive := 1;
1305 Socket
: Socket_Type
;
1308 while not Is_Empty
(Socket_Set
) loop
1309 Get
(Socket_Set
, Socket
);
1312 Socket_Img
: constant String := Socket
'Img;
1314 Buffer
(Index
.. Index
+ Socket_Img
'Length - 1) := Socket_Img
;
1315 Index
:= Index
+ Socket_Img
'Length;
1319 return "[" & Last_Img
& "]" & Buffer
(1 .. Index
- 1);
1327 function Inet_Addr
(Image
: String) return Inet_Addr_Type
is
1329 use Interfaces
.C
.Strings
;
1331 Img
: aliased char_array
:= To_C
(Image
);
1332 Addr
: aliased C
.int
;
1334 Result
: Inet_Addr_Type
;
1337 -- Special case for an empty Image as on some platforms (e.g. Windows)
1338 -- calling Inet_Addr("") will not return an error.
1341 Raise_Socket_Error
(SOSC
.EINVAL
);
1344 Res
:= Inet_Pton
(SOSC
.AF_INET
, Img
'Address, Addr
'Address);
1347 Raise_Socket_Error
(Socket_Errno
);
1350 Raise_Socket_Error
(SOSC
.EINVAL
);
1353 To_Inet_Addr
(To_In_Addr
(Addr
), Result
);
1361 procedure Initialize
(X
: in out Sockets_Library_Controller
) is
1362 pragma Unreferenced
(X
);
1372 procedure Initialize
(Process_Blocking_IO
: Boolean) is
1373 Expected
: constant Boolean := not SOSC
.Thread_Blocking_IO
;
1376 if Process_Blocking_IO
/= Expected
then
1377 raise Socket_Error
with
1378 "incorrect Process_Blocking_IO setting, expected " & Expected
'Img;
1381 -- This is a dummy placeholder for an obsolete API
1383 -- Real initialization actions are in Initialize primitive operation
1384 -- of Sockets_Library_Controller.
1393 procedure Initialize
is
1395 -- This is a dummy placeholder for an obsolete API
1397 -- Real initialization actions are in Initialize primitive operation
1398 -- of Sockets_Library_Controller.
1407 function Is_Empty
(Item
: Socket_Set_Type
) return Boolean is
1409 return Item
.Last
= No_Socket
;
1416 function Is_IP_Address
(Name
: String) return Boolean is
1418 for J
in Name
'Range loop
1420 and then Name
(J
) not in '0' .. '9'
1433 function Is_Open
(S
: Selector_Type
) return Boolean is
1439 -- Either both controlling socket descriptors are valid (case of an
1440 -- open selector) or neither (case of a closed selector).
1442 pragma Assert
((S
.R_Sig_Socket
/= No_Socket
)
1444 (S
.W_Sig_Socket
/= No_Socket
));
1446 return S
.R_Sig_Socket
/= No_Socket
;
1455 (Item
: Socket_Set_Type
;
1456 Socket
: Socket_Type
) return Boolean
1459 return Item
.Last
/= No_Socket
1460 and then Socket
<= Item
.Last
1461 and then Is_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
)) /= 0;
1468 procedure Listen_Socket
1469 (Socket
: Socket_Type
;
1470 Length
: Natural := 15)
1472 Res
: constant C
.int
:= C_Listen
(C
.int
(Socket
), C
.int
(Length
));
1474 if Res
= Failure
then
1475 Raise_Socket_Error
(Socket_Errno
);
1483 procedure Narrow
(Item
: in out Socket_Set_Type
) is
1484 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
1486 if Item
.Last
/= No_Socket
then
1487 Last_Socket_In_Set
(Item
.Set
'Access, Last
'Unchecked_Access);
1488 Item
.Last
:= Socket_Type
(Last
);
1496 procedure Netdb_Lock
is
1498 if Need_Netdb_Lock
then
1499 System
.Task_Lock
.Lock
;
1507 procedure Netdb_Unlock
is
1509 if Need_Netdb_Lock
then
1510 System
.Task_Lock
.Unlock
;
1514 --------------------------------
1515 -- Normalize_Empty_Socket_Set --
1516 --------------------------------
1518 procedure Normalize_Empty_Socket_Set
(S
: in out Socket_Set_Type
) is
1520 if S
.Last
= No_Socket
then
1521 Reset_Socket_Set
(S
.Set
'Access);
1523 end Normalize_Empty_Socket_Set
;
1529 function Official_Name
(E
: Host_Entry_Type
) return String is
1531 return To_String
(E
.Official
);
1538 function Official_Name
(S
: Service_Entry_Type
) return String is
1540 return To_String
(S
.Official
);
1543 --------------------
1544 -- Wait_On_Socket --
1545 --------------------
1547 procedure Wait_On_Socket
1548 (Socket
: Socket_Type
;
1550 Timeout
: Selector_Duration
;
1551 Selector
: access Selector_Type
:= null;
1552 Status
: out Selector_Status
)
1554 type Local_Selector_Access
is access Selector_Type
;
1555 for Local_Selector_Access
'Storage_Size use Selector_Type
'Size;
1557 S
: Selector_Access
;
1558 -- Selector to use for waiting
1560 R_Fd_Set
: Socket_Set_Type
;
1561 W_Fd_Set
: Socket_Set_Type
;
1564 -- Create selector if not provided by the user
1566 if Selector
= null then
1568 Local_S
: constant Local_Selector_Access
:= new Selector_Type
;
1570 S
:= Local_S
.all'Unchecked_Access;
1571 Create_Selector
(S
.all);
1575 S
:= Selector
.all'Access;
1579 Set
(R_Fd_Set
, Socket
);
1581 Set
(W_Fd_Set
, Socket
);
1584 Check_Selector
(S
.all, R_Fd_Set
, W_Fd_Set
, Status
, Timeout
);
1586 if Selector
= null then
1587 Close_Selector
(S
.all);
1595 function Port_Number
(S
: Service_Entry_Type
) return Port_Type
is
1604 function Protocol_Name
(S
: Service_Entry_Type
) return String is
1606 return To_String
(S
.Protocol
);
1609 ----------------------
1610 -- Raise_Host_Error --
1611 ----------------------
1613 procedure Raise_Host_Error
(H_Error
: Integer) is
1615 raise Host_Error
with
1616 Err_Code_Image
(H_Error
)
1617 & C
.Strings
.Value
(Host_Error_Messages
.Host_Error_Message
(H_Error
));
1618 end Raise_Host_Error
;
1620 ------------------------
1621 -- Raise_Socket_Error --
1622 ------------------------
1624 procedure Raise_Socket_Error
(Error
: Integer) is
1625 use type C
.Strings
.chars_ptr
;
1627 raise Socket_Error
with
1628 Err_Code_Image
(Error
)
1629 & C
.Strings
.Value
(Socket_Error_Message
(Error
));
1630 end Raise_Socket_Error
;
1637 (Stream
: in out Datagram_Socket_Stream_Type
;
1638 Item
: out Ada
.Streams
.Stream_Element_Array
;
1639 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1641 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1642 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1643 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1649 Item
(First
.. Max
),
1655 -- Exit when all or zero data received. Zero means that the socket
1658 exit when Index
< First
or else Index
= Max
;
1669 (Stream
: in out Stream_Socket_Stream_Type
;
1670 Item
: out Ada
.Streams
.Stream_Element_Array
;
1671 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1673 pragma Warnings
(Off
, Stream
);
1675 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1676 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1677 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1681 Receive_Socket
(Stream
.Socket
, Item
(First
.. Max
), Index
);
1684 -- Exit when all or zero data received. Zero means that the socket
1687 exit when Index
< First
or else Index
= Max
;
1693 --------------------
1694 -- Receive_Socket --
1695 --------------------
1697 procedure Receive_Socket
1698 (Socket
: Socket_Type
;
1699 Item
: out Ada
.Streams
.Stream_Element_Array
;
1700 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1701 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1707 C_Recv
(C
.int
(Socket
), Item
'Address, Item
'Length, To_Int
(Flags
));
1709 if Res
= Failure
then
1710 Raise_Socket_Error
(Socket_Errno
);
1713 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1716 --------------------
1717 -- Receive_Socket --
1718 --------------------
1720 procedure Receive_Socket
1721 (Socket
: Socket_Type
;
1722 Item
: out Ada
.Streams
.Stream_Element_Array
;
1723 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1724 From
: out Sock_Addr_Type
;
1725 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1728 Sin
: aliased Sockaddr_In
;
1729 Len
: aliased C
.int
:= Sin
'Size / 8;
1741 if Res
= Failure
then
1742 Raise_Socket_Error
(Socket_Errno
);
1745 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
1747 To_Inet_Addr
(Sin
.Sin_Addr
, From
.Addr
);
1748 From
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1751 --------------------
1752 -- Receive_Vector --
1753 --------------------
1755 procedure Receive_Vector
1756 (Socket
: Socket_Type
;
1757 Vector
: Vector_Type
;
1758 Count
: out Ada
.Streams
.Stream_Element_Count
;
1759 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1764 (Msg_Name
=> System
.Null_Address
,
1766 Msg_Iov
=> Vector
'Address,
1768 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1769 -- platforms) when the supplied vector is longer than IOV_MAX,
1770 -- so use minimum of the two lengths.
1772 Msg_Iovlen
=> SOSC
.Msg_Iovlen_T
'Min
1773 (Vector
'Length, SOSC
.IOV_MAX
),
1775 Msg_Control
=> System
.Null_Address
,
1776 Msg_Controllen
=> 0,
1786 if Res
= ssize_t
(Failure
) then
1787 Raise_Socket_Error
(Socket_Errno
);
1790 Count
:= Ada
.Streams
.Stream_Element_Count
(Res
);
1797 function Resolve_Error
1798 (Error_Value
: Integer;
1799 From_Errno
: Boolean := True) return Error_Type
1801 use GNAT
.Sockets
.SOSC
;
1804 if not From_Errno
then
1806 when SOSC
.HOST_NOT_FOUND
=> return Unknown_Host
;
1807 when SOSC
.TRY_AGAIN
=> return Host_Name_Lookup_Failure
;
1808 when SOSC
.NO_RECOVERY
=> return Non_Recoverable_Error
;
1809 when SOSC
.NO_DATA
=> return Unknown_Server_Error
;
1810 when others => return Cannot_Resolve_Error
;
1814 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1815 -- can't include it in the case statement below.
1817 pragma Warnings
(Off
);
1818 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1820 if EAGAIN
/= EWOULDBLOCK
and then Error_Value
= EAGAIN
then
1821 return Resource_Temporarily_Unavailable
;
1824 pragma Warnings
(On
);
1826 -- This is not a case statement because if a particular error
1827 -- number constant is not defined, s-oscons-tmplt.c defines
1828 -- it to -1. If multiple constants are not defined, they
1829 -- would each be -1 and result in a "duplicate value in case" error.
1830 if Error_Value
= ENOERROR
then
1832 elsif Error_Value
= EACCES
then
1833 return Permission_Denied
;
1834 elsif Error_Value
= EADDRINUSE
then
1835 return Address_Already_In_Use
;
1836 elsif Error_Value
= EADDRNOTAVAIL
then
1837 return Cannot_Assign_Requested_Address
;
1838 elsif Error_Value
= EAFNOSUPPORT
then
1839 return Address_Family_Not_Supported_By_Protocol
;
1840 elsif Error_Value
= EALREADY
then
1841 return Operation_Already_In_Progress
;
1842 elsif Error_Value
= EBADF
then
1843 return Bad_File_Descriptor
;
1844 elsif Error_Value
= ECONNABORTED
then
1845 return Software_Caused_Connection_Abort
;
1846 elsif Error_Value
= ECONNREFUSED
then
1847 return Connection_Refused
;
1848 elsif Error_Value
= ECONNRESET
then
1849 return Connection_Reset_By_Peer
;
1850 elsif Error_Value
= EDESTADDRREQ
then
1851 return Destination_Address_Required
;
1852 elsif Error_Value
= EFAULT
then
1854 elsif Error_Value
= EHOSTDOWN
then
1855 return Host_Is_Down
;
1856 elsif Error_Value
= EHOSTUNREACH
then
1857 return No_Route_To_Host
;
1858 elsif Error_Value
= EINPROGRESS
then
1859 return Operation_Now_In_Progress
;
1860 elsif Error_Value
= EINTR
then
1861 return Interrupted_System_Call
;
1862 elsif Error_Value
= EINVAL
then
1863 return Invalid_Argument
;
1864 elsif Error_Value
= EIO
then
1865 return Input_Output_Error
;
1866 elsif Error_Value
= EISCONN
then
1867 return Transport_Endpoint_Already_Connected
;
1868 elsif Error_Value
= ELOOP
then
1869 return Too_Many_Symbolic_Links
;
1870 elsif Error_Value
= EMFILE
then
1871 return Too_Many_Open_Files
;
1872 elsif Error_Value
= EMSGSIZE
then
1873 return Message_Too_Long
;
1874 elsif Error_Value
= ENAMETOOLONG
then
1875 return File_Name_Too_Long
;
1876 elsif Error_Value
= ENETDOWN
then
1877 return Network_Is_Down
;
1878 elsif Error_Value
= ENETRESET
then
1879 return Network_Dropped_Connection_Because_Of_Reset
;
1880 elsif Error_Value
= ENETUNREACH
then
1881 return Network_Is_Unreachable
;
1882 elsif Error_Value
= ENOBUFS
then
1883 return No_Buffer_Space_Available
;
1884 elsif Error_Value
= ENOPROTOOPT
then
1885 return Protocol_Not_Available
;
1886 elsif Error_Value
= ENOTCONN
then
1887 return Transport_Endpoint_Not_Connected
;
1888 elsif Error_Value
= ENOTSOCK
then
1889 return Socket_Operation_On_Non_Socket
;
1890 elsif Error_Value
= EOPNOTSUPP
then
1891 return Operation_Not_Supported
;
1892 elsif Error_Value
= EPFNOSUPPORT
then
1893 return Protocol_Family_Not_Supported
;
1894 elsif Error_Value
= EPIPE
then
1896 elsif Error_Value
= EPROTONOSUPPORT
then
1897 return Protocol_Not_Supported
;
1898 elsif Error_Value
= EPROTOTYPE
then
1899 return Protocol_Wrong_Type_For_Socket
;
1900 elsif Error_Value
= ESHUTDOWN
then
1901 return Cannot_Send_After_Transport_Endpoint_Shutdown
;
1902 elsif Error_Value
= ESOCKTNOSUPPORT
then
1903 return Socket_Type_Not_Supported
;
1904 elsif Error_Value
= ETIMEDOUT
then
1905 return Connection_Timed_Out
;
1906 elsif Error_Value
= ETOOMANYREFS
then
1907 return Too_Many_References
;
1908 elsif Error_Value
= EWOULDBLOCK
then
1909 return Resource_Temporarily_Unavailable
;
1911 return Cannot_Resolve_Error
;
1915 -----------------------
1916 -- Resolve_Exception --
1917 -----------------------
1919 function Resolve_Exception
1920 (Occurrence
: Exception_Occurrence
) return Error_Type
1922 Id
: constant Exception_Id
:= Exception_Identity
(Occurrence
);
1923 Msg
: constant String := Exception_Message
(Occurrence
);
1930 while First
<= Msg
'Last
1931 and then Msg
(First
) not in '0' .. '9'
1936 if First
> Msg
'Last then
1937 return Cannot_Resolve_Error
;
1941 while Last
< Msg
'Last
1942 and then Msg
(Last
+ 1) in '0' .. '9'
1947 Val
:= Integer'Value (Msg
(First
.. Last
));
1949 if Id
= Socket_Error_Id
then
1950 return Resolve_Error
(Val
);
1952 elsif Id
= Host_Error_Id
then
1953 return Resolve_Error
(Val
, False);
1956 return Cannot_Resolve_Error
;
1958 end Resolve_Exception
;
1964 procedure Send_Socket
1965 (Socket
: Socket_Type
;
1966 Item
: Ada
.Streams
.Stream_Element_Array
;
1967 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1968 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1971 Send_Socket
(Socket
, Item
, Last
, To
=> null, Flags
=> Flags
);
1978 procedure Send_Socket
1979 (Socket
: Socket_Type
;
1980 Item
: Ada
.Streams
.Stream_Element_Array
;
1981 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1982 To
: Sock_Addr_Type
;
1983 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1987 (Socket
, Item
, Last
, To
=> To
'Unrestricted_Access, Flags
=> Flags
);
1994 procedure Send_Socket
1995 (Socket
: Socket_Type
;
1996 Item
: Ada
.Streams
.Stream_Element_Array
;
1997 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1998 To
: access Sock_Addr_Type
;
1999 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2003 Sin
: aliased Sockaddr_In
;
2004 C_To
: System
.Address
;
2009 Set_Family
(Sin
.Sin_Family
, To
.Family
);
2010 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(To
.Addr
));
2012 (Sin
'Unchecked_Access,
2013 Short_To_Network
(C
.unsigned_short
(To
.Port
)));
2014 C_To
:= Sin
'Address;
2015 Len
:= Sin
'Size / 8;
2018 C_To
:= System
.Null_Address
;
2026 Set_Forced_Flags
(To_Int
(Flags
)),
2030 if Res
= Failure
then
2031 Raise_Socket_Error
(Socket_Errno
);
2034 Last
:= Last_Index
(First
=> Item
'First, Count
=> size_t
(Res
));
2041 procedure Send_Vector
2042 (Socket
: Socket_Type
;
2043 Vector
: Vector_Type
;
2044 Count
: out Ada
.Streams
.Stream_Element_Count
;
2045 Flags
: Request_Flag_Type
:= No_Request_Flag
)
2051 Iov_Count
: SOSC
.Msg_Iovlen_T
;
2052 This_Iov_Count
: SOSC
.Msg_Iovlen_T
;
2058 while Iov_Count
< Vector
'Length loop
2060 pragma Warnings
(Off
);
2061 -- Following test may be compile time known on some targets
2064 (if Vector
'Length - Iov_Count
> SOSC
.IOV_MAX
2066 else Vector
'Length - Iov_Count
);
2068 pragma Warnings
(On
);
2071 (Msg_Name
=> System
.Null_Address
,
2074 (Vector
'First + Integer (Iov_Count
))'Address,
2075 Msg_Iovlen
=> This_Iov_Count
,
2076 Msg_Control
=> System
.Null_Address
,
2077 Msg_Controllen
=> 0,
2084 Set_Forced_Flags
(To_Int
(Flags
)));
2086 if Res
= ssize_t
(Failure
) then
2087 Raise_Socket_Error
(Socket_Errno
);
2090 Count
:= Count
+ Ada
.Streams
.Stream_Element_Count
(Res
);
2091 Iov_Count
:= Iov_Count
+ This_Iov_Count
;
2099 procedure Set
(Item
: in out Socket_Set_Type
; Socket
: Socket_Type
) is
2101 if Item
.Last
= No_Socket
then
2103 -- Uninitialized socket set, make sure it is properly zeroed out
2105 Reset_Socket_Set
(Item
.Set
'Access);
2106 Item
.Last
:= Socket
;
2108 elsif Item
.Last
< Socket
then
2109 Item
.Last
:= Socket
;
2112 Insert_Socket_In_Set
(Item
.Set
'Access, C
.int
(Socket
));
2115 ----------------------
2116 -- Set_Forced_Flags --
2117 ----------------------
2119 function Set_Forced_Flags
(F
: C
.int
) return C
.int
is
2120 use type C
.unsigned
;
2121 function To_unsigned
is
2122 new Ada
.Unchecked_Conversion
(C
.int
, C
.unsigned
);
2124 new Ada
.Unchecked_Conversion
(C
.unsigned
, C
.int
);
2126 return To_int
(To_unsigned
(F
) or SOSC
.MSG_Forced_Flags
);
2127 end Set_Forced_Flags
;
2129 -----------------------
2130 -- Set_Socket_Option --
2131 -----------------------
2133 procedure Set_Socket_Option
2134 (Socket
: Socket_Type
;
2135 Level
: Level_Type
:= Socket_Level
;
2136 Option
: Option_Type
)
2138 V8
: aliased Two_Ints
;
2140 V1
: aliased C
.unsigned_char
;
2141 VT
: aliased Timeval
;
2143 Add
: System
.Address
:= Null_Address
;
2152 V4
:= C
.int
(Boolean'Pos (Option
.Enabled
));
2157 V8
(V8
'First) := C
.int
(Boolean'Pos (Option
.Enabled
));
2158 V8
(V8
'Last) := C
.int
(Option
.Seconds
);
2164 V4
:= C
.int
(Option
.Size
);
2169 V4
:= C
.int
(Boolean'Pos (True));
2173 when Add_Membership |
2175 V8
(V8
'First) := To_Int
(To_In_Addr
(Option
.Multicast_Address
));
2176 V8
(V8
'Last) := To_Int
(To_In_Addr
(Option
.Local_Interface
));
2180 when Multicast_If
=>
2181 V4
:= To_Int
(To_In_Addr
(Option
.Outgoing_If
));
2185 when Multicast_TTL
=>
2186 V1
:= C
.unsigned_char
(Option
.Time_To_Live
);
2190 when Multicast_Loop |
2191 Receive_Packet_Info
=>
2192 V1
:= C
.unsigned_char
(Boolean'Pos (Option
.Enabled
));
2198 VT
:= To_Timeval
(Option
.Timeout
);
2207 Options
(Option
.Name
),
2210 if Res
= Failure
then
2211 Raise_Socket_Error
(Socket_Errno
);
2213 end Set_Socket_Option
;
2215 ----------------------
2216 -- Short_To_Network --
2217 ----------------------
2219 function Short_To_Network
(S
: C
.unsigned_short
) return C
.unsigned_short
is
2220 use type C
.unsigned_short
;
2223 -- Big-endian case. No conversion needed. On these platforms,
2224 -- htons() defaults to a null procedure.
2226 pragma Warnings
(Off
);
2227 -- Since the test can generate "always True/False" warning
2229 if Default_Bit_Order
= High_Order_First
then
2232 pragma Warnings
(On
);
2234 -- Little-endian case. We must swap the high and low bytes of this
2235 -- short to make the port number network compliant.
2238 return (S
/ 256) + (S
mod 256) * 256;
2240 end Short_To_Network
;
2242 ---------------------
2243 -- Shutdown_Socket --
2244 ---------------------
2246 procedure Shutdown_Socket
2247 (Socket
: Socket_Type
;
2248 How
: Shutmode_Type
:= Shut_Read_Write
)
2253 Res
:= C_Shutdown
(C
.int
(Socket
), Shutmodes
(How
));
2255 if Res
= Failure
then
2256 Raise_Socket_Error
(Socket_Errno
);
2258 end Shutdown_Socket
;
2265 (Socket
: Socket_Type
;
2266 Send_To
: Sock_Addr_Type
) return Stream_Access
2268 S
: Datagram_Socket_Stream_Access
;
2271 S
:= new Datagram_Socket_Stream_Type
;
2274 S
.From
:= Get_Socket_Name
(Socket
);
2275 return Stream_Access
(S
);
2282 function Stream
(Socket
: Socket_Type
) return Stream_Access
is
2283 S
: Stream_Socket_Stream_Access
;
2285 S
:= new Stream_Socket_Stream_Type
;
2287 return Stream_Access
(S
);
2294 procedure Stream_Write
2295 (Socket
: Socket_Type
;
2296 Item
: Ada
.Streams
.Stream_Element_Array
;
2297 To
: access Sock_Addr_Type
)
2299 First
: Ada
.Streams
.Stream_Element_Offset
;
2300 Index
: Ada
.Streams
.Stream_Element_Offset
;
2301 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
2304 First
:= Item
'First;
2306 while First
<= Max
loop
2307 Send_Socket
(Socket
, Item
(First
.. Max
), Index
, To
);
2309 -- Exit when all or zero data sent. Zero means that the socket has
2310 -- been closed by peer.
2312 exit when Index
< First
or else Index
= Max
;
2317 -- For an empty array, we have First > Max, and hence Index >= Max (no
2318 -- error, the loop above is never executed). After a succesful send,
2319 -- Index = Max. The only remaining case, Index < Max, is therefore
2320 -- always an actual send failure.
2323 Raise_Socket_Error
(Socket_Errno
);
2331 function To_C
(Socket
: Socket_Type
) return Integer is
2333 return Integer (Socket
);
2340 function To_Duration
(Val
: Timeval
) return Timeval_Duration
is
2342 return Natural (Val
.Tv_Sec
) * 1.0 + Natural (Val
.Tv_Usec
) * 1.0E-6;
2349 function To_Host_Entry
(E
: Hostent_Access
) return Host_Entry_Type
is
2353 Aliases_Count
, Addresses_Count
: Natural;
2355 -- H_Length is not used because it is currently only set to 4
2356 -- H_Addrtype is always AF_INET
2360 while Hostent_H_Alias
(E
, C
.int
(Aliases_Count
)) /= Null_Address
loop
2361 Aliases_Count
:= Aliases_Count
+ 1;
2364 Addresses_Count
:= 0;
2365 while Hostent_H_Addr
(E
, C
.int
(Addresses_Count
)) /= Null_Address
loop
2366 Addresses_Count
:= Addresses_Count
+ 1;
2369 return Result
: Host_Entry_Type
2370 (Aliases_Length
=> Aliases_Count
,
2371 Addresses_Length
=> Addresses_Count
)
2373 Result
.Official
:= To_Name
(Value
(Hostent_H_Name
(E
)));
2375 for J
in Result
.Aliases
'Range loop
2376 Result
.Aliases
(J
) :=
2377 To_Name
(Value
(Hostent_H_Alias
2378 (E
, C
.int
(J
- Result
.Aliases
'First))));
2381 for J
in Result
.Addresses
'Range loop
2384 for Addr
'Address use
2385 Hostent_H_Addr
(E
, C
.int
(J
- Result
.Addresses
'First));
2386 pragma Import
(Ada
, Addr
);
2388 To_Inet_Addr
(Addr
, Result
.Addresses
(J
));
2398 function To_In_Addr
(Addr
: Inet_Addr_Type
) return In_Addr
is
2400 if Addr
.Family
= Family_Inet
then
2401 return (S_B1
=> C
.unsigned_char
(Addr
.Sin_V4
(1)),
2402 S_B2
=> C
.unsigned_char
(Addr
.Sin_V4
(2)),
2403 S_B3
=> C
.unsigned_char
(Addr
.Sin_V4
(3)),
2404 S_B4
=> C
.unsigned_char
(Addr
.Sin_V4
(4)));
2407 raise Socket_Error
with "IPv6 not supported";
2414 procedure To_Inet_Addr
2416 Result
: out Inet_Addr_Type
) is
2418 Result
.Sin_V4
(1) := Inet_Addr_Comp_Type
(Addr
.S_B1
);
2419 Result
.Sin_V4
(2) := Inet_Addr_Comp_Type
(Addr
.S_B2
);
2420 Result
.Sin_V4
(3) := Inet_Addr_Comp_Type
(Addr
.S_B3
);
2421 Result
.Sin_V4
(4) := Inet_Addr_Comp_Type
(Addr
.S_B4
);
2428 function To_Int
(F
: Request_Flag_Type
) return C
.int
2430 Current
: Request_Flag_Type
:= F
;
2431 Result
: C
.int
:= 0;
2434 for J
in Flags
'Range loop
2435 exit when Current
= 0;
2437 if Current
mod 2 /= 0 then
2438 if Flags
(J
) = -1 then
2439 Raise_Socket_Error
(SOSC
.EOPNOTSUPP
);
2442 Result
:= Result
+ Flags
(J
);
2445 Current
:= Current
/ 2;
2455 function To_Name
(N
: String) return Name_Type
is
2457 return Name_Type
'(N'Length, N);
2460 ----------------------
2461 -- To_Service_Entry --
2462 ----------------------
2464 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2468 Aliases_Count : Natural;
2472 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2473 Aliases_Count := Aliases_Count + 1;
2476 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
2477 Result.Official := To_Name (Value (Servent_S_Name (E)));
2479 for J in Result.Aliases'Range loop
2480 Result.Aliases (J) :=
2481 To_Name (Value (Servent_S_Alias
2482 (E, C.int (J - Result.Aliases'First))));
2485 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2487 Port_Type (Network_To_Short (Servent_S_Port (E)));
2489 end To_Service_Entry;
2495 function To_String (HN : Name_Type) return String is
2497 return HN.Name (1 .. HN.Length);
2504 function To_Timeval (Val : Timeval_Duration) return Timeval is
2509 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2515 -- Normal case where we do round down
2518 S := time_t (Val - 0.5);
2519 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2529 function Value (S : System.Address) return String is
2530 Str : String (1 .. Positive'Last);
2531 for Str'Address use S;
2532 pragma Import (Ada, Str);
2534 Terminator : Positive := Str'First;
2537 while Str (Terminator) /= ASCII.NUL loop
2538 Terminator := Terminator + 1;
2541 return Str (1 .. Terminator - 1);
2549 (Stream : in out Datagram_Socket_Stream_Type;
2550 Item : Ada.Streams.Stream_Element_Array)
2553 Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2561 (Stream : in out Stream_Socket_Stream_Type;
2562 Item : Ada.Streams.Stream_Element_Array)
2565 Stream_Write (Stream.Socket, Item, To => null);
2568 Sockets_Library_Controller_Object : Sockets_Library_Controller;
2569 pragma Unreferenced (Sockets_Library_Controller_Object);
2570 -- The elaboration and finalization of this object perform the required
2571 -- initialization and cleanup actions for the sockets library.