----------------------------------------------------------------------------- -- -- -- ADASOCKETS COMPONENTS -- -- -- -- S O C K E T S -- -- -- -- B o d y -- -- -- -- $ReleaseVersion: 0.1.3 $ -- -- -- -- Copyright (C) 1998 École Nationale Supérieure des Télécommunications -- -- -- -- 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-inf.enst.fr/ANC/ -- -- -- ----------------------------------------------------------------------------- with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 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.Utils; use Sockets.Utils; package body Sockets is use Ada.Streams, Interfaces.C; Socket_Domain_Match : constant array (Socket_Domain) of int := (AF_INET => Constants.Af_Inet); 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, 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); Socket_Option_Size : constant array (Socket_Option) of Natural := (SO_REUSEADDR => 4, IP_MULTICAST_TTL => 1, IP_ADD_MEMBERSHIP => 8, IP_DROP_MEMBERSHIP => 8, IP_MULTICAST_LOOP => 1); function "*" (Left : String; Right : Natural) return String; pragma Inline ("*"); CRLF : constant String := CR & LF; --------- -- "*" -- --------- 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); end if; end Accept_Socket; ---------- -- Bind -- ---------- procedure Bind (Socket : in Socket_FD; Port : in Positive) is Sin : aliased Sockaddr_In; begin Sin.Sin_Family := Constants.Af_Inet; 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; 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 raise Connection_Refused; 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; --------- -- Get -- --------- function Get (Socket : Socket_FD'Class) return String is Stream : constant Stream_Element_Array := Receive (Socket); Result : String (Positive (Stream'First) .. Positive (Stream'Last)); begin for I in Stream'Range loop Result (Positive (I)) := Character'Val (Stream_Element'Pos (Stream (I))); end loop; return Result; end Get; -------------- -- Get_Line -- -------------- function Get_Line (Socket : Socket_FD'Class) return String is Result : String (1 .. 1024); Index : Positive := Result'First; Byte : Stream_Element_Array (1 .. 1); Char : Character; begin loop Receive (Socket, Byte); Char := Character'Val (Stream_Element'Pos (Byte (Byte'First))); if Char = LF then return Result (1 .. Index - 1); elsif Char /= CR then Result (Index) := Char; Index := Index + 1; if Index > Result'Last then return Result & Get_Line (Socket); end if; end if; end loop; end Get_Line; ------------ -- 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 Ada.Streams.Stream_Element_Array is Buffer : Stream_Element_Array (1 .. Max); Addr : aliased In_Addr; Addrlen : aliased int := Addr'Size / 8; Count : constant int := C_Recvfrom (Socket.FD, Buffer'Address, Buffer'Length, 0, Addr'Address, Addrlen'Access); begin 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 Ada.Streams.Stream_Element_Array) is Index : Stream_Element_Offset := Data'First; Rest : Stream_Element_Count := Data'Length; begin while Rest > 0 loop declare Sub_Buffer : constant Stream_Element_Array := Receive (Socket, Rest); Length : constant Stream_Element_Count := Sub_Buffer'Length; begin Data (Index .. Index + Length - 1) := Sub_Buffer; Index := Index + Length; Rest := Rest - Length; end; end loop; end Receive; ---------- -- 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 while Rest > 0 loop Count := C_Send (Socket.FD, Data (Index) 'Address, int (Rest), 0); if Count < 0 then Raise_With_Message ("Send failed"); elsif Count = 0 then raise Connection_Closed; end if; Index := Index + Stream_Element_Count (Count); Rest := Rest - Stream_Element_Count (Count); end loop; end Send; ---------------- -- 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 Socket_FD; How : in Shutdown_Type := Both) is begin C_Shutdown (Socket.FD, Shutdown_Type_Match (How)); end Shutdown; ------------ -- Socket -- ------------ procedure Socket (Sock : out Socket_FD; Domain : in Socket_Domain := AF_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); end Socket; end Sockets;