------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . S O C K E T S . P O L L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2020-2023, 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 -- -- . -- -- -- -- 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;