gcc/ada/libgnat/g-socpol.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                    G N A T . S O C K E T S . P O L L                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                       Copyright (C) 2020-2023, AdaCore                   --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Calendar;
  33
  34 with GNAT.Sockets.Thin;
  35
  36 package body GNAT.Sockets.Poll is
  37
  38    To_C : constant array (Wait_Event_Type) of Events_Type :=
  39             [Input => SOC.POLLIN or SOC.POLLPRI, Output => SOC.POLLOUT];
  40    --  To convert Wait_Event_Type to C I/O events flags
  41
  42    procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set);
  43    --  Set I/O waiting mode on Item
  44
  45    procedure Set_Event
  46      (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean);
  47    --  Set or reset waiting state on I/O event
  48
  49    procedure Check_Range (Self : Set; Index : Positive) with Inline;
  50    --  raise Constraint_Error if Index is more than number of sockets in Self
  51
  52    function Status (Item : Pollfd) return Event_Set is
  53      ([Input           => (Item.REvents and To_C (Input)) /= 0,
  54        Output          => (Item.REvents and To_C (Output)) /= 0,
  55        Error           => (Item.REvents and SOC.POLLERR) /= 0,
  56        Hang_Up         => (Item.REvents and SOC.POLLHUP) /= 0,
  57        Invalid_Request => (Item.REvents and SOC.POLLNVAL) /= 0]);
  58    --  Get I/O events from C word
  59
  60    procedure Wait
  61      (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer);
  62    --  Waits until one or more of the sockets descriptors become ready for some
  63    --  class of I/O operation or error state occurs on one or more of them.
  64    --  Timeout is in milliseconds. Result mean how many sockets ready for I/O
  65    --  or have error state.
  66
  67    ----------
  68    -- Wait --
  69    ----------
  70
  71    procedure Wait
  72      (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
  73    is separate;
  74
  75    ------------
  76    -- Create --
  77    ------------
  78
  79    function Create (Size : Positive) return Set is
  80    begin
  81       return Result : Set (Size);
  82    end Create;
  83
  84    ------------
  85    -- To_Set --
  86    ------------
  87
  88    function To_Set
  89      (Socket : Socket_Type;
  90       Events : Wait_Event_Set;
  91       Size   : Positive := 1) return Set is
  92    begin
  93       return Result : Set (Size) do
  94          Append (Result, Socket, Events);
  95       end return;
  96    end To_Set;
  97
  98    ------------
  99    -- Append --
 100    ------------
 101
 102    procedure Append
 103      (Self : in out Set; Socket : Socket_Type; Events : Wait_Event_Set) is
 104    begin
 105       Insert (Self, Socket, Events, Self.Length + 1);
 106    end Append;
 107
 108    ------------
 109    -- Insert --
 110    ------------
 111
 112    procedure Insert
 113      (Self       : in out Set;
 114       Socket     : Socket_Type;
 115       Events     : Wait_Event_Set;
 116       Index      : Positive;
 117       Keep_Order : Boolean := False) is
 118    begin
 119       if Self.Size <= Self.Length then
 120          raise Constraint_Error with "Socket set is full";
 121
 122       elsif Index > Self.Length + 1 then
 123          raise Constraint_Error with "Insert out of range";
 124       end if;
 125
 126       if Socket < 0 then
 127          raise Socket_Error with
 128            "Wrong socket descriptor " & Socket_Type'Image (Socket);
 129       end if;
 130
 131       Self.Length := Self.Length + 1;
 132
 133       if Index /= Self.Length then
 134          if Keep_Order then
 135             Self.Fds (Index + 1 .. Self.Length) :=
 136               Self.Fds (Index .. Self.Length - 1);
 137          else
 138             Self.Fds (Self.Length) := Self.Fds (Index);
 139          end if;
 140
 141          Self.Fds (Index).Events := 0;
 142       end if;
 143
 144       Self.Fds (Index).Socket := FD_Type (Socket);
 145       Set_Mode (Self.Fds (Index), Events);
 146
 147       if FD_Type (Socket) > Self.Max_FD then
 148          Self.Max_FD := FD_Type (Socket);
 149          Self.Max_OK := True;
 150       end if;
 151    end Insert;
 152
 153    -----------------
 154    -- Check_Range --
 155    -----------------
 156
 157    procedure Check_Range (Self : Set; Index : Positive) is
 158    begin
 159       if Index > Self.Length then
 160          raise Constraint_Error;
 161       end if;
 162    end Check_Range;
 163
 164    ----------
 165    -- Copy --
 166    ----------
 167
 168    procedure Copy (Source : Set; Target : out Set) is
 169    begin
 170       if Target.Size < Source.Length then
 171          raise Constraint_Error with
 172            "Can't copy because size of target less than source length";
 173       end if;
 174
 175       Target.Fds (1 .. Source.Length) := Source.Fds (1 .. Source.Length);
 176
 177       Target.Length := Source.Length;
 178       Target.Max_FD := Source.Max_FD;
 179       Target.Max_OK := Source.Max_OK;
 180    end Copy;
 181
 182    ----------------
 183    -- Get_Events --
 184    ----------------
 185
 186    function Get_Events
 187      (Self : Set; Index  : Positive) return Wait_Event_Set is
 188    begin
 189       Check_Range (Self, Index);
 190       return
 191         [Input  => (Self.Fds (Index).Events and To_C (Input)) /= 0,
 192          Output => (Self.Fds (Index).Events and To_C (Output)) /= 0];
 193    end Get_Events;
 194
 195    ------------
 196    -- Growth --
 197    ------------
 198
 199    function Growth (Self : Set) return Set is
 200    begin
 201       return Resize
 202         (Self,
 203          (case Self.Size is
 204              when 1  .. 20 => 32,
 205              when 21 .. 50 => 64,
 206              when 51 .. 99 => Self.Size + Self.Size / 3,
 207              when others   => Self.Size + Self.Size / 4));
 208    end Growth;
 209
 210    ------------
 211    -- Remove --
 212    ------------
 213
 214    procedure Remove
 215      (Self : in out Set; Index : Positive; Keep_Order : Boolean := False) is
 216    begin
 217       Check_Range (Self, Index);
 218
 219       if Self.Max_FD = Self.Fds (Index).Socket then
 220          Self.Max_OK := False;
 221       end if;
 222
 223       if Index < Self.Length then
 224          if Keep_Order then
 225             Self.Fds (Index .. Self.Length - 1) :=
 226               Self.Fds (Index + 1 .. Self.Length);
 227          else
 228             Self.Fds (Index) := Self.Fds (Self.Length);
 229          end if;
 230       end if;
 231
 232       Self.Length := Self.Length - 1;
 233    end Remove;
 234
 235    ------------
 236    -- Resize --
 237    ------------
 238
 239    function Resize (Self : Set; Size : Positive) return Set is
 240    begin
 241       return Result : Set (Size) do
 242          Copy (Self, Result);
 243       end return;
 244    end Resize;
 245
 246    ---------------
 247    -- Set_Event --
 248    ---------------
 249
 250    procedure Set_Event
 251      (Self  : in out Set;
 252       Index : Positive;
 253       Event : Wait_Event_Type;
 254       Value : Boolean) is
 255    begin
 256       Check_Range (Self, Index);
 257       Set_Event (Self.Fds (Index), Event, Value);
 258    end Set_Event;
 259
 260    procedure Set_Event
 261      (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean) is
 262    begin
 263       if Value then
 264          Item.Events := Item.Events or To_C (Event);
 265       else
 266          Item.Events := Item.Events and not To_C (Event);
 267       end if;
 268    end Set_Event;
 269
 270    ----------------
 271    -- Set_Events --
 272    ----------------
 273
 274    procedure Set_Events
 275      (Self   : in out Set;
 276       Index  : Positive;
 277       Events : Wait_Event_Set) is
 278    begin
 279       Check_Range (Self, Index);
 280       Set_Mode (Self.Fds (Index), Events);
 281    end Set_Events;
 282
 283    --------------
 284    -- Set_Mode --
 285    --------------
 286
 287    procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set) is
 288    begin
 289       for J in Mode'Range loop
 290          Set_Event (Item, J, Mode (J));
 291       end loop;
 292    end Set_Mode;
 293
 294    ------------
 295    -- Socket --
 296    ------------
 297
 298    function Socket (Self : Set; Index : Positive) return Socket_Type is
 299    begin
 300       Check_Range (Self, Index);
 301       return Socket_Type (Self.Fds (Index).Socket);
 302    end Socket;
 303
 304    -----------
 305    -- State --
 306    -----------
 307
 308    procedure State
 309      (Self   : Set;
 310       Index  : Positive;
 311       Socket : out Socket_Type;
 312       Status : out Event_Set) is
 313    begin
 314       Check_Range (Self, Index);
 315       Socket := Socket_Type (Self.Fds (Index).Socket);
 316       Status := Poll.Status (Self.Fds (Index));
 317    end State;
 318
 319    ----------
 320    -- Wait --
 321    ----------
 322
 323    procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural)
 324    is
 325       use Ada.Calendar;
 326       --  Used to calculate partially consumed timeout on EINTR.
 327       --  Better to use Ada.Real_Time, but we can't in current GNAT because
 328       --  Ada.Real_Time is in tasking part of runtime.
 329
 330       Result       : Integer;
 331       Poll_Timeout : Duration := Timeout;
 332       C_Timeout    : Interfaces.C.int;
 333       Errno        : Integer;
 334       Stamp        : constant Time := Clock;
 335    begin
 336       if Self.Length = 0 then
 337          Count := 0;
 338          return;
 339       end if;
 340
 341       loop
 342          if Poll_Timeout >= Duration (Interfaces.C.int'Last - 8) / 1_000 then
 343             --  Minus 8 is to workaround Linux kernel 2.6.24 bug with close to
 344             --  Integer'Last poll timeout values.
 345             --  syscall (SYS_poll, &ufds, 1, 2147483644); // is waiting
 346             --  syscall (SYS_poll, &ufds, 1, 2147483645); // is not waiting
 347             --  Timeout values close to maximum could be not safe because of
 348             --  possible time conversion boundary errors in the kernel.
 349             --  Use unlimited timeout instead of maximum 24 days timeout for
 350             --  safety reasons.
 351
 352             C_Timeout := -1;
 353          else
 354             C_Timeout := Interfaces.C.int (Poll_Timeout * 1_000);
 355          end if;
 356
 357          Wait (Self, C_Timeout, Result);
 358
 359          exit when Result >= 0;
 360
 361          Errno := Thin.Socket_Errno;
 362
 363          --  In case of EINTR error we have to continue waiting for network
 364          --  events.
 365
 366          if Errno = SOC.EINTR then
 367             if C_Timeout >= 0 then
 368                Poll_Timeout := Timeout - (Clock - Stamp);
 369
 370                if Poll_Timeout < 0.0 then
 371                   Poll_Timeout := 0.0;
 372
 373                elsif Poll_Timeout > Timeout then
 374                   --  Clock moved back in time. This should not be happen when
 375                   --  we use monotonic time.
 376
 377                   Poll_Timeout := Timeout;
 378                end if;
 379             end if;
 380
 381          else
 382             Raise_Socket_Error (Errno);
 383          end if;
 384       end loop;
 385
 386       Count := Result;
 387    end Wait;
 388
 389    ----------
 390    -- Next --
 391    ----------
 392
 393    procedure Next (Self : Set; Index : in out Natural) is
 394    begin
 395       loop
 396          Index := Index + 1;
 397
 398          if Index > Self.Length then
 399             Index := 0;
 400             return;
 401
 402          elsif Self.Fds (Index).REvents /= 0 then
 403             return;
 404          end if;
 405       end loop;
 406    end Next;
 407
 408    ------------
 409    -- Status --
 410    ------------
 411
 412    function Status (Self : Set; Index : Positive) return Event_Set is
 413    begin
 414       Check_Range (Self, Index);
 415       return Status (Self.Fds (Index));
 416    end Status;
 417
 418    --------------
 419    -- C_Status --
 420    --------------
 421
 422    function C_Status
 423      (Self : Set; Index : Positive) return Interfaces.C.unsigned is
 424    begin
 425       Check_Range (Self, Index);
 426       return Interfaces.C.unsigned (Self.Fds (Index).REvents);
 427    end C_Status;
 428
 429 end GNAT.Sockets.Poll;