| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2021, 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; |
