------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . P O L L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Calendar;
with GNAT.Sockets.Thin;
package body GNAT.Sockets.Poll is
To_C : constant array (Wait_Event_Type) of Events_Type :=
(Input => SOC.POLLIN or SOC.POLLPRI, Output => SOC.POLLOUT);
-- To convert Wait_Event_Type to C I/O events flags
procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set);
-- Set I/O waiting mode on Item
procedure Set_Event
(Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean);
-- Set or reset waiting state on I/O event
procedure Check_Range (Self : Set; Index : Positive) with Inline;
-- raise Constraint_Error if Index is more than number of sockets in Self
function Status (Item : Pollfd) return Event_Set is
(Input => (Item.REvents and To_C (Input)) /= 0,
Output => (Item.REvents and To_C (Output)) /= 0,
Error => (Item.REvents and SOC.POLLERR) /= 0,
Hang_Up => (Item.REvents and SOC.POLLHUP) /= 0,
Invalid_Request => (Item.REvents and SOC.POLLNVAL) /= 0);
-- Get I/O events from C word
procedure Wait
(Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer);
-- Waits until one or more of the sockets descriptors become ready for some
-- class of I/O operation or error state occurs on one or more of them.
-- Timeout is in milliseconds. Result mean how many sockets ready for I/O
-- or have error state.
----------
-- Wait --
----------
procedure Wait
(Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
is separate;
------------
-- Create --
------------
function Create (Size : Positive) return Set is
begin
return Result : Set (Size);
end Create;
------------
-- To_Set --
------------
function To_Set
(Socket : Socket_Type;
Events : Wait_Event_Set;
Size : Positive := 1) return Set is
begin
return Result : Set (Size) do
Append (Result, Socket, Events);
end return;
end To_Set;
------------
-- Append --
------------
procedure Append
(Self : in out Set; Socket : Socket_Type; Events : Wait_Event_Set) is
begin
Insert (Self, Socket, Events, Self.Length + 1);
end Append;
------------
-- Insert --
------------
procedure Insert
(Self : in out Set;
Socket : Socket_Type;
Events : Wait_Event_Set;
Index : Positive;
Keep_Order : Boolean := False) is
begin
if Self.Size <= Self.Length then
raise Constraint_Error with "Socket set is full";
elsif Index > Self.Length + 1 then
raise Constraint_Error with "Insert out of range";
end if;
if Socket < 0 then
raise Socket_Error with
"Wrong socket descriptor " & Socket_Type'Image (Socket);
end if;
Self.Length := Self.Length + 1;
if Index /= Self.Length then
if Keep_Order then
Self.Fds (Index + 1 .. Self.Length) :=
Self.Fds (Index .. Self.Length - 1);
else
Self.Fds (Self.Length) := Self.Fds (Index);
end if;
Self.Fds (Index).Events := 0;
end if;
Self.Fds (Index).Socket := FD_Type (Socket);
Set_Mode (Self.Fds (Index), Events);
if FD_Type (Socket) > Self.Max_FD then
Self.Max_FD := FD_Type (Socket);
Self.Max_OK := True;
end if;
end Insert;
-----------------
-- Check_Range --
-----------------
procedure Check_Range (Self : Set; Index : Positive) is
begin
if Index > Self.Length then
raise Constraint_Error;
end if;
end Check_Range;
----------
-- Copy --
----------
procedure Copy (Source : Set; Target : out Set) is
begin
if Target.Size < Source.Length then
raise Constraint_Error with
"Can't copy because size of target less than source length";
end if;
Target.Fds (1 .. Source.Length) := Source.Fds (1 .. Source.Length);
Target.Length := Source.Length;
Target.Max_FD := Source.Max_FD;
Target.Max_OK := Source.Max_OK;
end Copy;
----------------
-- Get_Events --
----------------
function Get_Events
(Self : Set; Index : Positive) return Wait_Event_Set is
begin
Check_Range (Self, Index);
return
(Input => (Self.Fds (Index).Events and To_C (Input)) /= 0,
Output => (Self.Fds (Index).Events and To_C (Output)) /= 0);
end Get_Events;
------------
-- Growth --
------------
function Growth (Self : Set) return Set is
begin
return Resize
(Self,
(case Self.Size is
when 1 .. 20 => 32,
when 21 .. 50 => 64,
when 51 .. 99 => Self.Size + Self.Size / 3,
when others => Self.Size + Self.Size / 4));
end Growth;
------------
-- Remove --
------------
procedure Remove
(Self : in out Set; Index : Positive; Keep_Order : Boolean := False) is
begin
Check_Range (Self, Index);
if Self.Max_FD = Self.Fds (Index).Socket then
Self.Max_OK := False;
end if;
if Index < Self.Length then
if Keep_Order then
Self.Fds (Index .. Self.Length - 1) :=
Self.Fds (Index + 1 .. Self.Length);
else
Self.Fds (Index) := Self.Fds (Self.Length);
end if;
end if;
Self.Length := Self.Length - 1;
end Remove;
------------
-- Resize --
------------
function Resize (Self : Set; Size : Positive) return Set is
begin
return Result : Set (Size) do
Copy (Self, Result);
end return;
end Resize;
---------------
-- Set_Event --
---------------
procedure Set_Event
(Self : in out Set;
Index : Positive;
Event : Wait_Event_Type;
Value : Boolean) is
begin
Check_Range (Self, Index);
Set_Event (Self.Fds (Index), Event, Value);
end Set_Event;
procedure Set_Event
(Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean) is
begin
if Value then
Item.Events := Item.Events or To_C (Event);
else
Item.Events := Item.Events and not To_C (Event);
end if;
end Set_Event;
----------------
-- Set_Events --
----------------
procedure Set_Events
(Self : in out Set;
Index : Positive;
Events : Wait_Event_Set) is
begin
Check_Range (Self, Index);
Set_Mode (Self.Fds (Index), Events);
end Set_Events;
--------------
-- Set_Mode --
--------------
procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set) is
begin
for J in Mode'Range loop
Set_Event (Item, J, Mode (J));
end loop;
end Set_Mode;
------------
-- Socket --
------------
function Socket (Self : Set; Index : Positive) return Socket_Type is
begin
Check_Range (Self, Index);
return Socket_Type (Self.Fds (Index).Socket);
end Socket;
-----------
-- State --
-----------
procedure State
(Self : Set;
Index : Positive;
Socket : out Socket_Type;
Status : out Event_Set) is
begin
Check_Range (Self, Index);
Socket := Socket_Type (Self.Fds (Index).Socket);
Status := Poll.Status (Self.Fds (Index));
end State;
----------
-- Wait --
----------
procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural)
is
use Ada.Calendar;
-- Used to calculate partially consumed timeout on EINTR.
-- Better to use Ada.Real_Time, but we can't in current GNAT because
-- Ada.Real_Time is in tasking part of runtime.
Result : Integer;
Poll_Timeout : Duration := Timeout;
C_Timeout : Interfaces.C.int;
Errno : Integer;
Stamp : constant Time := Clock;
begin
if Self.Length = 0 then
Count := 0;
return;
end if;
loop
if Poll_Timeout >= Duration (Interfaces.C.int'Last - 8) / 1_000 then
-- Minus 8 is to workaround Linux kernel 2.6.24 bug with close to
-- Integer'Last poll timeout values.
-- syscall (SYS_poll, &ufds, 1, 2147483644); // is waiting
-- syscall (SYS_poll, &ufds, 1, 2147483645); // is not waiting
-- Timeout values close to maximum could be not safe because of
-- possible time conversion boundary errors in the kernel.
-- Use unlimited timeout instead of maximum 24 days timeout for
-- safety reasons.
C_Timeout := -1;
else
C_Timeout := Interfaces.C.int (Poll_Timeout * 1_000);
end if;
Wait (Self, C_Timeout, Result);
exit when Result >= 0;
Errno := Thin.Socket_Errno;
-- In case of EINTR error we have to continue waiting for network
-- events.
if Errno = SOC.EINTR then
if C_Timeout >= 0 then
Poll_Timeout := Timeout - (Clock - Stamp);
if Poll_Timeout < 0.0 then
Poll_Timeout := 0.0;
elsif Poll_Timeout > Timeout then
-- Clock moved back in time. This should not be happen when
-- we use monotonic time.
Poll_Timeout := Timeout;
end if;
end if;
else
Raise_Socket_Error (Errno);
end if;
end loop;
Count := Result;
end Wait;
----------
-- Next --
----------
procedure Next (Self : Set; Index : in out Natural) is
begin
loop
Index := Index + 1;
if Index > Self.Length then
Index := 0;
return;
elsif Self.Fds (Index).REvents /= 0 then
return;
end if;
end loop;
end Next;
------------
-- Status --
------------
function Status (Self : Set; Index : Positive) return Event_Set is
begin
Check_Range (Self, Index);
return Status (Self.Fds (Index));
end Status;
--------------
-- C_Status --
--------------
function C_Status
(Self : Set; Index : Positive) return Interfaces.C.unsigned is
begin
Check_Range (Self, Index);
return Interfaces.C.unsigned (Self.Fds (Index).REvents);
end C_Status;
end GNAT.Sockets.Poll;