Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / libgnat / g-socket.adb
blob: 12abb683bb0b603e33f935bf31a657a89ce3331b [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2022, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Containers.Generic_Array_Sort;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Finalization;
with Ada.Streams; use Ada.Streams;
with Ada.Unchecked_Conversion;
with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
with GNAT.Sockets.Linker_Options;
pragma Warnings (Off, GNAT.Sockets.Linker_Options);
-- Need to include pragma Linker_Options which is platform dependent
with GNAT.Sockets.Poll;
with System; use System;
with System.Communication; use System.Communication;
with System.CRTL; use System.CRTL;
with System.Task_Lock;
package body GNAT.Sockets is
package C renames Interfaces.C;
type IPV6_Mreq is record
ipv6mr_multiaddr : In6_Addr;
ipv6mr_interface : C.unsigned;
end record with Convention => C;
-- Record to Add/Drop_Membership for multicast in IPv6
ENOERROR : constant := 0;
Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
-- The network database functions gethostbyname, gethostbyaddr,
-- getservbyname and getservbyport can either be guaranteed task safe by
-- the operating system, or else return data through a user-provided buffer
-- to ensure concurrent uses do not interfere.
-- Correspondence tables
Levels : constant array (Level_Type) of C.int :=
[Socket_Level => SOSC.SOL_SOCKET,
IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
IP_Protocol_For_IPv6_Level => SOSC.IPPROTO_IPV6,
IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP,
IP_Protocol_For_ICMP_Level => SOSC.IPPROTO_ICMP,
IP_Protocol_For_IGMP_Level => SOSC.IPPROTO_IGMP,
IP_Protocol_For_RAW_Level => SOSC.IPPROTO_RAW];
Modes : constant array (Mode_Type) of C.int :=
[Socket_Stream => SOSC.SOCK_STREAM,
Socket_Datagram => SOSC.SOCK_DGRAM,
Socket_Raw => SOSC.SOCK_RAW];
Shutmodes : constant array (Shutmode_Type) of C.int :=
[Shut_Read => SOSC.SHUT_RD,
Shut_Write => SOSC.SHUT_WR,
Shut_Read_Write => SOSC.SHUT_RDWR];
Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T :=
[Non_Blocking_IO => SOSC.FIONBIO,
N_Bytes_To_Read => SOSC.FIONREAD];
Options : constant array (Specific_Option_Name) of C.int :=
[Keep_Alive => SOSC.SO_KEEPALIVE,
Keep_Alive_Count => SOSC.TCP_KEEPCNT,
Keep_Alive_Idle => SOSC.TCP_KEEPIDLE,
Keep_Alive_Interval => SOSC.TCP_KEEPINTVL,
Reuse_Address => SOSC.SO_REUSEADDR,
Broadcast => SOSC.SO_BROADCAST,
Send_Buffer => SOSC.SO_SNDBUF,
Receive_Buffer => SOSC.SO_RCVBUF,
Linger => SOSC.SO_LINGER,
Error => SOSC.SO_ERROR,
No_Delay => SOSC.TCP_NODELAY,
Add_Membership_V4 => SOSC.IP_ADD_MEMBERSHIP,
Drop_Membership_V4 => SOSC.IP_DROP_MEMBERSHIP,
Multicast_If_V4 => SOSC.IP_MULTICAST_IF,
Multicast_Loop_V4 => SOSC.IP_MULTICAST_LOOP,
Receive_Packet_Info => SOSC.IP_PKTINFO,
Multicast_TTL => SOSC.IP_MULTICAST_TTL,
Add_Membership_V6 => SOSC.IPV6_ADD_MEMBERSHIP,
Drop_Membership_V6 => SOSC.IPV6_DROP_MEMBERSHIP,
Multicast_If_V6 => SOSC.IPV6_MULTICAST_IF,
Multicast_Loop_V6 => SOSC.IPV6_MULTICAST_LOOP,
Multicast_Hops => SOSC.IPV6_MULTICAST_HOPS,
IPv6_Only => SOSC.IPV6_V6ONLY,
Send_Timeout => SOSC.SO_SNDTIMEO,
Receive_Timeout => SOSC.SO_RCVTIMEO,
Busy_Polling => SOSC.SO_BUSY_POLL];
-- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
-- but for Linux compatibility this constant is the same as IP_PKTINFO.
Flags : constant array (0 .. 3) of C.int :=
[0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
3 => SOSC.MSG_EOR]; -- Send_End_Of_Record
Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
Host_Error_Id : constant Exception_Id := Host_Error'Identity;
type In_Addr_Union (Family : Family_Inet_4_6) is record
case Family is
when Family_Inet =>
In4 : In_Addr;
when Family_Inet6 =>
In6 : In6_Addr;
end case;
end record with Unchecked_Union;
-----------------------
-- Local subprograms --
-----------------------
function Resolve_Error
(Error_Value : Integer;
From_Errno : Boolean := True) return Error_Type;
-- Associate an enumeration value (error_type) to an error value (errno).
-- From_Errno prevents from mixing h_errno with errno.
function To_Name (N : String) return Name_Type;
function To_String (HN : Name_Type) return String;
-- Conversion functions
function To_Int (F : Request_Flag_Type) return C.int;
-- Return the int value corresponding to the specified flags combination
function Set_Forced_Flags (F : C.int) return C.int;
-- Return F with the bits from SOSC.MSG_Forced_Flags forced set
procedure Netdb_Lock;
pragma Inline (Netdb_Lock);
procedure Netdb_Unlock;
pragma Inline (Netdb_Unlock);
-- Lock/unlock operation used to protect netdb access for platforms that
-- require such protection.
function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
-- Conversion function
function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
-- Conversion function
function Value (S : System.Address) return String;
-- Same as Interfaces.C.Strings.Value but taking a System.Address
function To_Timeval (Val : Timeval_Duration) return Timeval;
-- Separate Val in seconds and microseconds
function To_Duration (Val : Timeval) return Timeval_Duration;
-- Reconstruct a Duration value from a Timeval record (seconds and
-- microseconds).
function Dedot (Value : String) return String
is (if Value /= "" and then Value (Value'Last) = '.'
then Value (Value'First .. Value'Last - 1)
else Value);
-- Removes dot at the end of error message
procedure Raise_Host_Error (H_Error : Integer; Name : String);
-- Raise Host_Error exception with message describing error code (note
-- hstrerror seems to be obsolete) from h_errno. Name is the name
-- or address that was being looked up.
procedure Raise_GAI_Error (RC : C.int; Name : String);
-- Raise Host_Error with exception message in case of errors in
-- getaddrinfo and getnameinfo.
function Is_Windows return Boolean with Inline;
-- Returns True on Windows platform
procedure Narrow (Item : in out Socket_Set_Type);
-- Update Last as it may be greater than the real last socket
procedure Check_For_Fd_Set (Fd : Socket_Type);
pragma Inline (Check_For_Fd_Set);
-- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
-- FD_SETSIZE, on platforms where fd_set is a bitmap.
function Connect_Socket
(Socket : Socket_Type;
Server : Sock_Addr_Type) return C.int;
pragma Inline (Connect_Socket);
-- Underlying implementation for the Connect_Socket procedures
-- Types needed for Datagram_Socket_Stream_Type
type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
Socket : Socket_Type;
To : Sock_Addr_Type;
From : Sock_Addr_Type;
end record;
type Datagram_Socket_Stream_Access is
access all Datagram_Socket_Stream_Type;
procedure Read
(Stream : in out Datagram_Socket_Stream_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset);
procedure Write
(Stream : in out Datagram_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array);
-- Types needed for Stream_Socket_Stream_Type
type Stream_Socket_Stream_Type is new Root_Stream_Type with record
Socket : Socket_Type;
end record;
type Stream_Socket_Stream_Access is
access all Stream_Socket_Stream_Type;
procedure Read
(Stream : in out Stream_Socket_Stream_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset);
procedure Write
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array);
procedure Wait_On_Socket
(Socket : Socket_Type;
Event : Poll.Wait_Event_Set;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status);
-- Common code for variants of socket operations supporting a timeout:
-- block in Poll.Wait on Socket for at most the indicated timeout.
-- Event parameter defines what the Poll.Wait is waiting for.
type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
with null record;
-- This type is used to generate automatic calls to Initialize and Finalize
-- during the elaboration and finalization of this package. A single object
-- of this type must exist at library level.
function Err_Code_Image (E : Integer) return String;
-- Return the value of E surrounded with brackets
procedure Initialize (X : in out Sockets_Library_Controller);
procedure Finalize (X : in out Sockets_Library_Controller);
procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
-- If S is the empty set (detected by Last = No_Socket), make sure its
-- fd_set component is actually cleared. Note that the case where it is
-- not can occur for an uninitialized Socket_Set_Type object.
function Is_Open (S : Selector_Type) return Boolean;
-- Return True for an "open" Selector_Type object, i.e. one for which
-- Create_Selector has been called and Close_Selector has not been called,
-- or the null selector.
function Create_Address
(Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
with Inline;
-- Creates address from family and Inet_Addr_Bytes array
function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes
with Inline;
-- Extract bytes from address
---------
-- "+" --
---------
function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
begin
return L or R;
end "+";
--------------------
-- Abort_Selector --
--------------------
procedure Abort_Selector (Selector : Selector_Type) is
Res : C.int;
begin
if not Is_Open (Selector) then
raise Program_Error with "closed selector";
elsif Selector.Is_Null then
raise Program_Error with "null selector";
end if;
-- Send one byte to unblock select system call
Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Abort_Selector;
-------------------
-- Accept_Socket --
-------------------
procedure Accept_Socket
(Server : Socket_Type;
Socket : out Socket_Type;
Address : out Sock_Addr_Type)
is
Res : C.int;
Sin : aliased Sockaddr;
Len : aliased C.int := Sin'Size / 8;
begin
Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Socket := Socket_Type (Res);
Address := Get_Address (Sin, Len);
end Accept_Socket;
-------------------
-- Accept_Socket --
-------------------
procedure Accept_Socket
(Server : Socket_Type;
Socket : out Socket_Type;
Address : out Sock_Addr_Type;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status)
is
begin
if Selector /= null and then not Is_Open (Selector.all) then
raise Program_Error with "closed selector";
end if;
-- Wait for socket to become available for reading
Wait_On_Socket
(Socket => Server,
Event => Poll.Input_Event,
Timeout => Timeout,
Selector => Selector,
Status => Status);
-- Accept connection if available
if Status = Completed then
Accept_Socket (Server, Socket, Address);
else
Socket := No_Socket;
end if;
end Accept_Socket;
---------------
-- Addresses --
---------------
function Addresses
(E : Host_Entry_Type;
N : Positive := 1) return Inet_Addr_Type
is
begin
return E.Addresses (N);
end Addresses;
----------------------
-- Addresses_Length --
----------------------
function Addresses_Length (E : Host_Entry_Type) return Natural is
begin
return E.Addresses_Length;
end Addresses_Length;
-------------
-- Aliases --
-------------
function Aliases
(E : Host_Entry_Type;
N : Positive := 1) return String
is
begin
return To_String (E.Aliases (N));
end Aliases;
-------------
-- Aliases --
-------------
function Aliases
(S : Service_Entry_Type;
N : Positive := 1) return String
is
begin
return To_String (S.Aliases (N));
end Aliases;
--------------------
-- Aliases_Length --
--------------------
function Aliases_Length (E : Host_Entry_Type) return Natural is
begin
return E.Aliases_Length;
end Aliases_Length;
--------------------
-- Aliases_Length --
--------------------
function Aliases_Length (S : Service_Entry_Type) return Natural is
begin
return S.Aliases_Length;
end Aliases_Length;
-----------------
-- Bind_Socket --
-----------------
procedure Bind_Socket
(Socket : Socket_Type;
Address : Sock_Addr_Type)
is
Res : C.int;
Sin : aliased Sockaddr;
Len : C.int;
begin
Set_Address (Sin'Unchecked_Access, Address, Len);
Res := C_Bind (C.int (Socket), Sin'Address, Len);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Bind_Socket;
----------------------
-- Check_For_Fd_Set --
----------------------
procedure Check_For_Fd_Set (Fd : Socket_Type) is
begin
-- On Windows, fd_set is a FD_SETSIZE array of socket ids:
-- no check required. Warnings suppressed because condition
-- is known at compile time.
if Is_Windows then
return;
-- On other platforms, fd_set is an FD_SETSIZE bitmap: check
-- that Fd is within range (otherwise behavior is undefined).
elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
raise Constraint_Error
with "invalid value for socket set: " & Image (Fd);
end if;
end Check_For_Fd_Set;
--------------------
-- Check_Selector --
--------------------
procedure Check_Selector
(Selector : Selector_Type;
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
Timeout : Selector_Duration := Forever)
is
E_Socket_Set : Socket_Set_Type;
begin
Check_Selector
(Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
end Check_Selector;
procedure Check_Selector
(Selector : Selector_Type;
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
E_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
Timeout : Selector_Duration := Forever)
is
Res : C.int;
Last : C.int;
RSig : Socket_Type := No_Socket;
TVal : aliased Timeval;
TPtr : Timeval_Access;
begin
if not Is_Open (Selector) then
raise Program_Error with "closed selector";
end if;
Status := Completed;
-- No timeout or Forever is indicated by a null timeval pointer
if Timeout = Forever then
TPtr := null;
else
TVal := To_Timeval (Timeout);
TPtr := TVal'Unchecked_Access;
end if;
-- Add read signalling socket, if present
if not Selector.Is_Null then
RSig := Selector.R_Sig_Socket;
Set (R_Socket_Set, RSig);
end if;
Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
C.int (W_Socket_Set.Last)),
C.int (E_Socket_Set.Last));
-- Zero out fd_set for empty Socket_Set_Type objects
Normalize_Empty_Socket_Set (R_Socket_Set);
Normalize_Empty_Socket_Set (W_Socket_Set);
Normalize_Empty_Socket_Set (E_Socket_Set);
Res :=
C_Select
(Last + 1,
R_Socket_Set.Set'Access,
W_Socket_Set.Set'Access,
E_Socket_Set.Set'Access,
TPtr);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
-- If Select was resumed because of read signalling socket, read this
-- data and remove socket from set.
if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
Clear (R_Socket_Set, RSig);
Res := Signalling_Fds.Read (C.int (RSig));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Status := Aborted;
elsif Res = 0 then
Status := Expired;
end if;
-- Update socket sets in regard to their new contents
Narrow (R_Socket_Set);
Narrow (W_Socket_Set);
Narrow (E_Socket_Set);
end Check_Selector;
-----------
-- Clear --
-----------
procedure Clear
(Item : in out Socket_Set_Type;
Socket : Socket_Type)
is
Last : aliased C.int := C.int (Item.Last);
begin
Check_For_Fd_Set (Socket);
if Item.Last /= No_Socket then
Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
Item.Last := Socket_Type (Last);
end if;
end Clear;
--------------------
-- Close_Selector --
--------------------
procedure Close_Selector (Selector : in out Selector_Type) is
begin
-- Nothing to do if selector already in closed state
if Selector.Is_Null or else not Is_Open (Selector) then
return;
end if;
-- Close the signalling file descriptors used internally for the
-- implementation of Abort_Selector.
Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
-- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
-- (erroneous) subsequent attempt to use this selector properly fails.
Selector.R_Sig_Socket := No_Socket;
Selector.W_Sig_Socket := No_Socket;
end Close_Selector;
------------------
-- Close_Socket --
------------------
procedure Close_Socket (Socket : Socket_Type) is
Res : C.int;
begin
Res := C_Close (C.int (Socket));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Close_Socket;
--------------------
-- Connect_Socket --
--------------------
function Connect_Socket
(Socket : Socket_Type;
Server : Sock_Addr_Type) return C.int
is
Sin : aliased Sockaddr;
Len : C.int;
begin
Set_Address (Sin'Unchecked_Access, Server, Len);
return C_Connect (C.int (Socket), Sin'Address, Len);
end Connect_Socket;
procedure Connect_Socket
(Socket : Socket_Type;
Server : Sock_Addr_Type)
is
begin
if Connect_Socket (Socket, Server) = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Connect_Socket;
procedure Connect_Socket
(Socket : Socket_Type;
Server : Sock_Addr_Type;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status)
is
Req : Request_Type;
-- Used to set Socket to non-blocking I/O
Conn_Err : aliased Integer;
-- Error status of the socket after completion of select(2)
Res : C.int;
Conn_Err_Size : aliased C.int := Conn_Err'Size / 8;
-- For getsockopt(2) call
begin
if Selector /= null and then not Is_Open (Selector.all) then
raise Program_Error with "closed selector";
end if;
-- Set the socket to non-blocking I/O
Req := (Name => Non_Blocking_IO, Enabled => True);
Control_Socket (Socket, Request => Req);
-- Start operation (non-blocking), will return Failure with errno set
-- to EINPROGRESS.
Res := Connect_Socket (Socket, Server);
if Res = Failure then
Conn_Err := Socket_Errno;
if Conn_Err /= SOSC.EINPROGRESS then
Raise_Socket_Error (Conn_Err);
end if;
end if;
-- Wait for socket to become available for writing (unless the Timeout
-- is zero, in which case we consider that it has already expired, and
-- we do not need to wait at all).
if Timeout = 0.0 then
Status := Expired;
else
Wait_On_Socket
(Socket => Socket,
Event => Poll.Output_Event,
Timeout => Timeout,
Selector => Selector,
Status => Status);
end if;
-- Check error condition (the asynchronous connect may have terminated
-- with an error, e.g. ECONNREFUSED) if select(2) completed.
if Status = Completed then
Res := C_Getsockopt
(C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR,
Conn_Err'Address, Conn_Err_Size'Access);
if Res /= 0 then
Conn_Err := Socket_Errno;
end if;
else
Conn_Err := 0;
end if;
-- Reset the socket to blocking I/O
Req := (Name => Non_Blocking_IO, Enabled => False);
Control_Socket (Socket, Request => Req);
-- Report error condition if any
if Conn_Err /= 0 then
Raise_Socket_Error (Conn_Err);
end if;
end Connect_Socket;
--------------------
-- Control_Socket --
--------------------
procedure Control_Socket
(Socket : Socket_Type;
Request : in out Request_Type)
is
Arg : aliased C.int;
Res : C.int;
begin
case Request.Name is
when Non_Blocking_IO =>
Arg := C.int (Boolean'Pos (Request.Enabled));
when N_Bytes_To_Read =>
null;
end case;
Res := Socket_Ioctl
(C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
case Request.Name is
when Non_Blocking_IO =>
null;
when N_Bytes_To_Read =>
Request.Size := Natural (Arg);
end case;
end Control_Socket;
----------
-- Copy --
----------
procedure Copy
(Source : Socket_Set_Type;
Target : out Socket_Set_Type)
is
begin
Target := Source;
end Copy;
---------------------
-- Create_Selector --
---------------------
procedure Create_Selector (Selector : out Selector_Type) is
Two_Fds : aliased Fd_Pair;
Res : C.int;
begin
if Is_Open (Selector) then
-- Raise exception to prevent socket descriptor leak
raise Program_Error with "selector already open";
end if;
-- We open two signalling file descriptors. One of them is used to send
-- data to the other, which is included in a C_Select socket set. The
-- communication is used to force a call to C_Select to complete, and
-- the waiting task to resume its execution.
Res := Signalling_Fds.Create (Two_Fds'Access);
pragma Annotate (CodePeer, Modified, Two_Fds);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
end Create_Selector;
-------------------
-- Create_Socket --
-------------------
procedure Create_Socket
(Socket : out Socket_Type;
Family : Family_Type := Family_Inet;
Mode : Mode_Type := Socket_Stream;
Level : Level_Type := IP_Protocol_For_IP_Level)
is
Res : C.int;
begin
Res := C_Socket (Families (Family), Modes (Mode), Levels (Level));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Socket := Socket_Type (Res);
end Create_Socket;
------------------------
-- Create_Socket_Pair --
------------------------
procedure Create_Socket_Pair
(Left : out Socket_Type;
Right : out Socket_Type;
Family : Family_Type := Family_Unspec;
Mode : Mode_Type := Socket_Stream;
Level : Level_Type := IP_Protocol_For_IP_Level)
is
Res : C.int;
Pair : aliased Thin_Common.Fd_Pair;
begin
Res := C_Socketpair
((if Family = Family_Unspec then Default_Socket_Pair_Family
else Families (Family)),
Modes (Mode), Levels (Level), Pair'Access);
pragma Annotate (CodePeer, Modified, Pair);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Left := Socket_Type (Pair (Pair'First));
Right := Socket_Type (Pair (Pair'Last));
end Create_Socket_Pair;
-----------
-- Empty --
-----------
procedure Empty (Item : out Socket_Set_Type) is
begin
Reset_Socket_Set (Item.Set'Access);
Item.Last := No_Socket;
end Empty;
--------------------
-- Err_Code_Image --
--------------------
function Err_Code_Image (E : Integer) return String is
Msg : String := E'Img & "] ";
begin
Msg (Msg'First) := '[';
return Msg;
end Err_Code_Image;
--------------
-- Finalize --
--------------
procedure Finalize (X : in out Sockets_Library_Controller) is
pragma Unreferenced (X);
begin
-- Finalization operation for the GNAT.Sockets package
Thin.Finalize;
end Finalize;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
-- This is a dummy placeholder for an obsolete API.
-- The real finalization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Finalize;
---------
-- Get --
---------
procedure Get
(Item : in out Socket_Set_Type;
Socket : out Socket_Type)
is
S : aliased C.int;
L : aliased C.int := C.int (Item.Last);
begin
if Item.Last /= No_Socket then
Get_Socket_From_Set
(Item.Set'Access, Last => L'Access, Socket => S'Access);
pragma Annotate (CodePeer, Modified, L);
pragma Annotate (CodePeer, Modified, S);
Item.Last := Socket_Type (L);
Socket := Socket_Type (S);
else
Socket := No_Socket;
end if;
end Get;
-----------------
-- Get_Address --
-----------------
function Get_Address
(Stream : not null Stream_Access) return Sock_Addr_Type
is
begin
if Stream.all in Datagram_Socket_Stream_Type then
return Datagram_Socket_Stream_Type (Stream.all).From;
else
return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
end if;
end Get_Address;
---------------------
-- Raise_GAI_Error --
---------------------
procedure Raise_GAI_Error (RC : C.int; Name : String) is
begin
if RC = SOSC.EAI_SYSTEM then
declare
Errcode : constant Integer := Socket_Errno;
begin
raise Host_Error with Err_Code_Image (Errcode)
& Dedot (Socket_Error_Message (Errcode)) & ": " & Name;
end;
else
raise Host_Error with Err_Code_Image (Integer (RC))
& Dedot (CS.Value (C_GAI_Strerror (RC))) & ": " & Name;
end if;
end Raise_GAI_Error;
----------------------
-- Get_Address_Info --
----------------------
function Get_Address_Info
(Host : String;
Service : String;
Family : Family_Type := Family_Unspec;
Mode : Mode_Type := Socket_Stream;
Level : Level_Type := IP_Protocol_For_IP_Level;
Numeric_Host : Boolean := False;
Passive : Boolean := False;
Unknown : access procedure
(Family, Mode, Level, Length : Integer) := null)
return Address_Info_Array
is
A : aliased Addrinfo_Access;
N : aliased C.char_array := C.To_C (Host);
S : aliased C.char_array := C.To_C (if Service = "" then "0"
else Service);
Hints : aliased constant Addrinfo :=
(ai_family => Families (Family),
ai_socktype => Modes (Mode),
ai_protocol => Levels (Level),
ai_flags => (if Numeric_Host then SOSC.AI_NUMERICHOST else 0) +
(if Passive then SOSC.AI_PASSIVE else 0),
ai_addrlen => 0,
others => <>);
R : C.int;
Iter : Addrinfo_Access;
Found : Boolean;
function To_Array return Address_Info_Array;
-- Convert taken from OS addrinfo list A into Address_Info_Array
--------------
-- To_Array --
--------------
function To_Array return Address_Info_Array is
Result : Address_Info_Array (1 .. 8);
procedure Unsupported;
-- Calls Unknown callback if defiend
-----------------
-- Unsupported --
-----------------
procedure Unsupported is
begin
if Unknown /= null then
Unknown
(Integer (Iter.ai_family),
Integer (Iter.ai_socktype),
Integer (Iter.ai_protocol),
Integer (Iter.ai_addrlen));
end if;
end Unsupported;
-- Start of processing for To_Array
begin
for J in Result'Range loop
Look_For_Supported : loop
if Iter = null then
pragma Warnings
(Off, "may be referenced before it has a value");
return Result (1 .. J - 1);
pragma Warnings
(On, "may be referenced before it has a value");
end if;
Result (J).Addr :=
Get_Address (Iter.ai_addr.all, C.int (Iter.ai_addrlen));
if Result (J).Addr.Family = Family_Unspec then
Unsupported;
else
for M in Modes'Range loop
Found := False;
if Modes (M) = Iter.ai_socktype then
Result (J).Mode := M;
Found := True;
exit;
end if;
end loop;
if Found then
for L in Levels'Range loop
if Levels (L) = Iter.ai_protocol then
Result (J).Level := L;
exit;
end if;
end loop;
exit Look_For_Supported;
else
Unsupported;
end if;
end if;
Iter := Iter.ai_next;
end loop Look_For_Supported;
Iter := Iter.ai_next;
end loop;
return Result & To_Array;
end To_Array;
-- Start of processing for Get_Address_Info
begin
R := C_Getaddrinfo
(Node => (if Host = "" then null else N'Unchecked_Access),
Service => S'Unchecked_Access,
Hints => Hints'Unchecked_Access,
Res => A'Access);
if R /= 0 then
Raise_GAI_Error
(R, Host & (if Service = "" then "" else ':' & Service));
end if;
Iter := A;
return Result : constant Address_Info_Array := To_Array do
C_Freeaddrinfo (A);
end return;
end Get_Address_Info;
----------
-- Sort --
----------
procedure Sort
(Addr_Info : in out Address_Info_Array;
Compare : access function (Left, Right : Address_Info) return Boolean)
is
function Comp (Left, Right : Address_Info) return Boolean is
(Compare (Left, Right));
procedure Sorter is new Ada.Containers.Generic_Array_Sort
(Positive, Address_Info, Address_Info_Array, Comp);
begin
Sorter (Addr_Info);
end Sort;
------------------------
-- IPv6_TCP_Preferred --
------------------------
function IPv6_TCP_Preferred (Left, Right : Address_Info) return Boolean is
begin
pragma Assert (Family_Inet < Family_Inet6);
-- To be sure that Family_Type enumeration has appropriate elements
-- order
if Left.Addr.Family /= Right.Addr.Family then
return Left.Addr.Family > Right.Addr.Family;
end if;
pragma Assert (Socket_Stream < Socket_Datagram);
-- To be sure that Mode_Type enumeration has appropriate elements order
return Left.Mode < Right.Mode;
end IPv6_TCP_Preferred;
-------------------
-- Get_Name_Info --
-------------------
function Get_Name_Info
(Addr : Sock_Addr_Type;
Numeric_Host : Boolean := False;
Numeric_Serv : Boolean := False) return Host_Service
is
SA : aliased Sockaddr;
H : aliased C.char_array := [1 .. SOSC.NI_MAXHOST => C.nul];
S : aliased C.char_array := [1 .. SOSC.NI_MAXSERV => C.nul];
RC : C.int;
Len : C.int;
begin
Set_Address (SA'Unchecked_Access, Addr, Len);
RC := C_Getnameinfo
(SA'Unchecked_Access, socklen_t (Len),
H'Unchecked_Access, H'Length,
S'Unchecked_Access, S'Length,
(if Numeric_Host then SOSC.NI_NUMERICHOST else 0) +
(if Numeric_Serv then SOSC.NI_NUMERICSERV else 0));
if RC /= 0 then
Raise_GAI_Error (RC, Image (Addr));
end if;
declare
HR : constant String := C.To_Ada (H);
SR : constant String := C.To_Ada (S);
begin
return (HR'Length, SR'Length, HR, SR);
end;
end Get_Name_Info;
-------------------------
-- Get_Host_By_Address --
-------------------------
function Get_Host_By_Address
(Address : Inet_Addr_Type;
Family : Family_Type := Family_Inet) return Host_Entry_Type
is
pragma Unreferenced (Family);
HA : aliased In_Addr_Union (Address.Family);
Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
begin
case Address.Family is
when Family_Inet =>
HA.In4 := To_In_Addr (Address);
when Family_Inet6 =>
HA.In6 := To_In6_Addr (Address);
end case;
Netdb_Lock;
if C_Gethostbyaddr
(HA'Address,
(case Address.Family is
when Family_Inet => HA.In4'Size,
when Family_Inet6 => HA.In6'Size) / 8,
Families (Address.Family),
Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Netdb_Unlock;
Raise_Host_Error (Integer (Err), Image (Address));
end if;
begin
return H : constant Host_Entry_Type :=
To_Host_Entry (Res'Unchecked_Access)
do
Netdb_Unlock;
end return;
exception
when others =>
Netdb_Unlock;
raise;
end;
end Get_Host_By_Address;
----------------------
-- Get_Host_By_Name --
----------------------
function Get_Host_By_Name (Name : String) return Host_Entry_Type is
begin
-- If the given name actually is the string representation of
-- an IP address, use Get_Host_By_Address instead.
if Is_IPv4_Address (Name) or else Is_IPv6_Address (Name) then
return Get_Host_By_Address (Inet_Addr (Name));
end if;
declare
HN : constant C.char_array := C.To_C (Name);
Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Hostent;
Err : aliased C.int;
begin
Netdb_Lock;
if C_Gethostbyname
(HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Netdb_Unlock;
Raise_Host_Error (Integer (Err), Name);
end if;
return H : constant Host_Entry_Type :=
To_Host_Entry (Res'Unchecked_Access)
do
Netdb_Unlock;
end return;
end;
end Get_Host_By_Name;
-------------------
-- Get_Peer_Name --
-------------------
function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
Sin : aliased Sockaddr;
Len : aliased C.int := Sin'Size / 8;
begin
if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
return Get_Address (Sin, Len);
end Get_Peer_Name;
-------------------------
-- Get_Service_By_Name --
-------------------------
function Get_Service_By_Name
(Name : String;
Protocol : String) return Service_Entry_Type
is
SN : constant C.char_array := C.To_C (Name);
SP : constant C.char_array := C.To_C (Protocol);
Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
begin
Netdb_Lock;
if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
Netdb_Unlock;
raise Service_Error with "Service not found";
end if;
-- Translate from the C format to the API format
return S : constant Service_Entry_Type :=
To_Service_Entry (Res'Unchecked_Access)
do
Netdb_Unlock;
end return;
end Get_Service_By_Name;
-------------------------
-- Get_Service_By_Port --
-------------------------
function Get_Service_By_Port
(Port : Port_Type;
Protocol : String) return Service_Entry_Type
is
SP : constant C.char_array := C.To_C (Protocol);
Buflen : constant C.size_t := Netdb_Buffer_Size;
Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
Res : aliased Servent;
begin
Netdb_Lock;
if C_Getservbyport
(C.int (Short_To_Network (C.unsigned_short (Port))), SP,
Res'Access, Buf'Address, Buflen) /= 0
then
Netdb_Unlock;
raise Service_Error with "Service not found";
end if;
-- Translate from the C format to the API format
return S : constant Service_Entry_Type :=
To_Service_Entry (Res'Unchecked_Access)
do
Netdb_Unlock;
end return;
end Get_Service_By_Port;
---------------------
-- Get_Socket_Name --
---------------------
function Get_Socket_Name
(Socket : Socket_Type) return Sock_Addr_Type
is
Sin : aliased Sockaddr;
Len : aliased C.int := Sin'Size / 8;
Res : C.int;
begin
Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
if Res = Failure then
return No_Sock_Addr;
end if;
return Get_Address (Sin, Len);
end Get_Socket_Name;
-----------------------
-- Get_Socket_Option --
-----------------------
function Get_Socket_Option
(Socket : Socket_Type;
Level : Level_Type;
Name : Option_Name;
Optname : Interfaces.C.int := -1) return Option_Type
is
use type C.unsigned;
use type C.unsigned_char;
V8 : aliased Two_Ints;
V4 : aliased C.int;
U4 : aliased C.unsigned;
V1 : aliased C.unsigned_char;
VT : aliased Timeval;
Len : aliased C.int;
Add : System.Address;
Res : C.int;
Opt : Option_Type (Name);
Onm : Interfaces.C.int;
begin
if Name in Specific_Option_Name then
Onm := Options (Name);
elsif Optname = -1 then
raise Socket_Error with "optname must be specified";
else
Onm := Optname;
end if;
case Name is
when Multicast_TTL
| Receive_Packet_Info
=>
Len := V1'Size / 8;
Add := V1'Address;
when Broadcast
| Busy_Polling
| Error
| Generic_Option
| Keep_Alive
| Keep_Alive_Count
| Keep_Alive_Idle
| Keep_Alive_Interval
| Multicast_If_V4
| Multicast_If_V6
| Multicast_Loop_V4
| Multicast_Loop_V6
| Multicast_Hops
| No_Delay
| Receive_Buffer
| Reuse_Address
| Send_Buffer
| IPv6_Only
=>
Len := V4'Size / 8;
Add := V4'Address;
when Receive_Timeout
| Send_Timeout
=>
-- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
-- struct timeval, but on Windows it is a milliseconds count in
-- a DWORD.
if Is_Windows then
Len := U4'Size / 8;
Add := U4'Address;
else
Len := VT'Size / 8;
Add := VT'Address;
end if;
when Add_Membership_V4
| Add_Membership_V6
| Drop_Membership_V4
| Drop_Membership_V6
=>
raise Socket_Error with
"Add/Drop membership valid only for Set_Socket_Option";
when Linger
=>
Len := V8'Size / 8;
Add := V8'Address;
end case;
Res :=
C_Getsockopt
(C.int (Socket),
Levels (Level),
Onm,
Add, Len'Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
case Name is
when Generic_Option =>
Opt.Optname := Onm;
Opt.Optval := V4;
when Broadcast
| Keep_Alive
| No_Delay
| Reuse_Address
| Multicast_Loop_V4
| Multicast_Loop_V6
| IPv6_Only
=>
Opt.Enabled := (V4 /= 0);
when Keep_Alive_Count =>
Opt.Count := Natural (V4);
when Keep_Alive_Idle =>
Opt.Idle_Seconds := Natural (V4);
when Keep_Alive_Interval =>
Opt.Interval_Seconds := Natural (V4);
when Busy_Polling =>
Opt.Microseconds := Natural (V4);
when Linger =>
Opt.Enabled := (V8 (V8'First) /= 0);
Opt.Seconds := Natural (V8 (V8'Last));
when Receive_Buffer
| Send_Buffer
=>
Opt.Size := Natural (V4);
when Error =>
Opt.Error := Resolve_Error (Integer (V4));
when Add_Membership_V4
| Add_Membership_V6
| Drop_Membership_V4
| Drop_Membership_V6
=>
-- No way to be here. Exception raised in the first case Name
-- expression.
null;
when Multicast_If_V4 =>
To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
when Multicast_If_V6 =>
Opt.Outgoing_If_Index := Natural (V4);
when Multicast_TTL =>
Opt.Time_To_Live := Integer (V1);
when Multicast_Hops =>
Opt.Hop_Limit := Integer (V4);
when Receive_Packet_Info
=>
Opt.Enabled := (V1 /= 0);
when Receive_Timeout
| Send_Timeout
=>
if Is_Windows then
if U4 = 0 then
Opt.Timeout := 0.0;
else
if Minus_500ms_Windows_Timeout then
-- Timeout is in milliseconds, actual value is 500 ms +
-- returned value (unless it is 0).
U4 := U4 + 500;
end if;
Opt.Timeout := Duration (U4) / 1000;
end if;
else
Opt.Timeout := To_Duration (VT);
end if;
end case;
return Opt;
end Get_Socket_Option;
---------------
-- Host_Name --
---------------
function Host_Name return String is
Name : aliased C.char_array (1 .. 64);
Res : C.int;
begin
Res := C_Gethostname (Name'Address, Name'Length);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
return C.To_Ada (Name);
end Host_Name;
-----------
-- Image --
-----------
function Image (Value : Inet_Addr_Type) return String is
use type CS.char_array_access;
Size : constant socklen_t :=
(case Value.Family is
when Family_Inet => 4 * Value.Sin_V4'Length,
when Family_Inet6 => 6 * 5 + 4 * 4);
-- 1234:1234:1234:1234:1234:1234:123.123.123.123
Dst : aliased C.char_array := [1 .. C.size_t (Size) => C.nul];
Ia : aliased In_Addr_Union (Value.Family);
begin
case Value.Family is
when Family_Inet6 =>
Ia.In6 := To_In6_Addr (Value);
when Family_Inet =>
Ia.In4 := To_In_Addr (Value);
end case;
if Inet_Ntop
(Families (Value.Family), Ia'Address,
Dst'Unchecked_Access, Size) = null
then
Raise_Socket_Error (Socket_Errno);
end if;
return C.To_Ada (Dst);
end Image;
-----------
-- Image --
-----------
function Image (Value : Sock_Addr_Type) return String is
function Ipv6_Brackets (S : String) return String is
(if Value.Family = Family_Inet6 then "[" & S & "]" else S);
begin
case Value.Family is
when Family_Unix =>
if ASU.Length (Value.Name) > 0
and then ASU.Element (Value.Name, 1) = ASCII.NUL
then
return '@' & ASU.Slice (Value.Name, 2, ASU.Length (Value.Name));
else
return ASU.To_String (Value.Name);
end if;
when Family_Inet_4_6 =>
declare
Port : constant String := Value.Port'Img;
begin
return Ipv6_Brackets (Image (Value.Addr)) & ':'
& Port (2 .. Port'Last);
end;
when Family_Unspec =>
return "";
end case;
end Image;
-----------
-- Image --
-----------
function Image (Socket : Socket_Type) return String is
begin
return Socket'Img;
end Image;
-----------
-- Image --
-----------
function Image (Item : Socket_Set_Type) return String is
Socket_Set : Socket_Set_Type := Item;
begin
declare
Last_Img : constant String := Socket_Set.Last'Img;
Buffer : String
(1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
Index : Positive := 1;
Socket : Socket_Type;
begin
while not Is_Empty (Socket_Set) loop
Get (Socket_Set, Socket);
declare
Socket_Img : constant String := Socket'Img;
begin
Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
Index := Index + Socket_Img'Length;
end;
end loop;
return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
end;
end Image;
---------------
-- Inet_Addr --
---------------
function Inet_Addr (Image : String) return Inet_Addr_Type is
use Interfaces.C;
Img : aliased char_array := To_C (Image);
Res : C.int;
Result : Inet_Addr_Type;
IPv6 : constant Boolean := Is_IPv6_Address (Image);
Ia : aliased In_Addr_Union
(if IPv6 then Family_Inet6 else Family_Inet);
begin
-- Special case for an empty Image as on some platforms (e.g. Windows)
-- calling Inet_Addr("") will not return an error.
if Image = "" then
Raise_Socket_Error (SOSC.EINVAL);
end if;
Res := Inet_Pton
((if IPv6 then SOSC.AF_INET6 else SOSC.AF_INET), Img'Address,
Ia'Address);
if Res < 0 then
Raise_Socket_Error (Socket_Errno);
elsif Res = 0 then
Raise_Socket_Error (SOSC.EINVAL);
end if;
if IPv6 then
To_Inet_Addr (Ia.In6, Result);
else
To_Inet_Addr (Ia.In4, Result);
end if;
return Result;
end Inet_Addr;
----------------
-- Initialize --
----------------
procedure Initialize (X : in out Sockets_Library_Controller) is
pragma Unreferenced (X);
begin
Thin.Initialize;
end Initialize;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean) is
Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
begin
if Process_Blocking_IO /= Expected then
raise Socket_Error with
"incorrect Process_Blocking_IO setting, expected " & Expected'Img;
end if;
-- This is a dummy placeholder for an obsolete API
-- Real initialization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Initialize;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
-- This is a dummy placeholder for an obsolete API
-- Real initialization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Initialize;
----------------
-- Is_Windows --
----------------
function Is_Windows return Boolean is
use SOSC;
begin
return Target_OS = Windows;
end Is_Windows;
--------------
-- Is_Empty --
--------------
function Is_Empty (Item : Socket_Set_Type) return Boolean is
begin
return Item.Last = No_Socket;
end Is_Empty;
---------------------
-- Is_IPv6_Address --
---------------------
function Is_IPv6_Address (Name : String) return Boolean is
Prev_Colon : Natural := 0;
Double_Colon : Boolean := False;
Colons : Natural := 0;
begin
for J in Name'Range loop
if Name (J) = ':' then
Colons := Colons + 1;
if Prev_Colon > 0 and then J = Prev_Colon + 1 then
if Double_Colon then
-- Only one double colon allowed
return False;
end if;
Double_Colon := True;
elsif J = Name'Last then
-- Single colon at the end is not allowed
return False;
end if;
Prev_Colon := J;
elsif Prev_Colon = Name'First then
-- Single colon at start is not allowed
return False;
elsif Name (J) = '.' then
return Prev_Colon > 0
and then Is_IPv4_Address (Name (Prev_Colon + 1 .. Name'Last));
elsif Name (J) not in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' then
return False;
end if;
end loop;
return Colons in 2 .. 8;
end Is_IPv6_Address;
---------------------
-- Is_IPv4_Address --
---------------------
function Is_IPv4_Address (Name : String) return Boolean is
Dots : Natural := 0;
begin
-- Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
-- and there must be at least one digit around each.
for J in Name'Range loop
if Name (J) = '.' then
-- Check that the dot is not in first or last position, and that
-- it is followed by a digit. Note that we already know that it is
-- preceded by a digit, or we would have returned earlier on.
if J in Name'First + 1 .. Name'Last - 1
and then Name (J + 1) in '0' .. '9'
then
Dots := Dots + 1;
-- Definitely not a proper dotted quad
else
return False;
end if;
elsif Name (J) not in '0' .. '9' then
return False;
end if;
end loop;
return Dots in 1 .. 3;
end Is_IPv4_Address;
-------------
-- Is_Open --
-------------
function Is_Open (S : Selector_Type) return Boolean is
begin
if S.Is_Null then
return True;
else
-- Either both controlling socket descriptors are valid (case of an
-- open selector) or neither (case of a closed selector).
pragma Assert ((S.R_Sig_Socket /= No_Socket)
=
(S.W_Sig_Socket /= No_Socket));
return S.R_Sig_Socket /= No_Socket;
end if;
end Is_Open;
------------
-- Is_Set --
------------
function Is_Set
(Item : Socket_Set_Type;
Socket : Socket_Type) return Boolean
is
begin
Check_For_Fd_Set (Socket);
return Item.Last /= No_Socket
and then Socket <= Item.Last
and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
end Is_Set;
-------------------
-- Listen_Socket --
-------------------
procedure Listen_Socket
(Socket : Socket_Type;
Length : Natural := 15)
is
Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
begin
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Listen_Socket;
------------
-- Narrow --
------------
procedure Narrow (Item : in out Socket_Set_Type) is
Last : aliased C.int := C.int (Item.Last);
begin
if Item.Last /= No_Socket then
Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
Item.Last := Socket_Type (Last);
end if;
end Narrow;
----------------
-- Netdb_Lock --
----------------
procedure Netdb_Lock is
begin
if Need_Netdb_Lock then
System.Task_Lock.Lock;
end if;
end Netdb_Lock;
------------------
-- Netdb_Unlock --
------------------
procedure Netdb_Unlock is
begin
if Need_Netdb_Lock then
System.Task_Lock.Unlock;
end if;
end Netdb_Unlock;
----------------------------
-- Network_Socket_Address --
----------------------------
function Network_Socket_Address
(Addr : Inet_Addr_Type; Port : Port_Type) return Sock_Addr_Type is
begin
return Result : Sock_Addr_Type (Addr.Family) do
Result.Addr := Addr;
Result.Port := Port;
end return;
end Network_Socket_Address;
--------------------------------
-- Normalize_Empty_Socket_Set --
--------------------------------
procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
begin
if S.Last = No_Socket then
Reset_Socket_Set (S.Set'Access);
end if;
end Normalize_Empty_Socket_Set;
-------------------
-- Official_Name --
-------------------
function Official_Name (E : Host_Entry_Type) return String is
begin
return To_String (E.Official);
end Official_Name;
-------------------
-- Official_Name --
-------------------
function Official_Name (S : Service_Entry_Type) return String is
begin
return To_String (S.Official);
end Official_Name;
--------------------
-- Wait_On_Socket --
--------------------
procedure Wait_On_Socket
(Socket : Socket_Type;
Event : Poll.Wait_Event_Set;
Timeout : Selector_Duration;
Selector : access Selector_Type := null;
Status : out Selector_Status)
is
Fd_Set : Poll.Set := Poll.To_Set (Socket, Event, 2);
-- Socket itself and second place for signaling socket if necessary
Count : Natural;
Index : Natural := 0;
begin
-- Add signaling socket if selector defined
if Selector /= null then
Poll.Append (Fd_Set, Selector.R_Sig_Socket, Poll.Input_Event);
end if;
Poll.Wait (Fd_Set, Timeout, Count);
if Count = 0 then
Status := Expired;
else
Poll.Next (Fd_Set, Index);
Status := (if Index = 1 then Completed else Aborted);
end if;
end Wait_On_Socket;
-----------------
-- Port_Number --
-----------------
function Port_Number (S : Service_Entry_Type) return Port_Type is
begin
return S.Port;
end Port_Number;
-------------------
-- Protocol_Name --
-------------------
function Protocol_Name (S : Service_Entry_Type) return String is
begin
return To_String (S.Protocol);
end Protocol_Name;
----------------------
-- Raise_Host_Error --
----------------------
procedure Raise_Host_Error (H_Error : Integer; Name : String) is
begin
raise Host_Error with
Err_Code_Image (H_Error)
& Dedot (Host_Error_Messages.Host_Error_Message (H_Error))
& ": " & Name;
end Raise_Host_Error;
------------------------
-- Raise_Socket_Error --
------------------------
procedure Raise_Socket_Error (Error : Integer) is
begin
raise Socket_Error with
Err_Code_Image (Error) & Socket_Error_Message (Error);
end Raise_Socket_Error;
----------
-- Read --
----------
procedure Read
(Stream : in out Datagram_Socket_Stream_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset)
is
begin
Receive_Socket
(Stream.Socket,
Item,
Last,
Stream.From);
end Read;
----------
-- Read --
----------
procedure Read
(Stream : in out Stream_Socket_Stream_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset)
is
First : Ada.Streams.Stream_Element_Offset := Item'First;
Index : Ada.Streams.Stream_Element_Offset := First - 1;
Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
begin
loop
Receive_Socket (Stream.Socket, Item (First .. Max), Index);
Last := Index;
-- Exit when all or zero data received. Zero means that the socket
-- peer is closed.
exit when Index < First or else Index = Max;
First := Index + 1;
end loop;
end Read;
--------------------
-- Receive_Socket --
--------------------
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : C.int;
begin
Res :=
C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Last := Last_Index (First => Item'First, Count => size_t (Res));
end Receive_Socket;
--------------------
-- Receive_Socket --
--------------------
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
From : out Sock_Addr_Type;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : C.int;
Sin : aliased Sockaddr;
Len : aliased C.int := Sin'Size / 8;
begin
Res :=
C_Recvfrom
(C.int (Socket),
Item'Address,
Item'Length,
To_Int (Flags),
Sin'Address,
Len'Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Last := Last_Index (First => Item'First, Count => size_t (Res));
From := Get_Address (Sin, Len);
end Receive_Socket;
--------------------
-- Receive_Vector --
--------------------
procedure Receive_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : ssize_t;
Msg : Msghdr :=
(Msg_Name => System.Null_Address,
Msg_Namelen => 0,
Msg_Iov => Vector'Address,
-- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
-- platforms) when the supplied vector is longer than IOV_MAX,
-- so use minimum of the two lengths.
Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
(Vector'Length, SOSC.IOV_MAX),
Msg_Control => System.Null_Address,
Msg_Controllen => 0,
Msg_Flags => 0);
begin
Res :=
C_Recvmsg
(C.int (Socket),
Msg'Address,
To_Int (Flags));
if Res = ssize_t (Failure) then
Raise_Socket_Error (Socket_Errno);
end if;
Count := Ada.Streams.Stream_Element_Count (Res);
end Receive_Vector;
-------------------
-- Resolve_Error --
-------------------
function Resolve_Error
(Error_Value : Integer;
From_Errno : Boolean := True) return Error_Type
is
use GNAT.Sockets.SOSC;
begin
if not From_Errno then
case Error_Value is
when SOSC.HOST_NOT_FOUND => return Unknown_Host;
when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
when SOSC.NO_DATA => return Unknown_Server_Error;
when others => return Cannot_Resolve_Error;
end case;
end if;
-- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
-- can't include it in the case statement below.
pragma Warnings (Off);
-- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
return Resource_Temporarily_Unavailable;
end if;
-- This is not a case statement because if a particular error
-- number constant is not defined, s-oscons-tmplt.c defines
-- it to -1. If multiple constants are not defined, they
-- would each be -1 and result in a "duplicate value in case" error.
--
-- But we have to leave warnings off because the compiler is also
-- smart enough to note that when two errnos have the same value,
-- the second if condition is useless.
if Error_Value = ENOERROR then
return Success;
elsif Error_Value = EACCES then
return Permission_Denied;
elsif Error_Value = EADDRINUSE then
return Address_Already_In_Use;
elsif Error_Value = EADDRNOTAVAIL then
return Cannot_Assign_Requested_Address;
elsif Error_Value = EAFNOSUPPORT then
return Address_Family_Not_Supported_By_Protocol;
elsif Error_Value = EALREADY then
return Operation_Already_In_Progress;
elsif Error_Value = EBADF then
return Bad_File_Descriptor;
elsif Error_Value = ECONNABORTED then
return Software_Caused_Connection_Abort;
elsif Error_Value = ECONNREFUSED then
return Connection_Refused;
elsif Error_Value = ECONNRESET then
return Connection_Reset_By_Peer;
elsif Error_Value = EDESTADDRREQ then
return Destination_Address_Required;
elsif Error_Value = EFAULT then
return Bad_Address;
elsif Error_Value = EHOSTDOWN then
return Host_Is_Down;
elsif Error_Value = EHOSTUNREACH then
return No_Route_To_Host;
elsif Error_Value = EINPROGRESS then
return Operation_Now_In_Progress;
elsif Error_Value = EINTR then
return Interrupted_System_Call;
elsif Error_Value = EINVAL then
return Invalid_Argument;
elsif Error_Value = EIO then
return Input_Output_Error;
elsif Error_Value = EISCONN then
return Transport_Endpoint_Already_Connected;
elsif Error_Value = ELOOP then
return Too_Many_Symbolic_Links;
elsif Error_Value = EMFILE then
return Too_Many_Open_Files;
elsif Error_Value = EMSGSIZE then
return Message_Too_Long;
elsif Error_Value = ENAMETOOLONG then
return File_Name_Too_Long;
elsif Error_Value = ENETDOWN then
return Network_Is_Down;
elsif Error_Value = ENETRESET then
return Network_Dropped_Connection_Because_Of_Reset;
elsif Error_Value = ENETUNREACH then
return Network_Is_Unreachable;
elsif Error_Value = ENOBUFS then
return No_Buffer_Space_Available;
elsif Error_Value = ENOPROTOOPT then
return Protocol_Not_Available;
elsif Error_Value = ENOTCONN then
return Transport_Endpoint_Not_Connected;
elsif Error_Value = ENOTSOCK then
return Socket_Operation_On_Non_Socket;
elsif Error_Value = EOPNOTSUPP then
return Operation_Not_Supported;
elsif Error_Value = EPFNOSUPPORT then
return Protocol_Family_Not_Supported;
elsif Error_Value = EPIPE then
return Broken_Pipe;
elsif Error_Value = EPROTONOSUPPORT then
return Protocol_Not_Supported;
elsif Error_Value = EPROTOTYPE then
return Protocol_Wrong_Type_For_Socket;
elsif Error_Value = ESHUTDOWN then
return Cannot_Send_After_Transport_Endpoint_Shutdown;
elsif Error_Value = ESOCKTNOSUPPORT then
return Socket_Type_Not_Supported;
elsif Error_Value = ETIMEDOUT then
return Connection_Timed_Out;
elsif Error_Value = ETOOMANYREFS then
return Too_Many_References;
elsif Error_Value = EWOULDBLOCK then
return Resource_Temporarily_Unavailable;
else
return Cannot_Resolve_Error;
end if;
pragma Warnings (On);
end Resolve_Error;
-----------------------
-- Resolve_Exception --
-----------------------
function Resolve_Exception
(Occurrence : Exception_Occurrence) return Error_Type
is
Id : constant Exception_Id := Exception_Identity (Occurrence);
Msg : constant String := Exception_Message (Occurrence);
First : Natural;
Last : Natural;
Val : Integer;
begin
First := Msg'First;
while First <= Msg'Last
and then Msg (First) not in '0' .. '9'
loop
First := First + 1;
end loop;
if First > Msg'Last then
return Cannot_Resolve_Error;
end if;
Last := First;
while Last < Msg'Last
and then Msg (Last + 1) in '0' .. '9'
loop
Last := Last + 1;
end loop;
Val := Integer'Value (Msg (First .. Last));
if Id = Socket_Error_Id then
return Resolve_Error (Val);
elsif Id = Host_Error_Id then
return Resolve_Error (Val, False);
else
return Cannot_Resolve_Error;
end if;
end Resolve_Exception;
-----------------
-- Send_Socket --
-----------------
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
Flags : Request_Flag_Type := No_Request_Flag)
is
begin
Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
end Send_Socket;
-----------------
-- Send_Socket --
-----------------
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
To : Sock_Addr_Type;
Flags : Request_Flag_Type := No_Request_Flag)
is
begin
Send_Socket
(Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
end Send_Socket;
-----------------
-- Send_Socket --
-----------------
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
To : access Sock_Addr_Type;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : C.int;
Sin : aliased Sockaddr;
C_To : System.Address;
Len : C.int;
begin
if To /= null then
Set_Address (Sin'Unchecked_Access, To.all, Len);
C_To := Sin'Address;
else
C_To := System.Null_Address;
Len := 0;
end if;
Res := C_Sendto
(C.int (Socket),
Item'Address,
Item'Length,
Set_Forced_Flags (To_Int (Flags)),
C_To,
Len);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Last := Last_Index (First => Item'First, Count => size_t (Res));
end Send_Socket;
-----------------
-- Send_Vector --
-----------------
procedure Send_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag)
is
use Interfaces.C;
Res : ssize_t;
Iov_Count : SOSC.Msg_Iovlen_T;
This_Iov_Count : SOSC.Msg_Iovlen_T;
Msg : Msghdr;
begin
Count := 0;
Iov_Count := 0;
while Iov_Count < Vector'Length loop
pragma Warnings (Off);
-- Following test may be compile time known on some targets
This_Iov_Count :=
(if Vector'Length - Iov_Count > SOSC.IOV_MAX
then SOSC.IOV_MAX
else Vector'Length - Iov_Count);
pragma Warnings (On);
Msg :=
(Msg_Name => System.Null_Address,
Msg_Namelen => 0,
Msg_Iov => Vector
(Vector'First + Integer (Iov_Count))'Address,
Msg_Iovlen => This_Iov_Count,
Msg_Control => System.Null_Address,
Msg_Controllen => 0,
Msg_Flags => 0);
Res :=
C_Sendmsg
(C.int (Socket),
Msg'Address,
Set_Forced_Flags (To_Int (Flags)));
if Res = ssize_t (Failure) then
Raise_Socket_Error (Socket_Errno);
end if;
Count := Count + Ada.Streams.Stream_Element_Count (Res);
Iov_Count := Iov_Count + This_Iov_Count;
end loop;
end Send_Vector;
---------
-- Set --
---------
procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
begin
Check_For_Fd_Set (Socket);
if Item.Last = No_Socket then
-- Uninitialized socket set, make sure it is properly zeroed out
Reset_Socket_Set (Item.Set'Access);
Item.Last := Socket;
elsif Item.Last < Socket then
Item.Last := Socket;
end if;
Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
end Set;
-----------------------
-- Set_Close_On_Exec --
-----------------------
procedure Set_Close_On_Exec
(Socket : Socket_Type;
Close_On_Exec : Boolean;
Status : out Boolean)
is
function C_Set_Close_On_Exec
(Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
begin
Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
end Set_Close_On_Exec;
----------------------
-- Set_Forced_Flags --
----------------------
function Set_Forced_Flags (F : C.int) return C.int is
use type C.unsigned;
function To_unsigned is
new Ada.Unchecked_Conversion (C.int, C.unsigned);
function To_int is
new Ada.Unchecked_Conversion (C.unsigned, C.int);
begin
return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
end Set_Forced_Flags;
-----------------------
-- Set_Socket_Option --
-----------------------
procedure Set_Socket_Option
(Socket : Socket_Type;
Level : Level_Type;
Option : Option_Type)
is
use type C.unsigned;
MR : aliased IPV6_Mreq;
V8 : aliased Two_Ints;
V4 : aliased C.int;
U4 : aliased C.unsigned;
V1 : aliased C.unsigned_char;
VT : aliased Timeval;
Len : C.int;
Add : System.Address := Null_Address;
Res : C.int;
Onm : C.int;
begin
case Option.Name is
when Generic_Option =>
V4 := Option.Optval;
Len := V4'Size / 8;
Add := V4'Address;
when Broadcast
| Keep_Alive
| No_Delay
| Reuse_Address
| Multicast_Loop_V4
| Multicast_Loop_V6
| IPv6_Only
=>
V4 := C.int (Boolean'Pos (Option.Enabled));
Len := V4'Size / 8;
Add := V4'Address;
when Keep_Alive_Count =>
V4 := C.int (Option.Count);
Len := V4'Size / 8;
Add := V4'Address;
when Keep_Alive_Idle =>
V4 := C.int (Option.Idle_Seconds);
Len := V4'Size / 8;
Add := V4'Address;
when Keep_Alive_Interval =>
V4 := C.int (Option.Interval_Seconds);
Len := V4'Size / 8;
Add := V4'Address;
when Busy_Polling =>
V4 := C.int (Option.Microseconds);
Len := V4'Size / 8;
Add := V4'Address;
when Linger =>
V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
V8 (V8'Last) := C.int (Option.Seconds);
Len := V8'Size / 8;
Add := V8'Address;
when Receive_Buffer
| Send_Buffer
=>
V4 := C.int (Option.Size);
Len := V4'Size / 8;
Add := V4'Address;
when Error =>
V4 := C.int (Boolean'Pos (True));
Len := V4'Size / 8;
Add := V4'Address;
when Add_Membership_V4
| Drop_Membership_V4
=>
V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
Len := V8'Size / 8;
Add := V8'Address;
when Add_Membership_V6
| Drop_Membership_V6 =>
MR.ipv6mr_multiaddr := To_In6_Addr (Option.Multicast_Address);
MR.ipv6mr_interface := C.unsigned (Option.Interface_Index);
Len := MR'Size / 8;
Add := MR'Address;
when Multicast_If_V4 =>
V4 := To_Int (To_In_Addr (Option.Outgoing_If));
Len := V4'Size / 8;
Add := V4'Address;
when Multicast_If_V6 =>
V4 := C.int (Option.Outgoing_If_Index);
Len := V4'Size / 8;
Add := V4'Address;
when Multicast_TTL =>
V1 := C.unsigned_char (Option.Time_To_Live);
Len := V1'Size / 8;
Add := V1'Address;
when Multicast_Hops =>
V4 := C.int (Option.Hop_Limit);
Len := V4'Size / 8;
Add := V4'Address;
when Receive_Packet_Info
=>
V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
Len := V1'Size / 8;
Add := V1'Address;
when Receive_Timeout
| Send_Timeout
=>
if Is_Windows then
-- On Windows, the timeout is a DWORD in milliseconds
Len := U4'Size / 8;
Add := U4'Address;
U4 := C.unsigned (Option.Timeout * 1000);
if Option.Timeout > 0.0 and then U4 = 0 then
-- Avoid round to zero. Zero timeout mean unlimited
U4 := 1;
end if;
-- Old windows versions actual timeout is 500 ms + the given
-- value (unless it is 0).
if Minus_500ms_Windows_Timeout then
if U4 > 500 then
U4 := U4 - 500;
elsif U4 > 0 then
U4 := 1;
end if;
end if;
else
VT := To_Timeval (Option.Timeout);
Len := VT'Size / 8;
Add := VT'Address;
end if;
end case;
if Option.Name in Specific_Option_Name then
Onm := Options (Option.Name);
elsif Option.Optname = -1 then
raise Socket_Error with "optname must be specified";
else
Onm := Option.Optname;
end if;
Res := C_Setsockopt
(C.int (Socket),
Levels (Level),
Onm,
Add, Len);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Set_Socket_Option;
---------------------
-- Shutdown_Socket --
---------------------
procedure Shutdown_Socket
(Socket : Socket_Type;
How : Shutmode_Type := Shut_Read_Write)
is
Res : C.int;
begin
Res := C_Shutdown (C.int (Socket), Shutmodes (How));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Shutdown_Socket;
------------
-- Stream --
------------
function Stream
(Socket : Socket_Type;
Send_To : Sock_Addr_Type) return Stream_Access
is
S : Datagram_Socket_Stream_Access;
begin
S := new Datagram_Socket_Stream_Type;
S.Socket := Socket;
S.To := Send_To;
S.From := Get_Socket_Name (Socket);
return Stream_Access (S);
end Stream;
------------
-- Stream --
------------
function Stream (Socket : Socket_Type) return Stream_Access is
S : Stream_Socket_Stream_Access;
begin
S := new Stream_Socket_Stream_Type;
S.Socket := Socket;
return Stream_Access (S);
end Stream;
------------
-- To_Ada --
------------
function To_Ada (Fd : Integer) return Socket_Type is
begin
return Socket_Type (Fd);
end To_Ada;
----------
-- To_C --
----------
function To_C (Socket : Socket_Type) return Integer is
begin
return Integer (Socket);
end To_C;
-----------------
-- To_Duration --
-----------------
function To_Duration (Val : Timeval) return Timeval_Duration is
Max_D : constant Long_Long_Integer := Long_Long_Integer (Forever - 0.5);
Tv_sec_64 : constant Boolean := SOSC.SIZEOF_tv_sec = 8;
-- Need to separate this condition into the constant declaration to
-- avoid GNAT warning about "always true" or "always false".
begin
if Tv_sec_64 then
-- Check for possible Duration overflow when Tv_Sec field is 64 bit
-- integer.
if Val.Tv_Sec > time_t (Max_D)
or else
(Val.Tv_Sec = time_t (Max_D)
and then
Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6))
then
return Forever;
end if;
end if;
return Duration (Val.Tv_Sec) + Duration (Val.Tv_Usec) * 1.0E-6;
end To_Duration;
-------------------
-- To_Host_Entry --
-------------------
function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
Aliases_Count, Addresses_Count : Natural;
Family : constant Family_Type :=
(case Hostent_H_Addrtype (E) is
when SOSC.AF_INET => Family_Inet,
when SOSC.AF_INET6 => Family_Inet6,
when others => Family_Unspec);
Addr_Len : constant C.size_t := C.size_t (Hostent_H_Length (E));
begin
if Family = Family_Unspec then
Raise_Socket_Error (SOSC.EPFNOSUPPORT);
end if;
Aliases_Count := 0;
while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
Aliases_Count := Aliases_Count + 1;
end loop;
Addresses_Count := 0;
while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
Addresses_Count := Addresses_Count + 1;
end loop;
return Result : Host_Entry_Type
(Aliases_Length => Aliases_Count,
Addresses_Length => Addresses_Count)
do
Result.Official := To_Name (Value (Hostent_H_Name (E)));
for J in Result.Aliases'Range loop
Result.Aliases (J) :=
To_Name (Value (Hostent_H_Alias
(E, C.int (J - Result.Aliases'First))));
end loop;
for J in Result.Addresses'Range loop
declare
Ia : In_Addr_Union (Family);
-- Hostent_H_Addr (E, <index>) may return an address that is
-- not correctly aligned for In_Addr, so we need to use
-- an intermediate copy operation on a type with an alignment
-- of 1 to recover the value.
subtype Addr_Buf_T is C.char_array (1 .. Addr_Len);
Unaligned_Addr : Addr_Buf_T;
for Unaligned_Addr'Address
use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
pragma Import (Ada, Unaligned_Addr);
Aligned_Addr : Addr_Buf_T;
for Aligned_Addr'Address use Ia'Address;
pragma Import (Ada, Aligned_Addr);
begin
Aligned_Addr := Unaligned_Addr;
if Family = Family_Inet6 then
To_Inet_Addr (Ia.In6, Result.Addresses (J));
else
To_Inet_Addr (Ia.In4, Result.Addresses (J));
end if;
end;
end loop;
end return;
end To_Host_Entry;
------------
-- To_Int --
------------
function To_Int (F : Request_Flag_Type) return C.int is
Current : Request_Flag_Type := F;
Result : C.int := 0;
begin
for J in Flags'Range loop
exit when Current = 0;
if Current mod 2 /= 0 then
if Flags (J) = -1 then
pragma Annotate
(CodePeer, False_Positive,
"test always false", "self fulfilling prophecy");
Raise_Socket_Error (SOSC.EOPNOTSUPP);
end if;
Result := Result + Flags (J);
end if;
Current := Current / 2;
end loop;
return Result;
end To_Int;
-------------
-- To_Name --
-------------
function To_Name (N : String) return Name_Type is
begin
return Name_Type'(N'Length, N);
end To_Name;
----------------------
-- To_Service_Entry --
----------------------
function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
Aliases_Count : Natural;
begin
Aliases_Count := 0;
while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
Aliases_Count := Aliases_Count + 1;
end loop;
return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
Result.Official := To_Name (Value (Servent_S_Name (E)));
for J in Result.Aliases'Range loop
Result.Aliases (J) :=
To_Name (Value (Servent_S_Alias
(E, C.int (J - Result.Aliases'First))));
end loop;
Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
Result.Port :=
Port_Type (Network_To_Short (Servent_S_Port (E)));
end return;
end To_Service_Entry;
---------------
-- To_String --
---------------
function To_String (HN : Name_Type) return String is
begin
return HN.Name (1 .. HN.Length);
end To_String;
----------------
-- To_Timeval --
----------------
function To_Timeval (Val : Timeval_Duration) return Timeval is
S : time_t;
uS : suseconds_t;
begin
-- If zero, set result as zero (otherwise it gets rounded down to -1)
if Val = 0.0 then
S := 0;
uS := 0;
-- Normal case where we do round down
else
S := time_t (Val - 0.5);
uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5);
if uS = -1 then
-- It happen on integer duration
uS := 0;
end if;
end if;
return (S, uS);
end To_Timeval;
-----------
-- Value --
-----------
function Value (S : System.Address) return String is
Str : String (1 .. Positive'Last);
for Str'Address use S;
pragma Import (Ada, Str);
Terminator : Positive := Str'First;
begin
while Str (Terminator) /= ASCII.NUL loop
Terminator := Terminator + 1;
end loop;
return Str (1 .. Terminator - 1);
end Value;
-----------
-- Write --
-----------
procedure Write
(Stream : in out Datagram_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array)
is
Last : Stream_Element_Offset;
begin
Send_Socket
(Stream.Socket,
Item,
Last,
Stream.To);
-- It is an error if not all of the data has been sent
if Last /= Item'Last then
Raise_Socket_Error (Socket_Errno);
end if;
end Write;
-----------
-- Write --
-----------
procedure Write
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array)
is
First : Ada.Streams.Stream_Element_Offset;
Index : Ada.Streams.Stream_Element_Offset;
Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
begin
First := Item'First;
Index := First - 1;
while First <= Max loop
Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
-- Exit when all or zero data sent. Zero means that the socket has
-- been closed by peer.
exit when Index < First or else Index = Max;
First := Index + 1;
end loop;
-- For an empty array, we have First > Max, and hence Index >= Max (no
-- error, the loop above is never executed). After a successful send,
-- Index = Max. The only remaining case, Index < Max, is therefore
-- always an actual send failure.
if Index < Max then
Raise_Socket_Error (Socket_Errno);
end if;
end Write;
Sockets_Library_Controller_Object : Sockets_Library_Controller;
pragma Unreferenced (Sockets_Library_Controller_Object);
-- The elaboration and finalization of this object perform the required
-- initialization and cleanup actions for the sockets library.
--------------------
-- Create_Address --
--------------------
function Create_Address
(Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
is
(case Family is
when Family_Inet => (Family_Inet, Bytes),
when Family_Inet6 => (Family_Inet6, Bytes));
---------------
-- Get_Bytes --
---------------
function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is
(case Addr.Family is
when Family_Inet => Addr.Sin_V4,
when Family_Inet6 => Addr.Sin_V6);
----------
-- Mask --
----------
function Mask
(Family : Family_Inet_4_6;
Length : Natural;
Host : Boolean := False) return Inet_Addr_Type
is
Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family);
begin
if Length > 8 * Addr_Len then
raise Constraint_Error with
"invalid mask length for address family " & Family'Img;
end if;
declare
B : Inet_Addr_Bytes (1 .. Addr_Len);
Part : Inet_Addr_Comp_Type;
begin
for J in 1 .. Length / 8 loop
B (J) := (if Host then 0 else 255);
end loop;
if Length < 8 * Addr_Len then
Part := 2 ** (8 - Length mod 8) - 1;
B (Length / 8 + 1) := (if Host then Part else not Part);
for J in Length / 8 + 2 .. B'Last loop
B (J) := (if Host then 255 else 0);
end loop;
end if;
return Create_Address (Family, B);
end;
end Mask;
-------------------------
-- Unix_Socket_Address --
-------------------------
function Unix_Socket_Address (Addr : String) return Sock_Addr_Type is
begin
return Sock_Addr_Type'(Family_Unix, ASU.To_Unbounded_String (Addr));
end Unix_Socket_Address;
-----------
-- "and" --
-----------
function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is
begin
if Addr.Family /= Mask.Family then
raise Constraint_Error with "incompatible address families";
end if;
declare
A : constant Inet_Addr_Bytes := Get_Bytes (Addr);
M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
R : Inet_Addr_Bytes (A'Range);
begin
for J in A'Range loop
R (J) := A (J) and M (J);
end loop;
return Create_Address (Addr.Family, R);
end;
end "and";
----------
-- "or" --
----------
function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is
begin
if Net.Family /= Host.Family then
raise Constraint_Error with "incompatible address families";
end if;
declare
N : constant Inet_Addr_Bytes := Get_Bytes (Net);
H : constant Inet_Addr_Bytes := Get_Bytes (Host);
R : Inet_Addr_Bytes (N'Range);
begin
for J in N'Range loop
R (J) := N (J) or H (J);
end loop;
return Create_Address (Net.Family, R);
end;
end "or";
-----------
-- "not" --
-----------
function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is
M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
R : Inet_Addr_Bytes (M'Range);
begin
for J in R'Range loop
R (J) := not M (J);
end loop;
return Create_Address (Mask.Family, R);
end "not";
end GNAT.Sockets;