-----------------------------------------------------------------------------
-- --
-- ADASOCKETS COMPONENTS --
-- --
-- S O C K E T S --
-- --
-- B o d y --
-- --
-- $ReleaseVersion: 0.1.6 $ --
-- --
-- Copyright (C) 1998,1999 Samuel Tardieu <sam@rfc1149.net> --
-- Copyright (C) 1999-2003 ENST http://www.enst.fr/ --
-- --
-- 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 --
-- --
-- If you have any question, please send a mail to --
-- Samuel Tardieu <sam@rfc1149.net> --
-- --
-----------------------------------------------------------------------------
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);
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);
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);
function "*" (Left : String; Right : Natural) return String;
pragma Inline ("*");
CRLF : constant String := CR & LF;
procedure Refill (Socket : in 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
---------
-- "*" --
---------
function "*" (Left : String; Right : Natural) return String is
Result : String (1 .. Left'Length * Right);
First : Positive := 1;
Last : Natural := First + Left'Length - 1;
begin
for I in 1 .. Right loop
Result (First .. Last) := Left;
First := First + Left'Length;
Last := Last + Left'Length;
end loop;
return Result;
end "*";
-------------------
-- Accept_Socket --
-------------------
procedure Accept_Socket (Socket : in 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 : in Socket_FD;
Port : in Natural;
Host : in 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 : in Socket_FD;
Host : in String;
Port : in 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 : in Socket_FD'Class;
Optval : in 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 : in 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;
----------------
-- Getsockopt --
----------------
procedure Getsockopt
(Socket : in Socket_FD'Class;
Level : in Socket_Level := SOL_SOCKET;
Optname : in 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 : in Socket_FD;
Queue_Size : in 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 : in Socket_FD'Class;
Count : in Natural := 1)
is
begin
Put (Socket, CRLF * Count);
end New_Line;
---------
-- Put --
---------
procedure Put (Socket : in Socket_FD'Class;
Str : in 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 : in Socket_FD'Class; Str : in 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 : in 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 : in 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 : in 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 : in Socket_FD;
Data : in Stream_Element_Array)
is
Index : Stream_Element_Offset := Data'First;
Rest : Stream_Element_Count := Data'Length;
Count : int;
begin
if Socket.Shutdown (Send) then
raise Connection_Closed;
end if;
while Rest > 0 loop
Count := C_Send (Socket.FD, Data (Index) 'Address, int (Rest), 0);
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 : in Positive := 1500)
is
begin
Unset_Buffer (Socket);
Socket.Buffer := new Buffer_Type (Stream_Element_Count (Length));
end Set_Buffer;
----------------
-- Setsockopt --
----------------
procedure Setsockopt
(Socket : in Socket_FD'Class;
Level : in Socket_Level := Sol_Socket;
Optname : in Socket_Option;
Optval : in 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 : in 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);
begin
Unset_Buffer (Socket);
end;
end if;
end Shutdown;
------------
-- Socket --
------------
procedure Socket
(Sock : out Socket_FD;
Domain : in Socket_Domain := PF_INET;
Typ : in 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);
end Socket;
----------------
-- Socketpair --
----------------
procedure Socketpair
(Read_End : out Socket_FD;
Write_End : out Socket_FD;
Domain : in Socket_Domain := PF_INET;
Typ : in 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;
syntax highlighted by Code2HTML, v. 0.9.1