1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . P O L L --
9 -- Copyright (C) 2020-2023, AdaCore --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
34 with GNAT
.Sockets
.Thin
;
36 package body GNAT
.Sockets
.Poll
is
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
42 procedure Set_Mode
(Item
: out Pollfd
; Mode
: Wait_Event_Set
);
43 -- Set I/O waiting mode on Item
46 (Item
: out Pollfd
; Event
: Wait_Event_Type
; Value
: Boolean);
47 -- Set or reset waiting state on I/O event
49 procedure Check_Range
(Self
: Set
; Index
: Positive) with Inline
;
50 -- raise Constraint_Error if Index is more than number of sockets in Self
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
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.
72 (Fds
: in out Set
; Timeout
: Interfaces
.C
.int
; Result
: out Integer)
79 function Create
(Size
: Positive) return Set
is
81 return Result
: Set
(Size
);
89 (Socket
: Socket_Type
;
90 Events
: Wait_Event_Set
;
91 Size
: Positive := 1) return Set
is
93 return Result
: Set
(Size
) do
94 Append
(Result
, Socket
, Events
);
103 (Self
: in out Set
; Socket
: Socket_Type
; Events
: Wait_Event_Set
) is
105 Insert
(Self
, Socket
, Events
, Self
.Length
+ 1);
114 Socket
: Socket_Type
;
115 Events
: Wait_Event_Set
;
117 Keep_Order
: Boolean := False) is
119 if Self
.Size
<= Self
.Length
then
120 raise Constraint_Error
with "Socket set is full";
122 elsif Index
> Self
.Length
+ 1 then
123 raise Constraint_Error
with "Insert out of range";
127 raise Socket_Error
with
128 "Wrong socket descriptor " & Socket_Type
'Image (Socket
);
131 Self
.Length
:= Self
.Length
+ 1;
133 if Index
/= Self
.Length
then
135 Self
.Fds
(Index
+ 1 .. Self
.Length
) :=
136 Self
.Fds
(Index
.. Self
.Length
- 1);
138 Self
.Fds
(Self
.Length
) := Self
.Fds
(Index
);
141 Self
.Fds
(Index
).Events
:= 0;
144 Self
.Fds
(Index
).Socket
:= FD_Type
(Socket
);
145 Set_Mode
(Self
.Fds
(Index
), Events
);
147 if FD_Type
(Socket
) > Self
.Max_FD
then
148 Self
.Max_FD
:= FD_Type
(Socket
);
157 procedure Check_Range
(Self
: Set
; Index
: Positive) is
159 if Index
> Self
.Length
then
160 raise Constraint_Error
;
168 procedure Copy
(Source
: Set
; Target
: out Set
) is
170 if Target
.Size
< Source
.Length
then
171 raise Constraint_Error
with
172 "Can't copy because size of target less than source length";
175 Target
.Fds
(1 .. Source
.Length
) := Source
.Fds
(1 .. Source
.Length
);
177 Target
.Length
:= Source
.Length
;
178 Target
.Max_FD
:= Source
.Max_FD
;
179 Target
.Max_OK
:= Source
.Max_OK
;
187 (Self
: Set
; Index
: Positive) return Wait_Event_Set
is
189 Check_Range
(Self
, Index
);
191 [Input
=> (Self
.Fds
(Index
).Events
and To_C
(Input
)) /= 0,
192 Output
=> (Self
.Fds
(Index
).Events
and To_C
(Output
)) /= 0];
199 function Growth
(Self
: Set
) return Set
is
206 when 51 .. 99 => Self
.Size
+ Self
.Size
/ 3,
207 when others => Self
.Size
+ Self
.Size
/ 4));
215 (Self
: in out Set
; Index
: Positive; Keep_Order
: Boolean := False) is
217 Check_Range
(Self
, Index
);
219 if Self
.Max_FD
= Self
.Fds
(Index
).Socket
then
220 Self
.Max_OK
:= False;
223 if Index
< Self
.Length
then
225 Self
.Fds
(Index
.. Self
.Length
- 1) :=
226 Self
.Fds
(Index
+ 1 .. Self
.Length
);
228 Self
.Fds
(Index
) := Self
.Fds
(Self
.Length
);
232 Self
.Length
:= Self
.Length
- 1;
239 function Resize
(Self
: Set
; Size
: Positive) return Set
is
241 return Result
: Set
(Size
) do
253 Event
: Wait_Event_Type
;
256 Check_Range
(Self
, Index
);
257 Set_Event
(Self
.Fds
(Index
), Event
, Value
);
261 (Item
: out Pollfd
; Event
: Wait_Event_Type
; Value
: Boolean) is
264 Item
.Events
:= Item
.Events
or To_C
(Event
);
266 Item
.Events
:= Item
.Events
and not To_C
(Event
);
277 Events
: Wait_Event_Set
) is
279 Check_Range
(Self
, Index
);
280 Set_Mode
(Self
.Fds
(Index
), Events
);
287 procedure Set_Mode
(Item
: out Pollfd
; Mode
: Wait_Event_Set
) is
289 for J
in Mode
'Range loop
290 Set_Event
(Item
, J
, Mode
(J
));
298 function Socket
(Self
: Set
; Index
: Positive) return Socket_Type
is
300 Check_Range
(Self
, Index
);
301 return Socket_Type
(Self
.Fds
(Index
).Socket
);
311 Socket
: out Socket_Type
;
312 Status
: out Event_Set
) is
314 Check_Range
(Self
, Index
);
315 Socket
:= Socket_Type
(Self
.Fds
(Index
).Socket
);
316 Status
:= Poll
.Status
(Self
.Fds
(Index
));
323 procedure Wait
(Self
: in out Set
; Timeout
: Duration; Count
: out Natural)
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.
331 Poll_Timeout
: Duration := Timeout
;
332 C_Timeout
: Interfaces
.C
.int
;
334 Stamp
: constant Time
:= Clock
;
336 if Self
.Length
= 0 then
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
354 C_Timeout
:= Interfaces
.C
.int
(Poll_Timeout
* 1_000
);
357 Wait
(Self
, C_Timeout
, Result
);
359 exit when Result
>= 0;
361 Errno
:= Thin
.Socket_Errno
;
363 -- In case of EINTR error we have to continue waiting for network
366 if Errno
= SOC
.EINTR
then
367 if C_Timeout
>= 0 then
368 Poll_Timeout
:= Timeout
- (Clock
- Stamp
);
370 if Poll_Timeout
< 0.0 then
373 elsif Poll_Timeout
> Timeout
then
374 -- Clock moved back in time. This should not be happen when
375 -- we use monotonic time.
377 Poll_Timeout
:= Timeout
;
382 Raise_Socket_Error
(Errno
);
393 procedure Next
(Self
: Set
; Index
: in out Natural) is
398 if Index
> Self
.Length
then
402 elsif Self
.Fds
(Index
).REvents
/= 0 then
412 function Status
(Self
: Set
; Index
: Positive) return Event_Set
is
414 Check_Range
(Self
, Index
);
415 return Status
(Self
.Fds
(Index
));
423 (Self
: Set
; Index
: Positive) return Interfaces
.C
.unsigned
is
425 Check_Range
(Self
, Index
);
426 return Interfaces
.C
.unsigned
(Self
.Fds
(Index
).REvents
);
429 end GNAT
.Sockets
.Poll
;