From pierre.bodilis at gmail.com Thu Sep 7 11:57:24 2006 From: pierre.bodilis at gmail.com (pierre bodilis) Date: Thu, 7 Sep 2006 11:57:24 +0200 Subject: [adasockets] More AdaSockets Message-ID: 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;