741 lines
23 KiB
Ada
741 lines
23 KiB
Ada
-----------------------------------------------------------------------------
|
|
-- --
|
|
-- ADASOCKETS COMPONENTS --
|
|
-- --
|
|
-- S O C K E T S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1998-2020 Samuel Tardieu <sam@rfc1149.net> --
|
|
-- Copyright (C) 1999-2003 Télécom ParisTech --
|
|
-- --
|
|
-- AdaSockets is free software; you can redistribute it and/or modify --
|
|
-- it under terms of the GNU General Public License as published by --
|
|
-- the Free Software Foundation; either version 2, or (at your option) --
|
|
-- any later version. AdaSockets is distributed in the hope that it --
|
|
-- will be useful, but WITHOUT ANY WARRANTY; without even the implied --
|
|
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
-- See the GNU General Public License for more details. You should --
|
|
-- have received a copy of the GNU General Public License distributed --
|
|
-- with AdaSockets; see file COPYING. If not, write to the Free --
|
|
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --
|
|
-- 02111-1307, USA. --
|
|
-- --
|
|
-- As a special exception, if other files instantiate generics from --
|
|
-- this unit, or you link this unit with other files to produce an --
|
|
-- executable, this unit does not by itself cause the resulting --
|
|
-- executable to be covered by the GNU General Public License. This --
|
|
-- exception does not however invalidate any other reasons why the --
|
|
-- executable file might be covered by the GNU Public License. --
|
|
-- --
|
|
-- The main repository for this software is located at: --
|
|
-- http://www.rfc1149.net/devel/adasockets.html --
|
|
-- --
|
|
-- If you have any question, please use the issues tracker at: --
|
|
-- https://github.com/samueltardieu/adasockets/issues --
|
|
-- --
|
|
-----------------------------------------------------------------------------
|
|
|
|
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
|
|
with Ada.Unchecked_Deallocation;
|
|
with Sockets.Constants; use Sockets.Constants;
|
|
with Sockets.Link;
|
|
pragma Warnings (Off, Sockets.Link);
|
|
with Sockets.Naming; use Sockets.Naming;
|
|
with Sockets.Thin; use Sockets.Thin;
|
|
with Sockets.Types; use Sockets.Types;
|
|
with Sockets.Utils; use Sockets.Utils;
|
|
|
|
package body Sockets is
|
|
|
|
use Ada.Streams, Interfaces.C;
|
|
|
|
Socket_Domain_Match : constant array (Socket_Domain) of int :=
|
|
(PF_INET => Constants.Af_Inet,
|
|
AF_INET => Constants.Af_Inet); -- They hold the same value
|
|
|
|
Socket_Type_Match : constant array (Socket_Type) of int :=
|
|
(SOCK_STREAM => Constants.Sock_Stream,
|
|
SOCK_DGRAM => Constants.Sock_Dgram);
|
|
|
|
Shutdown_Type_Match : constant array (Shutdown_Type) of int :=
|
|
(Receive => 0,
|
|
Send => 1,
|
|
Both => 2);
|
|
|
|
Socket_Level_Match : constant array (Socket_Level) of int :=
|
|
(SOL_SOCKET => Constants.Sol_Socket,
|
|
IPPROTO_IP => Constants.Ipproto_Ip,
|
|
SOL_TCP => Constants.Sol_Tcp);
|
|
|
|
Socket_Option_Match : constant array (Socket_Option) of int :=
|
|
(SO_REUSEADDR => Constants.So_Reuseaddr,
|
|
SO_REUSEPORT => Constants.So_Reuseport,
|
|
IP_MULTICAST_TTL => Constants.Ip_Multicast_Ttl,
|
|
IP_ADD_MEMBERSHIP => Constants.Ip_Add_Membership,
|
|
IP_DROP_MEMBERSHIP => Constants.Ip_Drop_Membership,
|
|
IP_MULTICAST_LOOP => Constants.Ip_Multicast_Loop,
|
|
SO_SNDBUF => Constants.So_Sndbuf,
|
|
SO_RCVBUF => Constants.So_Rcvbuf,
|
|
SO_KEEPALIVE => Constants.So_Keepalive,
|
|
SO_NOSIGPIPE => Constants.So_Nosigpipe,
|
|
TCP_KEEPCNT => Constants.Tcp_Keepcnt,
|
|
TCP_KEEPIDLE => Constants.Tcp_Keepidle,
|
|
TCP_KEEPINTVL => Constants.Tcp_Keepintvl,
|
|
TCP_NODELAY => Constants.Tcp_Nodelay);
|
|
|
|
Socket_Option_Size : constant array (Socket_Option) of Natural :=
|
|
(SO_REUSEADDR => 4,
|
|
SO_REUSEPORT => 4,
|
|
IP_MULTICAST_TTL => 1,
|
|
IP_ADD_MEMBERSHIP => 8,
|
|
IP_DROP_MEMBERSHIP => 8,
|
|
IP_MULTICAST_LOOP => 1,
|
|
SO_SNDBUF => 4,
|
|
SO_RCVBUF => 4,
|
|
SO_KEEPALIVE => 4,
|
|
SO_NOSIGPIPE => 4,
|
|
TCP_KEEPCNT => 4,
|
|
TCP_KEEPIDLE => 4,
|
|
TCP_KEEPINTVL => 4,
|
|
TCP_NODELAY => 4);
|
|
|
|
CRLF : constant String := CR & LF;
|
|
|
|
procedure Refill (Socket : Socket_FD'Class);
|
|
-- Refill the socket when in buffered mode by receiving one packet
|
|
-- and putting it in the buffer.
|
|
|
|
function To_String (S : Stream_Element_Array) return String;
|
|
|
|
function Empty_Buffer (Socket : Socket_FD'Class) return Boolean;
|
|
-- Return True if buffered socket has an empty buffer
|
|
|
|
-------------------
|
|
-- Accept_Socket --
|
|
-------------------
|
|
|
|
procedure Accept_Socket (Socket : Socket_FD;
|
|
New_Socket : out Socket_FD)
|
|
is
|
|
Sin : aliased Sockaddr_In;
|
|
Size : aliased int := Sin'Size / 8;
|
|
Code : int;
|
|
begin
|
|
Code := C_Accept (Socket.FD, Sin'Address, Size'Access);
|
|
if Code = Failure then
|
|
Raise_With_Message ("Accept system call failed");
|
|
else
|
|
New_Socket :=
|
|
(FD => Code,
|
|
Shutdown => (others => False),
|
|
Buffer => null);
|
|
end if;
|
|
end Accept_Socket;
|
|
|
|
----------
|
|
-- Bind --
|
|
----------
|
|
|
|
procedure Bind
|
|
(Socket : Socket_FD;
|
|
Port : Natural;
|
|
Host : String := "")
|
|
is
|
|
Sin : aliased Sockaddr_In;
|
|
begin
|
|
Sin.Sin_Family := Constants.Af_Inet;
|
|
if Host /= "" then
|
|
Sin.Sin_Addr := To_In_Addr (Address_Of (Host));
|
|
end if;
|
|
Sin.Sin_Port := Port_To_Network (unsigned_short (Port));
|
|
if C_Bind (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
|
|
Raise_With_Message ("Bind failed");
|
|
end if;
|
|
end Bind;
|
|
|
|
-------------
|
|
-- Connect --
|
|
-------------
|
|
|
|
procedure Connect
|
|
(Socket : Socket_FD;
|
|
Host : String;
|
|
Port : Positive)
|
|
is
|
|
Sin : aliased Sockaddr_In;
|
|
Current_Errno : Integer;
|
|
begin
|
|
Sin.Sin_Family := Constants.Af_Inet;
|
|
Sin.Sin_Addr := To_In_Addr (Address_Of (Host));
|
|
Sin.Sin_Port := Port_To_Network (unsigned_short (Port));
|
|
if C_Connect (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
|
|
Current_Errno := Thin.Errno;
|
|
if Current_Errno = Constants.Econnrefused then
|
|
raise Connection_Refused;
|
|
else
|
|
Raise_With_Message
|
|
("Connection failed (errno was" &
|
|
Integer'Image (Current_Errno) & ')',
|
|
False);
|
|
end if;
|
|
end if;
|
|
end Connect;
|
|
|
|
---------------------------
|
|
-- Customized_Setsockopt --
|
|
---------------------------
|
|
|
|
procedure Customized_Setsockopt (Socket : Socket_FD'Class;
|
|
Optval : Opt_Type)
|
|
is
|
|
begin
|
|
pragma Assert (Optval'Size / 8 = Socket_Option_Size (Optname));
|
|
if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
|
|
Socket_Option_Match (Optname),
|
|
Optval'Address, Optval'Size / 8) = Failure
|
|
then
|
|
Raise_With_Message ("Setsockopt failed");
|
|
end if;
|
|
end Customized_Setsockopt;
|
|
|
|
------------------
|
|
-- Empty_Buffer --
|
|
------------------
|
|
|
|
function Empty_Buffer (Socket : Socket_FD'Class) return Boolean is
|
|
begin
|
|
return Socket.Buffer.First > Socket.Buffer.Last;
|
|
end Empty_Buffer;
|
|
|
|
---------
|
|
-- Get --
|
|
---------
|
|
|
|
function Get (Socket : Socket_FD'Class) return String
|
|
is
|
|
begin
|
|
if Socket.Buffer /= null and then not Empty_Buffer (Socket) then
|
|
declare
|
|
S : constant String :=
|
|
To_String (Socket.Buffer.Content
|
|
(Socket.Buffer.First .. Socket.Buffer.Last));
|
|
begin
|
|
Socket.Buffer.First := Socket.Buffer.Last + 1;
|
|
return S;
|
|
end;
|
|
else
|
|
return To_String (Receive (Socket));
|
|
end if;
|
|
end Get;
|
|
|
|
--------------
|
|
-- Get_Char --
|
|
--------------
|
|
|
|
function Get_Char (Socket : Socket_FD'Class) return Character is
|
|
C : Stream_Element_Array (0 .. 0);
|
|
begin
|
|
if Socket.Buffer = null then
|
|
-- Unbuffered mode
|
|
|
|
Receive (Socket, C);
|
|
else
|
|
-- Buffered mode
|
|
|
|
if Empty_Buffer (Socket) then
|
|
Refill (Socket);
|
|
end if;
|
|
|
|
C (0) := Socket.Buffer.Content (Socket.Buffer.First);
|
|
Socket.Buffer.First := Socket.Buffer.First + 1;
|
|
|
|
end if;
|
|
|
|
return Character'Val (C (0));
|
|
end Get_Char;
|
|
|
|
------------
|
|
-- Get FD --
|
|
------------
|
|
|
|
function Get_FD (Socket : Socket_FD)
|
|
return Interfaces.C.int
|
|
is
|
|
begin
|
|
return Socket.FD;
|
|
end Get_FD;
|
|
|
|
--------------
|
|
-- Get_Line --
|
|
--------------
|
|
|
|
procedure Get_Line
|
|
(Socket : Socket_FD'Class;
|
|
Str : out String;
|
|
Last : out Natural)
|
|
is
|
|
Index : Positive := Str'First;
|
|
Char : Character;
|
|
begin
|
|
loop
|
|
Char := Get_Char (Socket);
|
|
if Char = LF then
|
|
Last := Index - 1;
|
|
return;
|
|
elsif Char /= CR then
|
|
Str (Index) := Char;
|
|
Index := Index + 1;
|
|
if Index > Str'Last then
|
|
Last := Str'Last;
|
|
return;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
end Get_Line;
|
|
|
|
--------------
|
|
-- Get_Line --
|
|
--------------
|
|
|
|
function Get_Line
|
|
(Socket : Socket_FD'Class; Max_Length : Positive := 2048)
|
|
return String
|
|
is
|
|
Result : String (1 .. Max_Length);
|
|
Last : Natural;
|
|
begin
|
|
Get_Line (Socket, Result, Last);
|
|
return Result (1 .. Last);
|
|
end Get_Line;
|
|
|
|
----------------------------
|
|
-- Get_Receive_Queue_Size --
|
|
----------------------------
|
|
|
|
function Get_Receive_Queue_Size (Socket : Socket_FD) return Integer is
|
|
Error : Interfaces.C.int;
|
|
Size : aliased Interfaces.C.int := 0;
|
|
begin
|
|
-- The check always evaluates statically
|
|
pragma Warnings (Off, "condition is always *");
|
|
if Siocinq = -1 then
|
|
return -2;
|
|
end if;
|
|
pragma Warnings (On, "condition is always *");
|
|
Error := C_Ioctl (Socket.FD, Siocinq, Size'Access);
|
|
if Error < 0 then
|
|
return Integer (Error);
|
|
else
|
|
return Integer (Size);
|
|
end if;
|
|
end Get_Receive_Queue_Size;
|
|
|
|
-------------------------
|
|
-- Get_Send_Queue_Size --
|
|
-------------------------
|
|
|
|
function Get_Send_Queue_Size (Socket : Socket_FD) return Integer is
|
|
Error : Interfaces.C.int;
|
|
Size : aliased Interfaces.C.int := 0;
|
|
begin
|
|
-- The check always evaluates statically
|
|
pragma Warnings (Off, "condition is always *");
|
|
if Siocoutq = -1 then
|
|
return -2;
|
|
end if;
|
|
pragma Warnings (On, "condition is always *");
|
|
Error := C_Ioctl (Socket.FD, Siocoutq, Size'Access);
|
|
if Error < 0 then
|
|
return Integer (Error);
|
|
else
|
|
return Integer (Size);
|
|
end if;
|
|
end Get_Send_Queue_Size;
|
|
|
|
----------------
|
|
-- Getsockopt --
|
|
----------------
|
|
|
|
procedure Getsockopt
|
|
(Socket : Socket_FD'Class;
|
|
Level : Socket_Level := SOL_SOCKET;
|
|
Optname : Socket_Option;
|
|
Optval : out Integer)
|
|
is
|
|
Len : aliased int;
|
|
begin
|
|
case Socket_Option_Size (Optname) is
|
|
|
|
when 1 =>
|
|
declare
|
|
C_Char_Optval : aliased char;
|
|
begin
|
|
pragma Assert (C_Char_Optval'Size = 8);
|
|
Len := 1;
|
|
if C_Getsockopt (Socket.FD, Socket_Level_Match (Level),
|
|
Socket_Option_Match (Optname),
|
|
C_Char_Optval'Address, Len'Access) = Failure
|
|
then
|
|
Raise_With_Message ("Getsockopt failed");
|
|
end if;
|
|
Optval := char'Pos (C_Char_Optval);
|
|
end;
|
|
|
|
when 4 =>
|
|
declare
|
|
C_Int_Optval : aliased int;
|
|
begin
|
|
pragma Assert (C_Int_Optval'Size = 32);
|
|
Len := 4;
|
|
if C_Getsockopt (Socket.FD, Socket_Level_Match (Level),
|
|
Socket_Option_Match (Optname),
|
|
C_Int_Optval'Address, Len'Access) = Failure
|
|
then
|
|
Raise_With_Message ("Getsockopt failed");
|
|
end if;
|
|
Optval := Integer (C_Int_Optval);
|
|
|
|
end;
|
|
|
|
when others =>
|
|
Raise_With_Message ("Getsockopt called with wrong arguments",
|
|
False);
|
|
|
|
end case;
|
|
end Getsockopt;
|
|
|
|
------------
|
|
-- Listen --
|
|
------------
|
|
|
|
procedure Listen
|
|
(Socket : Socket_FD;
|
|
Queue_Size : Positive := 5)
|
|
is
|
|
begin
|
|
if C_Listen (Socket.FD, int (Queue_Size)) = Failure then
|
|
Raise_With_Message ("Listen failed");
|
|
end if;
|
|
end Listen;
|
|
|
|
--------------
|
|
-- New_Line --
|
|
--------------
|
|
|
|
procedure New_Line (Socket : Socket_FD'Class;
|
|
Count : Natural := 1)
|
|
is
|
|
begin
|
|
Put (Socket, CRLF * Count);
|
|
end New_Line;
|
|
|
|
---------
|
|
-- Put --
|
|
---------
|
|
|
|
procedure Put (Socket : Socket_FD'Class;
|
|
Str : String)
|
|
is
|
|
Stream : Stream_Element_Array (Stream_Element_Offset (Str'First) ..
|
|
Stream_Element_Offset (Str'Last));
|
|
begin
|
|
for I in Str'Range loop
|
|
Stream (Stream_Element_Offset (I)) :=
|
|
Stream_Element'Val (Character'Pos (Str (I)));
|
|
end loop;
|
|
Send (Socket, Stream);
|
|
end Put;
|
|
|
|
--------------
|
|
-- Put_Line --
|
|
--------------
|
|
|
|
procedure Put_Line (Socket : Socket_FD'Class; Str : String)
|
|
is
|
|
begin
|
|
Put (Socket, Str & CRLF);
|
|
end Put_Line;
|
|
|
|
-------------
|
|
-- Receive --
|
|
-------------
|
|
|
|
function Receive (Socket : Socket_FD; Max : Stream_Element_Count := 4096)
|
|
return Stream_Element_Array
|
|
is
|
|
Buffer : Stream_Element_Array (1 .. Max);
|
|
Addr : aliased Sockaddr_In;
|
|
Addrlen : aliased int := Addr'Size / 8;
|
|
Count : int;
|
|
begin
|
|
if Socket.Shutdown (Receive) then
|
|
raise Connection_Closed;
|
|
end if;
|
|
Count := C_Recvfrom (Socket.FD, Buffer'Address, Buffer'Length, 0,
|
|
Addr'Address, Addrlen'Access);
|
|
if Count < 0 then
|
|
Raise_With_Message ("Receive error");
|
|
elsif Count = 0 then
|
|
raise Connection_Closed;
|
|
end if;
|
|
return Buffer (1 .. Stream_Element_Offset (Count));
|
|
end Receive;
|
|
|
|
-------------
|
|
-- Receive --
|
|
-------------
|
|
|
|
procedure Receive (Socket : Socket_FD'Class;
|
|
Data : out Stream_Element_Array)
|
|
is
|
|
Index : Stream_Element_Offset := Data'First;
|
|
Rest : Stream_Element_Count := Data'Length;
|
|
Addr : aliased Sockaddr_In;
|
|
Addrlen : aliased int := Addr'Size / 8;
|
|
Count : int;
|
|
begin
|
|
while Rest > 0 loop
|
|
Count := C_Recvfrom (Socket.FD, Data (Index) 'Address,
|
|
int (Rest), 0, Addr'Address, Addrlen'Access);
|
|
|
|
if Count < 0 then
|
|
Raise_With_Message ("Receive error");
|
|
elsif Count = 0 then
|
|
raise Connection_Closed;
|
|
end if;
|
|
|
|
Index := Index + Stream_Element_Count (Count);
|
|
Rest := Rest - Stream_Element_Count (Count);
|
|
end loop;
|
|
end Receive;
|
|
|
|
------------------
|
|
-- Receive_Some --
|
|
------------------
|
|
|
|
procedure Receive_Some (Socket : Socket_FD'Class;
|
|
Data : out Stream_Element_Array;
|
|
Last : out Stream_Element_Offset)
|
|
is
|
|
Addr : aliased Sockaddr_In;
|
|
Addrlen : aliased int := Addr'Size / 8;
|
|
Count : int;
|
|
begin
|
|
Count := C_Recvfrom (Socket.FD, Data (Data'First) 'Address,
|
|
int (Data'Length), 0,
|
|
Addr'Address, Addrlen'Access);
|
|
if Count < 0 then
|
|
Raise_With_Message ("Receive error");
|
|
elsif Count = 0 then
|
|
raise Connection_Closed;
|
|
end if;
|
|
Last := Data'First + Stream_Element_Count (Count) - 1;
|
|
end Receive_Some;
|
|
|
|
------------
|
|
-- Refill --
|
|
------------
|
|
|
|
procedure Refill
|
|
(Socket : Socket_FD'Class)
|
|
is
|
|
begin
|
|
pragma Assert (Socket.Buffer /= null);
|
|
Receive_Some (Socket, Socket.Buffer.Content, Socket.Buffer.Last);
|
|
Socket.Buffer.First := 0;
|
|
end Refill;
|
|
|
|
----------
|
|
-- Send --
|
|
----------
|
|
|
|
procedure Send (Socket : Socket_FD;
|
|
Data : Stream_Element_Array)
|
|
is
|
|
Index : Stream_Element_Offset := Data'First;
|
|
Rest : Stream_Element_Count := Data'Length;
|
|
Count : int;
|
|
Flags : int := 0;
|
|
begin
|
|
if Socket.Shutdown (Send) then
|
|
raise Connection_Closed;
|
|
end if;
|
|
pragma Warnings (Off, "condition is always *");
|
|
if Constants.So_Nosigpipe = -1 and Constants.Msg_Nosignal /= -1 then
|
|
Flags := Constants.Msg_Nosignal;
|
|
end if;
|
|
pragma Warnings (On, "condition is always *");
|
|
while Rest > 0 loop
|
|
Count := C_Send (Socket.FD, Data (Index) 'Address, int (Rest), Flags);
|
|
if Count <= 0 then
|
|
-- Count could be zero if the socket was in non-blocking mode
|
|
-- and the output buffers were full. Since we do not support
|
|
-- non-blocking mode, this is an error.
|
|
|
|
raise Connection_Closed;
|
|
end if;
|
|
Index := Index + Stream_Element_Count (Count);
|
|
Rest := Rest - Stream_Element_Count (Count);
|
|
end loop;
|
|
end Send;
|
|
|
|
----------------
|
|
-- Set_Buffer --
|
|
----------------
|
|
|
|
procedure Set_Buffer
|
|
(Socket : in out Socket_FD'Class;
|
|
Length : Positive := 1500)
|
|
is
|
|
begin
|
|
Unset_Buffer (Socket);
|
|
Socket.Buffer := new Buffer_Type (Stream_Element_Count (Length));
|
|
end Set_Buffer;
|
|
|
|
----------------
|
|
-- Setsockopt --
|
|
----------------
|
|
|
|
procedure Setsockopt
|
|
(Socket : Socket_FD'Class;
|
|
Level : Socket_Level := SOL_SOCKET;
|
|
Optname : Socket_Option;
|
|
Optval : Integer)
|
|
is
|
|
begin
|
|
case Socket_Option_Size (Optname) is
|
|
|
|
when 1 =>
|
|
declare
|
|
C_Char_Optval : aliased char := char'Val (Optval);
|
|
begin
|
|
pragma Assert (C_Char_Optval'Size = 8);
|
|
if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
|
|
Socket_Option_Match (Optname),
|
|
C_Char_Optval'Address, 1) = Failure
|
|
then
|
|
Raise_With_Message ("Setsockopt failed");
|
|
end if;
|
|
end;
|
|
|
|
when 4 =>
|
|
declare
|
|
C_Int_Optval : aliased int := int (Optval);
|
|
begin
|
|
pragma Assert (C_Int_Optval'Size = 32);
|
|
if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
|
|
Socket_Option_Match (Optname),
|
|
C_Int_Optval'Address, 4) = Failure
|
|
then
|
|
Raise_With_Message ("Setsockopt failed");
|
|
end if;
|
|
end;
|
|
|
|
when others =>
|
|
Raise_With_Message ("Setsockopt called with wrong arguments",
|
|
False);
|
|
|
|
end case;
|
|
end Setsockopt;
|
|
|
|
--------------
|
|
-- Shutdown --
|
|
--------------
|
|
|
|
procedure Shutdown (Socket : in out Socket_FD;
|
|
How : Shutdown_Type := Both)
|
|
is
|
|
begin
|
|
if How /= Both then
|
|
Socket.Shutdown (How) := True;
|
|
else
|
|
Socket.Shutdown := (others => True);
|
|
end if;
|
|
C_Shutdown (Socket.FD, Shutdown_Type_Match (How));
|
|
if Socket.Shutdown (Receive) and then Socket.Shutdown (Send) then
|
|
declare
|
|
Result : constant int := C_Close (Socket.FD);
|
|
pragma Unreferenced (Result);
|
|
begin
|
|
Unset_Buffer (Socket);
|
|
end;
|
|
end if;
|
|
end Shutdown;
|
|
|
|
------------
|
|
-- Socket --
|
|
------------
|
|
|
|
procedure Socket
|
|
(Sock : out Socket_FD;
|
|
Domain : Socket_Domain := PF_INET;
|
|
Typ : Socket_Type := SOCK_STREAM)
|
|
is
|
|
Result : constant int :=
|
|
C_Socket (Socket_Domain_Match (Domain), Socket_Type_Match (Typ), 0);
|
|
begin
|
|
if Result = Failure then
|
|
Raise_With_Message ("Unable to create socket");
|
|
end if;
|
|
Sock := (FD => Result, Shutdown => (others => False), Buffer => null);
|
|
pragma Warnings (Off, "condition is always *");
|
|
if Constants.So_Nosigpipe /= -1 then
|
|
Setsockopt (Sock, SOL_SOCKET, SO_NOSIGPIPE, 1);
|
|
end if;
|
|
pragma Warnings (On, "condition is always *");
|
|
end Socket;
|
|
|
|
----------------
|
|
-- Socketpair --
|
|
----------------
|
|
|
|
procedure Socketpair
|
|
(Read_End : out Socket_FD;
|
|
Write_End : out Socket_FD;
|
|
Domain : Socket_Domain := PF_INET;
|
|
Typ : Socket_Type := SOCK_STREAM)
|
|
is
|
|
Filedes : aliased Two_Int;
|
|
Result : constant int :=
|
|
C_Socketpair (Socket_Domain_Match (Domain),
|
|
Socket_Type_Match (Typ), 0,
|
|
Filedes'Address);
|
|
begin
|
|
if Result = Failure then
|
|
Raise_With_Message ("Unable to create socket");
|
|
end if;
|
|
Read_End := (FD => Filedes (0), Shutdown => (others => False),
|
|
Buffer => null);
|
|
Write_End := (FD => Filedes (1), Shutdown => (others => False),
|
|
Buffer => null);
|
|
end Socketpair;
|
|
|
|
---------------
|
|
-- To_String --
|
|
---------------
|
|
|
|
function To_String (S : Stream_Element_Array) return String is
|
|
Result : String (1 .. S'Length);
|
|
begin
|
|
for I in Result'Range loop
|
|
Result (I) :=
|
|
Character'Val (Stream_Element'Pos
|
|
(S (Stream_Element_Offset (I) + S'First - 1)));
|
|
end loop;
|
|
return Result;
|
|
end To_String;
|
|
|
|
------------------
|
|
-- Unset_Buffer --
|
|
------------------
|
|
|
|
procedure Unset_Buffer (Socket : in out Socket_FD'Class) is
|
|
procedure Free is
|
|
new Ada.Unchecked_Deallocation (Buffer_Type, Buffer_Access);
|
|
begin
|
|
Free (Socket.Buffer);
|
|
end Unset_Buffer;
|
|
|
|
end Sockets;
|