[adasockets] More AdaSockets
pierre bodilis
pierre.bodilis at gmail.com
Thu Sep 7 11:57:24 CEST 2006
Hi everyone
I don't know if Samuel Tardieu got my email, but I'll post that here
in case someone find it useful :)
I needed a poll function, so I made one which could be useful at some
point. I also made a Send_Some (same as receive_some), of which I'm
still wondering if it is truely useful or it's just a stupid idea of
mine (and in anycase, I need it, so I'll keep it). And finally, I also
adapted 2 functions from GNAT.Sockets : Get_Service_By_Name and
Port_Number.
I'd think a Poll function would be fine in AdaSockets :)
----------------------------------------------------------------------------------------------------------------------
--- specs :
with Ada.Streams; use Ada.Streams;
with Sockets; use Sockets;
package More_AdaSockets is
type Poll_Option is (POLLNULL, -- nothing...
POLLIN, -- There is data to read
POLLPRI, -- There is urgent data to read
POLLOUT, -- Writing now will not block
POLLERR, -- Error condition
POLLHUP, -- Hung up
POLLNVAL, -- Invalid request: fd not open
-- When compiling XPG4.2 source also has
POLLRDNORM, -- Normal data may be read
POLLRDBAND, -- Priority data may be read
POLLWRNORM, -- Writing now will not block
POLLWRBAND, -- Priority data may be written
-- Finally, Linux knows about
POLLMSG);
--------------------------------------------------------------------------
procedure Poll(Socket : in Socket_FD;
Timeout : in Duration;
Option : in Poll_Option;
Timed_Out : out Boolean);
--------------------------------------------------------------------------
--------------------------------------------------------------------------
procedure Send_Some (Socket : in Socket_FD;
Data : in Stream_Element_Array;
Last : in out Stream_Element_Offset);
--------------------------------------------------------------------------
--------------------------------------------------------------------------
type Service_Entry_Type (Aliases_Length : Natural) is private;
-- Service entries provide complete information on a given service: the
-- official name, an array of alternative names or aliases and the port
-- number.
--------------------------------------------------------------------------
--------------------------------------------------------------------------
Service_Error : exception;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
function Get_Service_By_Name
(Name : String;
Protocol : String) return Service_Entry_Type;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
function Port_Number (S : Service_Entry_Type) return Natural;
--------------------------------------------------------------------------
private
Max_Name_Length : constant := 64;
-- The constant MAXHOSTNAMELEN is usually set to 64
subtype Name_Index is Natural range 1 .. Max_Name_Length;
type Name_Type (Length : Name_Index := Max_Name_Length) is record
Name : String (1 .. Length);
end record;
-- We need fixed strings to avoid access types in host entry type
type Name_Array is array (Natural range <>) of Name_Type;
type Port_Type is new Natural;
-- Classical port definition. No_Port provides a special value to
-- denote uninitialized port. Any_Port provides a special value
-- enabling all ports.
type Service_Entry_Type (Aliases_Length : Natural) is record
Official : Name_Type;
Aliases : Name_Array (1 .. Aliases_Length);
Port : Port_Type;
Protocol : Name_Type;
end record;
protected Serv_Lock is
entry Lock;
procedure Unlock;
private
Locked : Boolean := False;
end Serv_Lock;
end More_AdaSockets;
----------------------------------------------------------------------------------------------------------------------
--- impl :
with Sockets; use Sockets;
with Sockets.Thin; use Sockets.Thin;
with Sockets.Types; use Sockets.Types;
with Sockets.Constants;
with More_AdaSockets.Thin; use More_AdaSockets.Thin;
with Interfaces.C;
with Interfaces.C.Strings;
with Ada.Exceptions; use Ada.Exceptions;
with System; use System;
package body More_AdaSockets is
package C renames Interfaces.C;
package Const renames Sockets.Constants;
Poll_Value : constant array (POLL_OPTION) of C.short :=
( -- Message Null
POLLNULL => 16#0000#,
-- Those messages can be used for both events and revents
POLLIN => Const.Pollin,
POLLPRI => Const.Pollpri,
POLLOUT => Const.Pollout,
-- Those messages can be used only for revents
POLLERR => Const.Pollerr,
POLLHUP => Const.Pollhup,
POLLNVAL => Const.Pollnval,
-- When compiling XPG4.2 source also has
POLLRDNORM => 16#0040#,
POLLRDBAND => 16#0080#,
POLLWRNORM => 16#0100#,
POLLWRBAND => 16#0200#,
-- Finally, Linux knows about
POLLMSG => 16#0400#);
--------------------------------------------------------------------------
procedure Poll (Socket : in Socket_FD;
Timeout : in Duration;
Option : in Poll_Option;
Timed_Out : out Boolean) is
use C;
Event : C.short := Poll_Value(Option); -- poll number
Revent : C.short := Poll_Value(POLLNULL); -- by default, revent is null
Pfd : aliased Pollfd; -- Ptrable Pollfd
Result : C.int;
TO : C.int := C.int(Timeout*1000); -- with Poll, time is in ms
begin
Pfd := (FD => Get_FD(Socket), -- Socket FD
Events => Event, -- Events to wait for
Revents => Revent); -- Events to get
Result := C_Poll(FDS => Pfd'Address, -- our Poll File Descriptpor
NFDS => 1, -- 1 FS to poll
Timeout => TO); -- Time in millisecond
case Result is
when -1 => -- error !
Raise_Exception (Socket_Error'Identity,
"Polling error! " & Integer'Image(Integer(errno)));
when 0 => -- timeout !
Timed_Out := True;
when 1 => -- something happened !
Timed_Out := False;
when others => -- something
strange happened...
raise Socket_Error;
end case;
end Poll;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
procedure Send_Some (Socket : in Socket_FD;
Data : in Stream_Element_Array;
Last : in out Stream_Element_Offset)
is
use C;
Index : Stream_Element_Offset := Data'First;
Rest : Stream_Element_Count := Last;
Count : C.int;
begin
-- if Socket.Shutdown (Send) then
-- raise Connection_Closed;
-- end if;
while Rest > 0 loop
Count := C_Send (Get_FD(Socket), Data (Index) 'Address, C.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_Some;
--------------------------------------------------------------------------
function To_Service_Entry (E : Servent) return Service_Entry_Type;
--------------------------------------------------------------------------
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);
Res : Servent_Access;
begin
-- This C function is not always thread-safe. Protect against
-- concurrent access.
Serv_Lock.Lock;
Res := C_Getservbyname (SN, SP);
if Res = null then
Serv_Lock.Unlock;
Raise_Exception (Service_Error'Identity, "Service not found");
end if;
declare
SE : constant Service_Entry_Type := To_Service_Entry (Res.all);
begin
Serv_Lock.Unlock;
return SE;
end;
end Get_Service_By_Name;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
function Port_Number (S : Service_Entry_Type) return Natural is
begin
return Natural(S.Port);
end Port_Number;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
---------------------------- private -------------------------------------
--------------------------------------------------------------------------
--------------------------------------------------------------------------
function To_Name (N : String) return Name_Type is
begin
return Name_Type'(N'Length, N);
end To_Name;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
function To_Service_Entry (E : Servent) return Service_Entry_Type is
use type C.size_t;
function Network_To_Port (Port : C.unsigned_short) return C.unsigned_short
is
use C;
begin
if Default_Bit_Order = High_Order_First then
return Port;
else
return (Port / 256) + (Port mod 256) * 256;
end if;
end Network_To_Port;
Official : constant String := C.Strings.Value (E.S_Name);
Aliases : constant Chars_Ptr_Array
:= Chars_Ptr_Pointers.Value (E.S_Aliases);
Protocol : constant String := C.Strings.Value (E.S_Proto);
Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
Source : C.size_t;
Target : Natural;
begin
Result.Official := To_Name (Official);
Source := Aliases'First;
Target := Result.Aliases'First;
while Target <= Result.Aliases_Length loop
Result.Aliases(Target) := To_Name(C.Strings.Value(Aliases (Source)));
Source := Source + 1;
Target := Target + 1;
end loop;
Result.Port := Port_Type
(Network_To_Port (C.unsigned_short (E.S_Port)));
Result.Protocol := To_Name (Protocol);
return Result;
end To_Service_Entry;
--------------------------------------------------------------------------
--------------------------------------------------------------------------
-- rather simple protected object, used as a semaphore.
protected body Serv_Lock is
entry Lock when not Locked is
begin
Locked := True;
end Lock;
procedure Unlock is
begin
Locked := False;
end Unlock;
end Serv_Lock;
--------------------------------------------------------------------------
end More_AdaSockets;
More information about the AdaSockets
mailing list