|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . S O C K E T S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2001-2018, AdaCore --
|
|
111
|
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.Streams; use Ada.Streams;
|
|
|
33 with Ada.Exceptions; use Ada.Exceptions;
|
|
|
34 with Ada.Finalization;
|
|
|
35 with Ada.Unchecked_Conversion;
|
|
|
36
|
|
|
37 with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
|
|
|
38 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
|
|
|
39
|
|
|
40 with GNAT.Sockets.Linker_Options;
|
|
|
41 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
|
|
|
42 -- Need to include pragma Linker_Options which is platform dependent
|
|
|
43
|
|
|
44 with System; use System;
|
|
|
45 with System.Communication; use System.Communication;
|
|
|
46 with System.CRTL; use System.CRTL;
|
|
|
47 with System.Task_Lock;
|
|
|
48
|
|
|
49 package body GNAT.Sockets is
|
|
|
50
|
|
|
51 package C renames Interfaces.C;
|
|
|
52
|
|
|
53 ENOERROR : constant := 0;
|
|
|
54
|
|
|
55 Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
|
|
|
56 Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
|
|
|
57 -- The network database functions gethostbyname, gethostbyaddr,
|
|
|
58 -- getservbyname and getservbyport can either be guaranteed task safe by
|
|
|
59 -- the operating system, or else return data through a user-provided buffer
|
|
|
60 -- to ensure concurrent uses do not interfere.
|
|
|
61
|
|
|
62 -- Correspondence tables
|
|
|
63
|
|
|
64 Levels : constant array (Level_Type) of C.int :=
|
|
|
65 (Socket_Level => SOSC.SOL_SOCKET,
|
|
|
66 IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
|
|
|
67 IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
|
|
|
68 IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
|
|
|
69
|
|
|
70 Modes : constant array (Mode_Type) of C.int :=
|
|
|
71 (Socket_Stream => SOSC.SOCK_STREAM,
|
|
|
72 Socket_Datagram => SOSC.SOCK_DGRAM);
|
|
|
73
|
|
|
74 Shutmodes : constant array (Shutmode_Type) of C.int :=
|
|
|
75 (Shut_Read => SOSC.SHUT_RD,
|
|
|
76 Shut_Write => SOSC.SHUT_WR,
|
|
|
77 Shut_Read_Write => SOSC.SHUT_RDWR);
|
|
|
78
|
|
|
79 Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T :=
|
|
|
80 (Non_Blocking_IO => SOSC.FIONBIO,
|
|
|
81 N_Bytes_To_Read => SOSC.FIONREAD);
|
|
|
82
|
|
|
83 Options : constant array (Specific_Option_Name) of C.int :=
|
|
|
84 (Keep_Alive => SOSC.SO_KEEPALIVE,
|
|
|
85 Reuse_Address => SOSC.SO_REUSEADDR,
|
|
|
86 Broadcast => SOSC.SO_BROADCAST,
|
|
|
87 Send_Buffer => SOSC.SO_SNDBUF,
|
|
|
88 Receive_Buffer => SOSC.SO_RCVBUF,
|
|
|
89 Linger => SOSC.SO_LINGER,
|
|
|
90 Error => SOSC.SO_ERROR,
|
|
|
91 No_Delay => SOSC.TCP_NODELAY,
|
|
|
92 Add_Membership => SOSC.IP_ADD_MEMBERSHIP,
|
|
|
93 Drop_Membership => SOSC.IP_DROP_MEMBERSHIP,
|
|
|
94 Multicast_If => SOSC.IP_MULTICAST_IF,
|
|
|
95 Multicast_TTL => SOSC.IP_MULTICAST_TTL,
|
|
|
96 Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
|
|
|
97 Receive_Packet_Info => SOSC.IP_PKTINFO,
|
|
|
98 Send_Timeout => SOSC.SO_SNDTIMEO,
|
|
|
99 Receive_Timeout => SOSC.SO_RCVTIMEO,
|
|
|
100 Busy_Polling => SOSC.SO_BUSY_POLL);
|
|
|
101 -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
|
|
|
102 -- but for Linux compatibility this constant is the same as IP_PKTINFO.
|
|
|
103
|
|
|
104 Flags : constant array (0 .. 3) of C.int :=
|
|
|
105 (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
|
|
|
106 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
|
|
|
107 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
|
|
|
108 3 => SOSC.MSG_EOR); -- Send_End_Of_Record
|
|
|
109
|
|
|
110 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
|
|
|
111 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
|
|
|
112
|
|
|
113 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
|
|
|
114 -- Use to print in hexadecimal format
|
|
|
115
|
|
|
116 -----------------------
|
|
|
117 -- Local subprograms --
|
|
|
118 -----------------------
|
|
|
119
|
|
|
120 function Resolve_Error
|
|
|
121 (Error_Value : Integer;
|
|
|
122 From_Errno : Boolean := True) return Error_Type;
|
|
|
123 -- Associate an enumeration value (error_type) to an error value (errno).
|
|
|
124 -- From_Errno prevents from mixing h_errno with errno.
|
|
|
125
|
|
|
126 function To_Name (N : String) return Name_Type;
|
|
|
127 function To_String (HN : Name_Type) return String;
|
|
|
128 -- Conversion functions
|
|
|
129
|
|
|
130 function To_Int (F : Request_Flag_Type) return C.int;
|
|
|
131 -- Return the int value corresponding to the specified flags combination
|
|
|
132
|
|
|
133 function Set_Forced_Flags (F : C.int) return C.int;
|
|
|
134 -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
|
|
|
135
|
|
|
136 function Short_To_Network
|
|
|
137 (S : C.unsigned_short) return C.unsigned_short;
|
|
|
138 pragma Inline (Short_To_Network);
|
|
|
139 -- Convert a port number into a network port number
|
|
|
140
|
|
|
141 function Network_To_Short
|
|
|
142 (S : C.unsigned_short) return C.unsigned_short
|
|
|
143 renames Short_To_Network;
|
|
|
144 -- Symmetric operation
|
|
|
145
|
|
|
146 function Image
|
|
131
|
147 (Val : Inet_Addr_Bytes;
|
|
|
148 Hex : Boolean := False) return String;
|
|
111
|
149 -- Output an array of inet address components in hex or decimal mode
|
|
|
150
|
|
|
151 function Is_IP_Address (Name : String) return Boolean;
|
|
|
152 -- Return true when Name is an IPv4 address in dotted quad notation
|
|
|
153
|
|
|
154 procedure Netdb_Lock;
|
|
|
155 pragma Inline (Netdb_Lock);
|
|
|
156 procedure Netdb_Unlock;
|
|
|
157 pragma Inline (Netdb_Unlock);
|
|
|
158 -- Lock/unlock operation used to protect netdb access for platforms that
|
|
|
159 -- require such protection.
|
|
|
160
|
|
|
161 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
|
|
|
162 procedure To_Inet_Addr
|
|
|
163 (Addr : In_Addr;
|
|
|
164 Result : out Inet_Addr_Type);
|
|
|
165 -- Conversion functions
|
|
|
166
|
|
|
167 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type;
|
|
|
168 -- Conversion function
|
|
|
169
|
|
|
170 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
|
|
|
171 -- Conversion function
|
|
|
172
|
|
|
173 function Value (S : System.Address) return String;
|
|
|
174 -- Same as Interfaces.C.Strings.Value but taking a System.Address
|
|
|
175
|
|
|
176 function To_Timeval (Val : Timeval_Duration) return Timeval;
|
|
|
177 -- Separate Val in seconds and microseconds
|
|
|
178
|
|
|
179 function To_Duration (Val : Timeval) return Timeval_Duration;
|
|
|
180 -- Reconstruct a Duration value from a Timeval record (seconds and
|
|
|
181 -- microseconds).
|
|
|
182
|
|
|
183 procedure Raise_Socket_Error (Error : Integer);
|
|
|
184 -- Raise Socket_Error with an exception message describing the error code
|
|
|
185 -- from errno.
|
|
|
186
|
|
|
187 procedure Raise_Host_Error (H_Error : Integer; Name : String);
|
|
|
188 -- Raise Host_Error exception with message describing error code (note
|
|
|
189 -- hstrerror seems to be obsolete) from h_errno. Name is the name
|
|
|
190 -- or address that was being looked up.
|
|
|
191
|
|
|
192 procedure Narrow (Item : in out Socket_Set_Type);
|
|
|
193 -- Update Last as it may be greater than the real last socket
|
|
|
194
|
|
|
195 procedure Check_For_Fd_Set (Fd : Socket_Type);
|
|
|
196 pragma Inline (Check_For_Fd_Set);
|
|
|
197 -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to
|
|
|
198 -- FD_SETSIZE, on platforms where fd_set is a bitmap.
|
|
|
199
|
|
|
200 function Connect_Socket
|
|
|
201 (Socket : Socket_Type;
|
|
|
202 Server : Sock_Addr_Type) return C.int;
|
|
|
203 pragma Inline (Connect_Socket);
|
|
|
204 -- Underlying implementation for the Connect_Socket procedures
|
|
|
205
|
|
|
206 -- Types needed for Datagram_Socket_Stream_Type
|
|
|
207
|
|
|
208 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
|
|
|
209 Socket : Socket_Type;
|
|
|
210 To : Sock_Addr_Type;
|
|
|
211 From : Sock_Addr_Type;
|
|
|
212 end record;
|
|
|
213
|
|
|
214 type Datagram_Socket_Stream_Access is
|
|
|
215 access all Datagram_Socket_Stream_Type;
|
|
|
216
|
|
|
217 procedure Read
|
|
|
218 (Stream : in out Datagram_Socket_Stream_Type;
|
|
|
219 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
220 Last : out Ada.Streams.Stream_Element_Offset);
|
|
|
221
|
|
|
222 procedure Write
|
|
|
223 (Stream : in out Datagram_Socket_Stream_Type;
|
|
|
224 Item : Ada.Streams.Stream_Element_Array);
|
|
|
225
|
|
|
226 -- Types needed for Stream_Socket_Stream_Type
|
|
|
227
|
|
|
228 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
|
|
|
229 Socket : Socket_Type;
|
|
|
230 end record;
|
|
|
231
|
|
|
232 type Stream_Socket_Stream_Access is
|
|
|
233 access all Stream_Socket_Stream_Type;
|
|
|
234
|
|
|
235 procedure Read
|
|
|
236 (Stream : in out Stream_Socket_Stream_Type;
|
|
|
237 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
238 Last : out Ada.Streams.Stream_Element_Offset);
|
|
|
239
|
|
|
240 procedure Write
|
|
|
241 (Stream : in out Stream_Socket_Stream_Type;
|
|
|
242 Item : Ada.Streams.Stream_Element_Array);
|
|
|
243
|
|
|
244 procedure Wait_On_Socket
|
|
|
245 (Socket : Socket_Type;
|
|
|
246 For_Read : Boolean;
|
|
|
247 Timeout : Selector_Duration;
|
|
|
248 Selector : access Selector_Type := null;
|
|
|
249 Status : out Selector_Status);
|
|
|
250 -- Common code for variants of socket operations supporting a timeout:
|
|
|
251 -- block in Check_Selector on Socket for at most the indicated timeout.
|
|
|
252 -- If For_Read is True, Socket is added to the read set for this call, else
|
|
|
253 -- it is added to the write set. If no selector is provided, a local one is
|
|
|
254 -- created for this call and destroyed prior to returning.
|
|
|
255
|
|
|
256 type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
|
|
|
257 with null record;
|
|
|
258 -- This type is used to generate automatic calls to Initialize and Finalize
|
|
|
259 -- during the elaboration and finalization of this package. A single object
|
|
|
260 -- of this type must exist at library level.
|
|
|
261
|
|
|
262 function Err_Code_Image (E : Integer) return String;
|
|
|
263 -- Return the value of E surrounded with brackets
|
|
|
264
|
|
|
265 procedure Initialize (X : in out Sockets_Library_Controller);
|
|
|
266 procedure Finalize (X : in out Sockets_Library_Controller);
|
|
|
267
|
|
|
268 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
|
|
|
269 -- If S is the empty set (detected by Last = No_Socket), make sure its
|
|
|
270 -- fd_set component is actually cleared. Note that the case where it is
|
|
|
271 -- not can occur for an uninitialized Socket_Set_Type object.
|
|
|
272
|
|
|
273 function Is_Open (S : Selector_Type) return Boolean;
|
|
|
274 -- Return True for an "open" Selector_Type object, i.e. one for which
|
|
|
275 -- Create_Selector has been called and Close_Selector has not been called,
|
|
|
276 -- or the null selector.
|
|
|
277
|
|
131
|
278 function Create_Address
|
|
|
279 (Family : Family_Type; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
|
|
|
280 with Inline;
|
|
|
281 -- Creates address from family and Inet_Addr_Bytes array.
|
|
|
282
|
|
|
283 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes
|
|
|
284 with Inline;
|
|
|
285 -- Extract bytes from address
|
|
|
286
|
|
111
|
287 ---------
|
|
|
288 -- "+" --
|
|
|
289 ---------
|
|
|
290
|
|
|
291 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
|
|
|
292 begin
|
|
|
293 return L or R;
|
|
|
294 end "+";
|
|
|
295
|
|
|
296 --------------------
|
|
|
297 -- Abort_Selector --
|
|
|
298 --------------------
|
|
|
299
|
|
|
300 procedure Abort_Selector (Selector : Selector_Type) is
|
|
|
301 Res : C.int;
|
|
|
302
|
|
|
303 begin
|
|
|
304 if not Is_Open (Selector) then
|
|
|
305 raise Program_Error with "closed selector";
|
|
|
306
|
|
|
307 elsif Selector.Is_Null then
|
|
|
308 raise Program_Error with "null selector";
|
|
|
309
|
|
|
310 end if;
|
|
|
311
|
|
|
312 -- Send one byte to unblock select system call
|
|
|
313
|
|
|
314 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
|
|
|
315
|
|
|
316 if Res = Failure then
|
|
|
317 Raise_Socket_Error (Socket_Errno);
|
|
|
318 end if;
|
|
|
319 end Abort_Selector;
|
|
|
320
|
|
|
321 -------------------
|
|
|
322 -- Accept_Socket --
|
|
|
323 -------------------
|
|
|
324
|
|
|
325 procedure Accept_Socket
|
|
|
326 (Server : Socket_Type;
|
|
|
327 Socket : out Socket_Type;
|
|
|
328 Address : out Sock_Addr_Type)
|
|
|
329 is
|
|
|
330 Res : C.int;
|
|
|
331 Sin : aliased Sockaddr_In;
|
|
|
332 Len : aliased C.int := Sin'Size / 8;
|
|
|
333
|
|
|
334 begin
|
|
|
335 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
|
|
|
336
|
|
|
337 if Res = Failure then
|
|
|
338 Raise_Socket_Error (Socket_Errno);
|
|
|
339 end if;
|
|
|
340
|
|
|
341 Socket := Socket_Type (Res);
|
|
|
342
|
|
|
343 To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
|
|
|
344 Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
|
|
|
345 end Accept_Socket;
|
|
|
346
|
|
|
347 -------------------
|
|
|
348 -- Accept_Socket --
|
|
|
349 -------------------
|
|
|
350
|
|
|
351 procedure Accept_Socket
|
|
|
352 (Server : Socket_Type;
|
|
|
353 Socket : out Socket_Type;
|
|
|
354 Address : out Sock_Addr_Type;
|
|
|
355 Timeout : Selector_Duration;
|
|
|
356 Selector : access Selector_Type := null;
|
|
|
357 Status : out Selector_Status)
|
|
|
358 is
|
|
|
359 begin
|
|
|
360 if Selector /= null and then not Is_Open (Selector.all) then
|
|
|
361 raise Program_Error with "closed selector";
|
|
|
362 end if;
|
|
|
363
|
|
|
364 -- Wait for socket to become available for reading
|
|
|
365
|
|
|
366 Wait_On_Socket
|
|
|
367 (Socket => Server,
|
|
|
368 For_Read => True,
|
|
|
369 Timeout => Timeout,
|
|
|
370 Selector => Selector,
|
|
|
371 Status => Status);
|
|
|
372
|
|
|
373 -- Accept connection if available
|
|
|
374
|
|
|
375 if Status = Completed then
|
|
|
376 Accept_Socket (Server, Socket, Address);
|
|
|
377 else
|
|
|
378 Socket := No_Socket;
|
|
|
379 end if;
|
|
|
380 end Accept_Socket;
|
|
|
381
|
|
|
382 ---------------
|
|
|
383 -- Addresses --
|
|
|
384 ---------------
|
|
|
385
|
|
|
386 function Addresses
|
|
|
387 (E : Host_Entry_Type;
|
|
|
388 N : Positive := 1) return Inet_Addr_Type
|
|
|
389 is
|
|
|
390 begin
|
|
|
391 return E.Addresses (N);
|
|
|
392 end Addresses;
|
|
|
393
|
|
|
394 ----------------------
|
|
|
395 -- Addresses_Length --
|
|
|
396 ----------------------
|
|
|
397
|
|
|
398 function Addresses_Length (E : Host_Entry_Type) return Natural is
|
|
|
399 begin
|
|
|
400 return E.Addresses_Length;
|
|
|
401 end Addresses_Length;
|
|
|
402
|
|
|
403 -------------
|
|
|
404 -- Aliases --
|
|
|
405 -------------
|
|
|
406
|
|
|
407 function Aliases
|
|
|
408 (E : Host_Entry_Type;
|
|
|
409 N : Positive := 1) return String
|
|
|
410 is
|
|
|
411 begin
|
|
|
412 return To_String (E.Aliases (N));
|
|
|
413 end Aliases;
|
|
|
414
|
|
|
415 -------------
|
|
|
416 -- Aliases --
|
|
|
417 -------------
|
|
|
418
|
|
|
419 function Aliases
|
|
|
420 (S : Service_Entry_Type;
|
|
|
421 N : Positive := 1) return String
|
|
|
422 is
|
|
|
423 begin
|
|
|
424 return To_String (S.Aliases (N));
|
|
|
425 end Aliases;
|
|
|
426
|
|
|
427 --------------------
|
|
|
428 -- Aliases_Length --
|
|
|
429 --------------------
|
|
|
430
|
|
|
431 function Aliases_Length (E : Host_Entry_Type) return Natural is
|
|
|
432 begin
|
|
|
433 return E.Aliases_Length;
|
|
|
434 end Aliases_Length;
|
|
|
435
|
|
|
436 --------------------
|
|
|
437 -- Aliases_Length --
|
|
|
438 --------------------
|
|
|
439
|
|
|
440 function Aliases_Length (S : Service_Entry_Type) return Natural is
|
|
|
441 begin
|
|
|
442 return S.Aliases_Length;
|
|
|
443 end Aliases_Length;
|
|
|
444
|
|
|
445 -----------------
|
|
|
446 -- Bind_Socket --
|
|
|
447 -----------------
|
|
|
448
|
|
|
449 procedure Bind_Socket
|
|
|
450 (Socket : Socket_Type;
|
|
|
451 Address : Sock_Addr_Type)
|
|
|
452 is
|
|
|
453 Res : C.int;
|
|
|
454 Sin : aliased Sockaddr_In;
|
|
|
455 Len : constant C.int := Sin'Size / 8;
|
|
|
456 -- This assumes that Address.Family = Family_Inet???
|
|
|
457
|
|
|
458 begin
|
|
|
459 if Address.Family = Family_Inet6 then
|
|
|
460 raise Socket_Error with "IPv6 not supported";
|
|
|
461 end if;
|
|
|
462
|
|
|
463 Set_Family (Sin.Sin_Family, Address.Family);
|
|
|
464 Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
|
|
|
465 Set_Port
|
|
|
466 (Sin'Unchecked_Access,
|
|
|
467 Short_To_Network (C.unsigned_short (Address.Port)));
|
|
|
468
|
|
|
469 Res := C_Bind (C.int (Socket), Sin'Address, Len);
|
|
|
470
|
|
|
471 if Res = Failure then
|
|
|
472 Raise_Socket_Error (Socket_Errno);
|
|
|
473 end if;
|
|
|
474 end Bind_Socket;
|
|
|
475
|
|
|
476 ----------------------
|
|
|
477 -- Check_For_Fd_Set --
|
|
|
478 ----------------------
|
|
|
479
|
|
|
480 procedure Check_For_Fd_Set (Fd : Socket_Type) is
|
|
|
481 use SOSC;
|
|
|
482
|
|
|
483 begin
|
|
|
484 -- On Windows, fd_set is a FD_SETSIZE array of socket ids:
|
|
|
485 -- no check required. Warnings suppressed because condition
|
|
|
486 -- is known at compile time.
|
|
|
487
|
|
|
488 if Target_OS = Windows then
|
|
|
489
|
|
|
490 return;
|
|
|
491
|
|
|
492 -- On other platforms, fd_set is an FD_SETSIZE bitmap: check
|
|
|
493 -- that Fd is within range (otherwise behavior is undefined).
|
|
|
494
|
|
|
495 elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
|
|
|
496 raise Constraint_Error
|
|
|
497 with "invalid value for socket set: " & Image (Fd);
|
|
|
498 end if;
|
|
|
499 end Check_For_Fd_Set;
|
|
|
500
|
|
|
501 --------------------
|
|
|
502 -- Check_Selector --
|
|
|
503 --------------------
|
|
|
504
|
|
|
505 procedure Check_Selector
|
|
|
506 (Selector : Selector_Type;
|
|
|
507 R_Socket_Set : in out Socket_Set_Type;
|
|
|
508 W_Socket_Set : in out Socket_Set_Type;
|
|
|
509 Status : out Selector_Status;
|
|
|
510 Timeout : Selector_Duration := Forever)
|
|
|
511 is
|
|
|
512 E_Socket_Set : Socket_Set_Type;
|
|
|
513 begin
|
|
|
514 Check_Selector
|
|
|
515 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
|
|
|
516 end Check_Selector;
|
|
|
517
|
|
|
518 procedure Check_Selector
|
|
|
519 (Selector : Selector_Type;
|
|
|
520 R_Socket_Set : in out Socket_Set_Type;
|
|
|
521 W_Socket_Set : in out Socket_Set_Type;
|
|
|
522 E_Socket_Set : in out Socket_Set_Type;
|
|
|
523 Status : out Selector_Status;
|
|
|
524 Timeout : Selector_Duration := Forever)
|
|
|
525 is
|
|
|
526 Res : C.int;
|
|
|
527 Last : C.int;
|
|
|
528 RSig : Socket_Type := No_Socket;
|
|
|
529 TVal : aliased Timeval;
|
|
|
530 TPtr : Timeval_Access;
|
|
|
531
|
|
|
532 begin
|
|
|
533 if not Is_Open (Selector) then
|
|
|
534 raise Program_Error with "closed selector";
|
|
|
535 end if;
|
|
|
536
|
|
|
537 Status := Completed;
|
|
|
538
|
|
|
539 -- No timeout or Forever is indicated by a null timeval pointer
|
|
|
540
|
|
|
541 if Timeout = Forever then
|
|
|
542 TPtr := null;
|
|
|
543 else
|
|
|
544 TVal := To_Timeval (Timeout);
|
|
|
545 TPtr := TVal'Unchecked_Access;
|
|
|
546 end if;
|
|
|
547
|
|
|
548 -- Add read signalling socket, if present
|
|
|
549
|
|
|
550 if not Selector.Is_Null then
|
|
|
551 RSig := Selector.R_Sig_Socket;
|
|
|
552 Set (R_Socket_Set, RSig);
|
|
|
553 end if;
|
|
|
554
|
|
|
555 Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
|
|
|
556 C.int (W_Socket_Set.Last)),
|
|
|
557 C.int (E_Socket_Set.Last));
|
|
|
558
|
|
|
559 -- Zero out fd_set for empty Socket_Set_Type objects
|
|
|
560
|
|
|
561 Normalize_Empty_Socket_Set (R_Socket_Set);
|
|
|
562 Normalize_Empty_Socket_Set (W_Socket_Set);
|
|
|
563 Normalize_Empty_Socket_Set (E_Socket_Set);
|
|
|
564
|
|
|
565 Res :=
|
|
|
566 C_Select
|
|
|
567 (Last + 1,
|
|
|
568 R_Socket_Set.Set'Access,
|
|
|
569 W_Socket_Set.Set'Access,
|
|
|
570 E_Socket_Set.Set'Access,
|
|
|
571 TPtr);
|
|
|
572
|
|
|
573 if Res = Failure then
|
|
|
574 Raise_Socket_Error (Socket_Errno);
|
|
|
575 end if;
|
|
|
576
|
|
|
577 -- If Select was resumed because of read signalling socket, read this
|
|
|
578 -- data and remove socket from set.
|
|
|
579
|
|
|
580 if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then
|
|
|
581 Clear (R_Socket_Set, RSig);
|
|
|
582
|
|
|
583 Res := Signalling_Fds.Read (C.int (RSig));
|
|
|
584
|
|
|
585 if Res = Failure then
|
|
|
586 Raise_Socket_Error (Socket_Errno);
|
|
|
587 end if;
|
|
|
588
|
|
|
589 Status := Aborted;
|
|
|
590
|
|
|
591 elsif Res = 0 then
|
|
|
592 Status := Expired;
|
|
|
593 end if;
|
|
|
594
|
|
|
595 -- Update socket sets in regard to their new contents
|
|
|
596
|
|
|
597 Narrow (R_Socket_Set);
|
|
|
598 Narrow (W_Socket_Set);
|
|
|
599 Narrow (E_Socket_Set);
|
|
|
600 end Check_Selector;
|
|
|
601
|
|
|
602 -----------
|
|
|
603 -- Clear --
|
|
|
604 -----------
|
|
|
605
|
|
|
606 procedure Clear
|
|
|
607 (Item : in out Socket_Set_Type;
|
|
|
608 Socket : Socket_Type)
|
|
|
609 is
|
|
|
610 Last : aliased C.int := C.int (Item.Last);
|
|
|
611
|
|
|
612 begin
|
|
|
613 Check_For_Fd_Set (Socket);
|
|
|
614
|
|
|
615 if Item.Last /= No_Socket then
|
|
|
616 Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
|
|
|
617 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
|
|
|
618 Item.Last := Socket_Type (Last);
|
|
|
619 end if;
|
|
|
620 end Clear;
|
|
|
621
|
|
|
622 --------------------
|
|
|
623 -- Close_Selector --
|
|
|
624 --------------------
|
|
|
625
|
|
|
626 procedure Close_Selector (Selector : in out Selector_Type) is
|
|
|
627 begin
|
|
|
628 -- Nothing to do if selector already in closed state
|
|
|
629
|
|
|
630 if Selector.Is_Null or else not Is_Open (Selector) then
|
|
|
631 return;
|
|
|
632 end if;
|
|
|
633
|
|
|
634 -- Close the signalling file descriptors used internally for the
|
|
|
635 -- implementation of Abort_Selector.
|
|
|
636
|
|
|
637 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
|
|
|
638 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
|
|
|
639
|
|
|
640 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
|
|
|
641 -- (erroneous) subsequent attempt to use this selector properly fails.
|
|
|
642
|
|
|
643 Selector.R_Sig_Socket := No_Socket;
|
|
|
644 Selector.W_Sig_Socket := No_Socket;
|
|
|
645 end Close_Selector;
|
|
|
646
|
|
|
647 ------------------
|
|
|
648 -- Close_Socket --
|
|
|
649 ------------------
|
|
|
650
|
|
|
651 procedure Close_Socket (Socket : Socket_Type) is
|
|
|
652 Res : C.int;
|
|
|
653
|
|
|
654 begin
|
|
|
655 Res := C_Close (C.int (Socket));
|
|
|
656
|
|
|
657 if Res = Failure then
|
|
|
658 Raise_Socket_Error (Socket_Errno);
|
|
|
659 end if;
|
|
|
660 end Close_Socket;
|
|
|
661
|
|
|
662 --------------------
|
|
|
663 -- Connect_Socket --
|
|
|
664 --------------------
|
|
|
665
|
|
|
666 function Connect_Socket
|
|
|
667 (Socket : Socket_Type;
|
|
|
668 Server : Sock_Addr_Type) return C.int
|
|
|
669 is
|
|
|
670 Sin : aliased Sockaddr_In;
|
|
|
671 Len : constant C.int := Sin'Size / 8;
|
|
|
672
|
|
|
673 begin
|
|
|
674 if Server.Family = Family_Inet6 then
|
|
|
675 raise Socket_Error with "IPv6 not supported";
|
|
|
676 end if;
|
|
|
677
|
|
|
678 Set_Family (Sin.Sin_Family, Server.Family);
|
|
|
679 Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
|
|
|
680 Set_Port
|
|
|
681 (Sin'Unchecked_Access,
|
|
|
682 Short_To_Network (C.unsigned_short (Server.Port)));
|
|
|
683
|
|
|
684 return C_Connect (C.int (Socket), Sin'Address, Len);
|
|
|
685 end Connect_Socket;
|
|
|
686
|
|
|
687 procedure Connect_Socket
|
|
|
688 (Socket : Socket_Type;
|
|
|
689 Server : Sock_Addr_Type)
|
|
|
690 is
|
|
|
691 begin
|
|
|
692 if Connect_Socket (Socket, Server) = Failure then
|
|
|
693 Raise_Socket_Error (Socket_Errno);
|
|
|
694 end if;
|
|
|
695 end Connect_Socket;
|
|
|
696
|
|
|
697 procedure Connect_Socket
|
|
|
698 (Socket : Socket_Type;
|
|
|
699 Server : Sock_Addr_Type;
|
|
|
700 Timeout : Selector_Duration;
|
|
|
701 Selector : access Selector_Type := null;
|
|
|
702 Status : out Selector_Status)
|
|
|
703 is
|
|
|
704 Req : Request_Type;
|
|
|
705 -- Used to set Socket to non-blocking I/O
|
|
|
706
|
|
|
707 Conn_Err : aliased Integer;
|
|
|
708 -- Error status of the socket after completion of select(2)
|
|
|
709
|
|
|
710 Res : C.int;
|
|
|
711 Conn_Err_Size : aliased C.int := Conn_Err'Size / 8;
|
|
|
712 -- For getsockopt(2) call
|
|
|
713
|
|
|
714 begin
|
|
|
715 if Selector /= null and then not Is_Open (Selector.all) then
|
|
|
716 raise Program_Error with "closed selector";
|
|
|
717 end if;
|
|
|
718
|
|
|
719 -- Set the socket to non-blocking I/O
|
|
|
720
|
|
|
721 Req := (Name => Non_Blocking_IO, Enabled => True);
|
|
|
722 Control_Socket (Socket, Request => Req);
|
|
|
723
|
|
|
724 -- Start operation (non-blocking), will return Failure with errno set
|
|
|
725 -- to EINPROGRESS.
|
|
|
726
|
|
|
727 Res := Connect_Socket (Socket, Server);
|
|
|
728 if Res = Failure then
|
|
|
729 Conn_Err := Socket_Errno;
|
|
|
730 if Conn_Err /= SOSC.EINPROGRESS then
|
|
|
731 Raise_Socket_Error (Conn_Err);
|
|
|
732 end if;
|
|
|
733 end if;
|
|
|
734
|
|
|
735 -- Wait for socket to become available for writing (unless the Timeout
|
|
|
736 -- is zero, in which case we consider that it has already expired, and
|
|
|
737 -- we do not need to wait at all).
|
|
|
738
|
|
|
739 if Timeout = 0.0 then
|
|
|
740 Status := Expired;
|
|
|
741
|
|
|
742 else
|
|
|
743 Wait_On_Socket
|
|
|
744 (Socket => Socket,
|
|
|
745 For_Read => False,
|
|
|
746 Timeout => Timeout,
|
|
|
747 Selector => Selector,
|
|
|
748 Status => Status);
|
|
|
749 end if;
|
|
|
750
|
|
|
751 -- Check error condition (the asynchronous connect may have terminated
|
|
|
752 -- with an error, e.g. ECONNREFUSED) if select(2) completed.
|
|
|
753
|
|
|
754 if Status = Completed then
|
|
|
755 Res := C_Getsockopt
|
|
|
756 (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR,
|
|
|
757 Conn_Err'Address, Conn_Err_Size'Access);
|
|
|
758
|
|
|
759 if Res /= 0 then
|
|
|
760 Conn_Err := Socket_Errno;
|
|
|
761 end if;
|
|
|
762
|
|
|
763 else
|
|
|
764 Conn_Err := 0;
|
|
|
765 end if;
|
|
|
766
|
|
|
767 -- Reset the socket to blocking I/O
|
|
|
768
|
|
|
769 Req := (Name => Non_Blocking_IO, Enabled => False);
|
|
|
770 Control_Socket (Socket, Request => Req);
|
|
|
771
|
|
|
772 -- Report error condition if any
|
|
|
773
|
|
|
774 if Conn_Err /= 0 then
|
|
|
775 Raise_Socket_Error (Conn_Err);
|
|
|
776 end if;
|
|
|
777 end Connect_Socket;
|
|
|
778
|
|
|
779 --------------------
|
|
|
780 -- Control_Socket --
|
|
|
781 --------------------
|
|
|
782
|
|
|
783 procedure Control_Socket
|
|
|
784 (Socket : Socket_Type;
|
|
|
785 Request : in out Request_Type)
|
|
|
786 is
|
|
|
787 Arg : aliased C.int;
|
|
|
788 Res : C.int;
|
|
|
789
|
|
|
790 begin
|
|
|
791 case Request.Name is
|
|
|
792 when Non_Blocking_IO =>
|
|
|
793 Arg := C.int (Boolean'Pos (Request.Enabled));
|
|
|
794
|
|
|
795 when N_Bytes_To_Read =>
|
|
|
796 null;
|
|
|
797 end case;
|
|
|
798
|
|
|
799 Res := Socket_Ioctl
|
|
|
800 (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
|
|
|
801
|
|
|
802 if Res = Failure then
|
|
|
803 Raise_Socket_Error (Socket_Errno);
|
|
|
804 end if;
|
|
|
805
|
|
|
806 case Request.Name is
|
|
|
807 when Non_Blocking_IO =>
|
|
|
808 null;
|
|
|
809
|
|
|
810 when N_Bytes_To_Read =>
|
|
|
811 Request.Size := Natural (Arg);
|
|
|
812 end case;
|
|
|
813 end Control_Socket;
|
|
|
814
|
|
|
815 ----------
|
|
|
816 -- Copy --
|
|
|
817 ----------
|
|
|
818
|
|
|
819 procedure Copy
|
|
|
820 (Source : Socket_Set_Type;
|
|
|
821 Target : out Socket_Set_Type)
|
|
|
822 is
|
|
|
823 begin
|
|
|
824 Target := Source;
|
|
|
825 end Copy;
|
|
|
826
|
|
|
827 ---------------------
|
|
|
828 -- Create_Selector --
|
|
|
829 ---------------------
|
|
|
830
|
|
|
831 procedure Create_Selector (Selector : out Selector_Type) is
|
|
|
832 Two_Fds : aliased Fd_Pair;
|
|
|
833 Res : C.int;
|
|
|
834
|
|
|
835 begin
|
|
|
836 if Is_Open (Selector) then
|
|
|
837 -- Raise exception to prevent socket descriptor leak
|
|
|
838
|
|
|
839 raise Program_Error with "selector already open";
|
|
|
840 end if;
|
|
|
841
|
|
|
842 -- We open two signalling file descriptors. One of them is used to send
|
|
|
843 -- data to the other, which is included in a C_Select socket set. The
|
|
|
844 -- communication is used to force a call to C_Select to complete, and
|
|
|
845 -- the waiting task to resume its execution.
|
|
|
846
|
|
|
847 Res := Signalling_Fds.Create (Two_Fds'Access);
|
|
|
848
|
|
|
849 if Res = Failure then
|
|
|
850 Raise_Socket_Error (Socket_Errno);
|
|
|
851 end if;
|
|
|
852
|
|
|
853 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
|
|
|
854 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
|
|
|
855 end Create_Selector;
|
|
|
856
|
|
|
857 -------------------
|
|
|
858 -- Create_Socket --
|
|
|
859 -------------------
|
|
|
860
|
|
|
861 procedure Create_Socket
|
|
|
862 (Socket : out Socket_Type;
|
|
|
863 Family : Family_Type := Family_Inet;
|
|
|
864 Mode : Mode_Type := Socket_Stream)
|
|
|
865 is
|
|
|
866 Res : C.int;
|
|
|
867
|
|
|
868 begin
|
|
|
869 Res := C_Socket (Families (Family), Modes (Mode), 0);
|
|
|
870
|
|
|
871 if Res = Failure then
|
|
|
872 Raise_Socket_Error (Socket_Errno);
|
|
|
873 end if;
|
|
|
874
|
|
|
875 Socket := Socket_Type (Res);
|
|
|
876 end Create_Socket;
|
|
|
877
|
|
|
878 -----------
|
|
|
879 -- Empty --
|
|
|
880 -----------
|
|
|
881
|
|
|
882 procedure Empty (Item : out Socket_Set_Type) is
|
|
|
883 begin
|
|
|
884 Reset_Socket_Set (Item.Set'Access);
|
|
|
885 Item.Last := No_Socket;
|
|
|
886 end Empty;
|
|
|
887
|
|
|
888 --------------------
|
|
|
889 -- Err_Code_Image --
|
|
|
890 --------------------
|
|
|
891
|
|
|
892 function Err_Code_Image (E : Integer) return String is
|
|
|
893 Msg : String := E'Img & "] ";
|
|
|
894 begin
|
|
|
895 Msg (Msg'First) := '[';
|
|
|
896 return Msg;
|
|
|
897 end Err_Code_Image;
|
|
|
898
|
|
|
899 --------------
|
|
|
900 -- Finalize --
|
|
|
901 --------------
|
|
|
902
|
|
|
903 procedure Finalize (X : in out Sockets_Library_Controller) is
|
|
|
904 pragma Unreferenced (X);
|
|
|
905
|
|
|
906 begin
|
|
|
907 -- Finalization operation for the GNAT.Sockets package
|
|
|
908
|
|
|
909 Thin.Finalize;
|
|
|
910 end Finalize;
|
|
|
911
|
|
|
912 --------------
|
|
|
913 -- Finalize --
|
|
|
914 --------------
|
|
|
915
|
|
|
916 procedure Finalize is
|
|
|
917 begin
|
|
|
918 -- This is a dummy placeholder for an obsolete API.
|
|
|
919 -- The real finalization actions are in Initialize primitive operation
|
|
|
920 -- of Sockets_Library_Controller.
|
|
|
921
|
|
|
922 null;
|
|
|
923 end Finalize;
|
|
|
924
|
|
|
925 ---------
|
|
|
926 -- Get --
|
|
|
927 ---------
|
|
|
928
|
|
|
929 procedure Get
|
|
|
930 (Item : in out Socket_Set_Type;
|
|
|
931 Socket : out Socket_Type)
|
|
|
932 is
|
|
|
933 S : aliased C.int;
|
|
|
934 L : aliased C.int := C.int (Item.Last);
|
|
|
935
|
|
|
936 begin
|
|
|
937 if Item.Last /= No_Socket then
|
|
|
938 Get_Socket_From_Set
|
|
|
939 (Item.Set'Access, Last => L'Access, Socket => S'Access);
|
|
|
940 Item.Last := Socket_Type (L);
|
|
|
941 Socket := Socket_Type (S);
|
|
|
942 else
|
|
|
943 Socket := No_Socket;
|
|
|
944 end if;
|
|
|
945 end Get;
|
|
|
946
|
|
|
947 -----------------
|
|
|
948 -- Get_Address --
|
|
|
949 -----------------
|
|
|
950
|
|
|
951 function Get_Address
|
|
|
952 (Stream : not null Stream_Access) return Sock_Addr_Type
|
|
|
953 is
|
|
|
954 begin
|
|
|
955 if Stream.all in Datagram_Socket_Stream_Type then
|
|
|
956 return Datagram_Socket_Stream_Type (Stream.all).From;
|
|
|
957 else
|
|
|
958 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
|
|
|
959 end if;
|
|
|
960 end Get_Address;
|
|
|
961
|
|
|
962 -------------------------
|
|
|
963 -- Get_Host_By_Address --
|
|
|
964 -------------------------
|
|
|
965
|
|
|
966 function Get_Host_By_Address
|
|
|
967 (Address : Inet_Addr_Type;
|
|
|
968 Family : Family_Type := Family_Inet) return Host_Entry_Type
|
|
|
969 is
|
|
|
970 pragma Unreferenced (Family);
|
|
|
971
|
|
|
972 HA : aliased In_Addr := To_In_Addr (Address);
|
|
|
973 Buflen : constant C.int := Netdb_Buffer_Size;
|
|
|
974 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
|
|
|
975 Res : aliased Hostent;
|
|
|
976 Err : aliased C.int;
|
|
|
977
|
|
|
978 begin
|
|
|
979 Netdb_Lock;
|
|
|
980
|
|
|
981 if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET,
|
|
|
982 Res'Access, Buf'Address, Buflen, Err'Access) /= 0
|
|
|
983 then
|
|
|
984 Netdb_Unlock;
|
|
|
985 Raise_Host_Error (Integer (Err), Image (Address));
|
|
|
986 end if;
|
|
|
987
|
|
|
988 begin
|
|
|
989 return H : constant Host_Entry_Type :=
|
|
|
990 To_Host_Entry (Res'Unchecked_Access)
|
|
|
991 do
|
|
|
992 Netdb_Unlock;
|
|
|
993 end return;
|
|
|
994 exception
|
|
|
995 when others =>
|
|
|
996 Netdb_Unlock;
|
|
|
997 raise;
|
|
|
998 end;
|
|
|
999 end Get_Host_By_Address;
|
|
|
1000
|
|
|
1001 ----------------------
|
|
|
1002 -- Get_Host_By_Name --
|
|
|
1003 ----------------------
|
|
|
1004
|
|
|
1005 function Get_Host_By_Name (Name : String) return Host_Entry_Type is
|
|
|
1006 begin
|
|
|
1007 -- If the given name actually is the string representation of
|
|
|
1008 -- an IP address, use Get_Host_By_Address instead.
|
|
|
1009
|
|
|
1010 if Is_IP_Address (Name) then
|
|
|
1011 return Get_Host_By_Address (Inet_Addr (Name));
|
|
|
1012 end if;
|
|
|
1013
|
|
|
1014 declare
|
|
|
1015 HN : constant C.char_array := C.To_C (Name);
|
|
|
1016 Buflen : constant C.int := Netdb_Buffer_Size;
|
|
|
1017 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
|
|
|
1018 Res : aliased Hostent;
|
|
|
1019 Err : aliased C.int;
|
|
|
1020
|
|
|
1021 begin
|
|
|
1022 Netdb_Lock;
|
|
|
1023
|
|
|
1024 if C_Gethostbyname
|
|
|
1025 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
|
|
|
1026 then
|
|
|
1027 Netdb_Unlock;
|
|
|
1028 Raise_Host_Error (Integer (Err), Name);
|
|
|
1029 end if;
|
|
|
1030
|
|
|
1031 return H : constant Host_Entry_Type :=
|
|
|
1032 To_Host_Entry (Res'Unchecked_Access)
|
|
|
1033 do
|
|
|
1034 Netdb_Unlock;
|
|
|
1035 end return;
|
|
|
1036 end;
|
|
|
1037 end Get_Host_By_Name;
|
|
|
1038
|
|
|
1039 -------------------
|
|
|
1040 -- Get_Peer_Name --
|
|
|
1041 -------------------
|
|
|
1042
|
|
|
1043 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
|
|
|
1044 Sin : aliased Sockaddr_In;
|
|
|
1045 Len : aliased C.int := Sin'Size / 8;
|
|
|
1046 Res : Sock_Addr_Type (Family_Inet);
|
|
|
1047
|
|
|
1048 begin
|
|
|
1049 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
|
|
|
1050 Raise_Socket_Error (Socket_Errno);
|
|
|
1051 end if;
|
|
|
1052
|
|
|
1053 To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
|
|
|
1054 Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
|
|
|
1055
|
|
|
1056 return Res;
|
|
|
1057 end Get_Peer_Name;
|
|
|
1058
|
|
|
1059 -------------------------
|
|
|
1060 -- Get_Service_By_Name --
|
|
|
1061 -------------------------
|
|
|
1062
|
|
|
1063 function Get_Service_By_Name
|
|
|
1064 (Name : String;
|
|
|
1065 Protocol : String) return Service_Entry_Type
|
|
|
1066 is
|
|
|
1067 SN : constant C.char_array := C.To_C (Name);
|
|
|
1068 SP : constant C.char_array := C.To_C (Protocol);
|
|
|
1069 Buflen : constant C.int := Netdb_Buffer_Size;
|
|
|
1070 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
|
|
|
1071 Res : aliased Servent;
|
|
|
1072
|
|
|
1073 begin
|
|
|
1074 Netdb_Lock;
|
|
|
1075
|
|
|
1076 if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
|
|
|
1077 Netdb_Unlock;
|
|
|
1078 raise Service_Error with "Service not found";
|
|
|
1079 end if;
|
|
|
1080
|
|
|
1081 -- Translate from the C format to the API format
|
|
|
1082
|
|
|
1083 return S : constant Service_Entry_Type :=
|
|
|
1084 To_Service_Entry (Res'Unchecked_Access)
|
|
|
1085 do
|
|
|
1086 Netdb_Unlock;
|
|
|
1087 end return;
|
|
|
1088 end Get_Service_By_Name;
|
|
|
1089
|
|
|
1090 -------------------------
|
|
|
1091 -- Get_Service_By_Port --
|
|
|
1092 -------------------------
|
|
|
1093
|
|
|
1094 function Get_Service_By_Port
|
|
|
1095 (Port : Port_Type;
|
|
|
1096 Protocol : String) return Service_Entry_Type
|
|
|
1097 is
|
|
|
1098 SP : constant C.char_array := C.To_C (Protocol);
|
|
|
1099 Buflen : constant C.int := Netdb_Buffer_Size;
|
|
|
1100 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
|
|
|
1101 Res : aliased Servent;
|
|
|
1102
|
|
|
1103 begin
|
|
|
1104 Netdb_Lock;
|
|
|
1105
|
|
|
1106 if C_Getservbyport
|
|
|
1107 (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
|
|
|
1108 Res'Access, Buf'Address, Buflen) /= 0
|
|
|
1109 then
|
|
|
1110 Netdb_Unlock;
|
|
|
1111 raise Service_Error with "Service not found";
|
|
|
1112 end if;
|
|
|
1113
|
|
|
1114 -- Translate from the C format to the API format
|
|
|
1115
|
|
|
1116 return S : constant Service_Entry_Type :=
|
|
|
1117 To_Service_Entry (Res'Unchecked_Access)
|
|
|
1118 do
|
|
|
1119 Netdb_Unlock;
|
|
|
1120 end return;
|
|
|
1121 end Get_Service_By_Port;
|
|
|
1122
|
|
|
1123 ---------------------
|
|
|
1124 -- Get_Socket_Name --
|
|
|
1125 ---------------------
|
|
|
1126
|
|
|
1127 function Get_Socket_Name
|
|
|
1128 (Socket : Socket_Type) return Sock_Addr_Type
|
|
|
1129 is
|
|
|
1130 Sin : aliased Sockaddr_In;
|
|
|
1131 Len : aliased C.int := Sin'Size / 8;
|
|
|
1132 Res : C.int;
|
|
|
1133 Addr : Sock_Addr_Type := No_Sock_Addr;
|
|
|
1134
|
|
|
1135 begin
|
|
|
1136 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
|
|
|
1137
|
|
|
1138 if Res /= Failure then
|
|
|
1139 To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
|
|
|
1140 Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
|
|
|
1141 end if;
|
|
|
1142
|
|
|
1143 return Addr;
|
|
|
1144 end Get_Socket_Name;
|
|
|
1145
|
|
|
1146 -----------------------
|
|
|
1147 -- Get_Socket_Option --
|
|
|
1148 -----------------------
|
|
|
1149
|
|
|
1150 function Get_Socket_Option
|
|
|
1151 (Socket : Socket_Type;
|
|
|
1152 Level : Level_Type := Socket_Level;
|
|
|
1153 Name : Option_Name;
|
|
|
1154 Optname : Interfaces.C.int := -1) return Option_Type
|
|
|
1155 is
|
|
|
1156 use SOSC;
|
|
|
1157 use type C.unsigned_char;
|
|
|
1158
|
|
|
1159 V8 : aliased Two_Ints;
|
|
|
1160 V4 : aliased C.int;
|
|
|
1161 V1 : aliased C.unsigned_char;
|
|
|
1162 VT : aliased Timeval;
|
|
|
1163 Len : aliased C.int;
|
|
|
1164 Add : System.Address;
|
|
|
1165 Res : C.int;
|
|
|
1166 Opt : Option_Type (Name);
|
|
|
1167 Onm : Interfaces.C.int;
|
|
|
1168
|
|
|
1169 begin
|
|
|
1170 if Name in Specific_Option_Name then
|
|
|
1171 Onm := Options (Name);
|
|
|
1172
|
|
|
1173 elsif Optname = -1 then
|
|
|
1174 raise Socket_Error with "optname must be specified";
|
|
|
1175
|
|
|
1176 else
|
|
|
1177 Onm := Optname;
|
|
|
1178 end if;
|
|
|
1179
|
|
|
1180 case Name is
|
|
|
1181 when Multicast_Loop
|
|
|
1182 | Multicast_TTL
|
|
|
1183 | Receive_Packet_Info
|
|
|
1184 =>
|
|
|
1185 Len := V1'Size / 8;
|
|
|
1186 Add := V1'Address;
|
|
|
1187
|
|
|
1188 when Broadcast
|
|
|
1189 | Busy_Polling
|
|
|
1190 | Error
|
|
|
1191 | Generic_Option
|
|
|
1192 | Keep_Alive
|
|
|
1193 | Multicast_If
|
|
|
1194 | No_Delay
|
|
|
1195 | Receive_Buffer
|
|
|
1196 | Reuse_Address
|
|
|
1197 | Send_Buffer
|
|
|
1198 =>
|
|
|
1199 Len := V4'Size / 8;
|
|
|
1200 Add := V4'Address;
|
|
|
1201
|
|
|
1202 when Receive_Timeout
|
|
|
1203 | Send_Timeout
|
|
|
1204 =>
|
|
|
1205 -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
|
|
|
1206 -- struct timeval, but on Windows it is a milliseconds count in
|
|
|
1207 -- a DWORD.
|
|
|
1208
|
|
|
1209 if Target_OS = Windows then
|
|
|
1210 Len := V4'Size / 8;
|
|
|
1211 Add := V4'Address;
|
|
|
1212
|
|
|
1213 else
|
|
|
1214 Len := VT'Size / 8;
|
|
|
1215 Add := VT'Address;
|
|
|
1216 end if;
|
|
|
1217
|
|
|
1218 when Add_Membership
|
|
|
1219 | Drop_Membership
|
|
|
1220 | Linger
|
|
|
1221 =>
|
|
|
1222 Len := V8'Size / 8;
|
|
|
1223 Add := V8'Address;
|
|
|
1224 end case;
|
|
|
1225
|
|
|
1226 Res :=
|
|
|
1227 C_Getsockopt
|
|
|
1228 (C.int (Socket),
|
|
|
1229 Levels (Level),
|
|
|
1230 Onm,
|
|
|
1231 Add, Len'Access);
|
|
|
1232
|
|
|
1233 if Res = Failure then
|
|
|
1234 Raise_Socket_Error (Socket_Errno);
|
|
|
1235 end if;
|
|
|
1236
|
|
|
1237 case Name is
|
|
|
1238 when Generic_Option =>
|
|
|
1239 Opt.Optname := Onm;
|
|
|
1240 Opt.Optval := V4;
|
|
|
1241
|
|
|
1242 when Broadcast
|
|
|
1243 | Keep_Alive
|
|
|
1244 | No_Delay
|
|
|
1245 | Reuse_Address
|
|
|
1246 =>
|
|
|
1247 Opt.Enabled := (V4 /= 0);
|
|
|
1248
|
|
|
1249 when Busy_Polling =>
|
|
|
1250 Opt.Microseconds := Natural (V4);
|
|
|
1251
|
|
|
1252 when Linger =>
|
|
|
1253 Opt.Enabled := (V8 (V8'First) /= 0);
|
|
|
1254 Opt.Seconds := Natural (V8 (V8'Last));
|
|
|
1255
|
|
|
1256 when Receive_Buffer
|
|
|
1257 | Send_Buffer
|
|
|
1258 =>
|
|
|
1259 Opt.Size := Natural (V4);
|
|
|
1260
|
|
|
1261 when Error =>
|
|
|
1262 Opt.Error := Resolve_Error (Integer (V4));
|
|
|
1263
|
|
|
1264 when Add_Membership
|
|
|
1265 | Drop_Membership
|
|
|
1266 =>
|
|
|
1267 To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
|
|
|
1268 To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
|
|
|
1269
|
|
|
1270 when Multicast_If =>
|
|
|
1271 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
|
|
|
1272
|
|
|
1273 when Multicast_TTL =>
|
|
|
1274 Opt.Time_To_Live := Integer (V1);
|
|
|
1275
|
|
|
1276 when Multicast_Loop
|
|
|
1277 | Receive_Packet_Info
|
|
|
1278 =>
|
|
|
1279 Opt.Enabled := (V1 /= 0);
|
|
|
1280
|
|
|
1281 when Receive_Timeout
|
|
|
1282 | Send_Timeout
|
|
|
1283 =>
|
|
|
1284 if Target_OS = Windows then
|
|
|
1285
|
|
|
1286 -- Timeout is in milliseconds, actual value is 500 ms +
|
|
|
1287 -- returned value (unless it is 0).
|
|
|
1288
|
|
|
1289 if V4 = 0 then
|
|
|
1290 Opt.Timeout := 0.0;
|
|
|
1291 else
|
|
|
1292 Opt.Timeout := Natural (V4) * 0.001 + 0.500;
|
|
|
1293 end if;
|
|
|
1294
|
|
|
1295 else
|
|
|
1296 Opt.Timeout := To_Duration (VT);
|
|
|
1297 end if;
|
|
|
1298 end case;
|
|
|
1299
|
|
|
1300 return Opt;
|
|
|
1301 end Get_Socket_Option;
|
|
|
1302
|
|
|
1303 ---------------
|
|
|
1304 -- Host_Name --
|
|
|
1305 ---------------
|
|
|
1306
|
|
|
1307 function Host_Name return String is
|
|
|
1308 Name : aliased C.char_array (1 .. 64);
|
|
|
1309 Res : C.int;
|
|
|
1310
|
|
|
1311 begin
|
|
|
1312 Res := C_Gethostname (Name'Address, Name'Length);
|
|
|
1313
|
|
|
1314 if Res = Failure then
|
|
|
1315 Raise_Socket_Error (Socket_Errno);
|
|
|
1316 end if;
|
|
|
1317
|
|
|
1318 return C.To_Ada (Name);
|
|
|
1319 end Host_Name;
|
|
|
1320
|
|
|
1321 -----------
|
|
|
1322 -- Image --
|
|
|
1323 -----------
|
|
|
1324
|
|
|
1325 function Image
|
|
131
|
1326 (Val : Inet_Addr_Bytes;
|
|
111
|
1327 Hex : Boolean := False) return String
|
|
|
1328 is
|
|
|
1329 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
|
|
|
1330 -- has at most a length of 3 plus one '.' character.
|
|
|
1331
|
|
|
1332 Buffer : String (1 .. 4 * Val'Length);
|
|
|
1333 Length : Natural := 1;
|
|
|
1334 Separator : Character;
|
|
|
1335
|
|
|
1336 procedure Img10 (V : Inet_Addr_Comp_Type);
|
|
|
1337 -- Append to Buffer image of V in decimal format
|
|
|
1338
|
|
|
1339 procedure Img16 (V : Inet_Addr_Comp_Type);
|
|
|
1340 -- Append to Buffer image of V in hexadecimal format
|
|
|
1341
|
|
|
1342 -----------
|
|
|
1343 -- Img10 --
|
|
|
1344 -----------
|
|
|
1345
|
|
|
1346 procedure Img10 (V : Inet_Addr_Comp_Type) is
|
|
|
1347 Img : constant String := V'Img;
|
|
|
1348 Len : constant Natural := Img'Length - 1;
|
|
|
1349 begin
|
|
|
1350 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
|
|
|
1351 Length := Length + Len;
|
|
|
1352 end Img10;
|
|
|
1353
|
|
|
1354 -----------
|
|
|
1355 -- Img16 --
|
|
|
1356 -----------
|
|
|
1357
|
|
|
1358 procedure Img16 (V : Inet_Addr_Comp_Type) is
|
|
|
1359 begin
|
|
|
1360 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
|
|
|
1361 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
|
|
|
1362 Length := Length + 2;
|
|
|
1363 end Img16;
|
|
|
1364
|
|
|
1365 -- Start of processing for Image
|
|
|
1366
|
|
|
1367 begin
|
|
|
1368 Separator := (if Hex then ':' else '.');
|
|
|
1369
|
|
|
1370 for J in Val'Range loop
|
|
|
1371 if Hex then
|
|
|
1372 Img16 (Val (J));
|
|
|
1373 else
|
|
|
1374 Img10 (Val (J));
|
|
|
1375 end if;
|
|
|
1376
|
|
|
1377 if J /= Val'Last then
|
|
|
1378 Buffer (Length) := Separator;
|
|
|
1379 Length := Length + 1;
|
|
|
1380 end if;
|
|
|
1381 end loop;
|
|
|
1382
|
|
|
1383 return Buffer (1 .. Length - 1);
|
|
|
1384 end Image;
|
|
|
1385
|
|
|
1386 -----------
|
|
|
1387 -- Image --
|
|
|
1388 -----------
|
|
|
1389
|
|
|
1390 function Image (Value : Inet_Addr_Type) return String is
|
|
|
1391 begin
|
|
|
1392 if Value.Family = Family_Inet then
|
|
131
|
1393 return Image (Inet_Addr_Bytes (Value.Sin_V4), Hex => False);
|
|
111
|
1394 else
|
|
131
|
1395 return Image (Inet_Addr_Bytes (Value.Sin_V6), Hex => True);
|
|
111
|
1396 end if;
|
|
|
1397 end Image;
|
|
|
1398
|
|
|
1399 -----------
|
|
|
1400 -- Image --
|
|
|
1401 -----------
|
|
|
1402
|
|
|
1403 function Image (Value : Sock_Addr_Type) return String is
|
|
|
1404 Port : constant String := Value.Port'Img;
|
|
|
1405 begin
|
|
|
1406 return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
|
|
|
1407 end Image;
|
|
|
1408
|
|
|
1409 -----------
|
|
|
1410 -- Image --
|
|
|
1411 -----------
|
|
|
1412
|
|
|
1413 function Image (Socket : Socket_Type) return String is
|
|
|
1414 begin
|
|
|
1415 return Socket'Img;
|
|
|
1416 end Image;
|
|
|
1417
|
|
|
1418 -----------
|
|
|
1419 -- Image --
|
|
|
1420 -----------
|
|
|
1421
|
|
|
1422 function Image (Item : Socket_Set_Type) return String is
|
|
|
1423 Socket_Set : Socket_Set_Type := Item;
|
|
|
1424
|
|
|
1425 begin
|
|
|
1426 declare
|
|
|
1427 Last_Img : constant String := Socket_Set.Last'Img;
|
|
|
1428 Buffer : String
|
|
|
1429 (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
|
|
|
1430 Index : Positive := 1;
|
|
|
1431 Socket : Socket_Type;
|
|
|
1432
|
|
|
1433 begin
|
|
|
1434 while not Is_Empty (Socket_Set) loop
|
|
|
1435 Get (Socket_Set, Socket);
|
|
|
1436
|
|
|
1437 declare
|
|
|
1438 Socket_Img : constant String := Socket'Img;
|
|
|
1439 begin
|
|
|
1440 Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
|
|
|
1441 Index := Index + Socket_Img'Length;
|
|
|
1442 end;
|
|
|
1443 end loop;
|
|
|
1444
|
|
|
1445 return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
|
|
|
1446 end;
|
|
|
1447 end Image;
|
|
|
1448
|
|
|
1449 ---------------
|
|
|
1450 -- Inet_Addr --
|
|
|
1451 ---------------
|
|
|
1452
|
|
|
1453 function Inet_Addr (Image : String) return Inet_Addr_Type is
|
|
|
1454 use Interfaces.C;
|
|
|
1455
|
|
|
1456 Img : aliased char_array := To_C (Image);
|
|
|
1457 Addr : aliased C.int;
|
|
|
1458 Res : C.int;
|
|
|
1459 Result : Inet_Addr_Type;
|
|
|
1460
|
|
|
1461 begin
|
|
|
1462 -- Special case for an empty Image as on some platforms (e.g. Windows)
|
|
|
1463 -- calling Inet_Addr("") will not return an error.
|
|
|
1464
|
|
|
1465 if Image = "" then
|
|
|
1466 Raise_Socket_Error (SOSC.EINVAL);
|
|
|
1467 end if;
|
|
|
1468
|
|
|
1469 Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address);
|
|
|
1470
|
|
|
1471 if Res < 0 then
|
|
|
1472 Raise_Socket_Error (Socket_Errno);
|
|
|
1473
|
|
|
1474 elsif Res = 0 then
|
|
|
1475 Raise_Socket_Error (SOSC.EINVAL);
|
|
|
1476 end if;
|
|
|
1477
|
|
|
1478 To_Inet_Addr (To_In_Addr (Addr), Result);
|
|
|
1479 return Result;
|
|
|
1480 end Inet_Addr;
|
|
|
1481
|
|
|
1482 ----------------
|
|
|
1483 -- Initialize --
|
|
|
1484 ----------------
|
|
|
1485
|
|
|
1486 procedure Initialize (X : in out Sockets_Library_Controller) is
|
|
|
1487 pragma Unreferenced (X);
|
|
|
1488
|
|
|
1489 begin
|
|
|
1490 Thin.Initialize;
|
|
|
1491 end Initialize;
|
|
|
1492
|
|
|
1493 ----------------
|
|
|
1494 -- Initialize --
|
|
|
1495 ----------------
|
|
|
1496
|
|
|
1497 procedure Initialize (Process_Blocking_IO : Boolean) is
|
|
|
1498 Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
|
|
|
1499
|
|
|
1500 begin
|
|
|
1501 if Process_Blocking_IO /= Expected then
|
|
|
1502 raise Socket_Error with
|
|
|
1503 "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
|
|
|
1504 end if;
|
|
|
1505
|
|
|
1506 -- This is a dummy placeholder for an obsolete API
|
|
|
1507
|
|
|
1508 -- Real initialization actions are in Initialize primitive operation
|
|
|
1509 -- of Sockets_Library_Controller.
|
|
|
1510
|
|
|
1511 null;
|
|
|
1512 end Initialize;
|
|
|
1513
|
|
|
1514 ----------------
|
|
|
1515 -- Initialize --
|
|
|
1516 ----------------
|
|
|
1517
|
|
|
1518 procedure Initialize is
|
|
|
1519 begin
|
|
|
1520 -- This is a dummy placeholder for an obsolete API
|
|
|
1521
|
|
|
1522 -- Real initialization actions are in Initialize primitive operation
|
|
|
1523 -- of Sockets_Library_Controller.
|
|
|
1524
|
|
|
1525 null;
|
|
|
1526 end Initialize;
|
|
|
1527
|
|
|
1528 --------------
|
|
|
1529 -- Is_Empty --
|
|
|
1530 --------------
|
|
|
1531
|
|
|
1532 function Is_Empty (Item : Socket_Set_Type) return Boolean is
|
|
|
1533 begin
|
|
|
1534 return Item.Last = No_Socket;
|
|
|
1535 end Is_Empty;
|
|
|
1536
|
|
|
1537 -------------------
|
|
|
1538 -- Is_IP_Address --
|
|
|
1539 -------------------
|
|
|
1540
|
|
|
1541 function Is_IP_Address (Name : String) return Boolean is
|
|
|
1542 Dots : Natural := 0;
|
|
|
1543
|
|
|
1544 begin
|
|
|
1545 -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
|
|
|
1546 -- and there must be at least one digit around each.
|
|
|
1547
|
|
|
1548 for J in Name'Range loop
|
|
|
1549 if Name (J) = '.' then
|
|
|
1550
|
|
|
1551 -- Check that the dot is not in first or last position, and that
|
|
|
1552 -- it is followed by a digit. Note that we already know that it is
|
|
|
1553 -- preceded by a digit, or we would have returned earlier on.
|
|
|
1554
|
|
|
1555 if J in Name'First + 1 .. Name'Last - 1
|
|
|
1556 and then Name (J + 1) in '0' .. '9'
|
|
|
1557 then
|
|
|
1558 Dots := Dots + 1;
|
|
|
1559
|
|
|
1560 -- Definitely not a proper dotted quad
|
|
|
1561
|
|
|
1562 else
|
|
|
1563 return False;
|
|
|
1564 end if;
|
|
|
1565
|
|
|
1566 elsif Name (J) not in '0' .. '9' then
|
|
|
1567 return False;
|
|
|
1568 end if;
|
|
|
1569 end loop;
|
|
|
1570
|
|
|
1571 return Dots in 1 .. 3;
|
|
|
1572 end Is_IP_Address;
|
|
|
1573
|
|
|
1574 -------------
|
|
|
1575 -- Is_Open --
|
|
|
1576 -------------
|
|
|
1577
|
|
|
1578 function Is_Open (S : Selector_Type) return Boolean is
|
|
|
1579 begin
|
|
|
1580 if S.Is_Null then
|
|
|
1581 return True;
|
|
|
1582
|
|
|
1583 else
|
|
|
1584 -- Either both controlling socket descriptors are valid (case of an
|
|
|
1585 -- open selector) or neither (case of a closed selector).
|
|
|
1586
|
|
|
1587 pragma Assert ((S.R_Sig_Socket /= No_Socket)
|
|
|
1588 =
|
|
|
1589 (S.W_Sig_Socket /= No_Socket));
|
|
|
1590
|
|
|
1591 return S.R_Sig_Socket /= No_Socket;
|
|
|
1592 end if;
|
|
|
1593 end Is_Open;
|
|
|
1594
|
|
|
1595 ------------
|
|
|
1596 -- Is_Set --
|
|
|
1597 ------------
|
|
|
1598
|
|
|
1599 function Is_Set
|
|
|
1600 (Item : Socket_Set_Type;
|
|
|
1601 Socket : Socket_Type) return Boolean
|
|
|
1602 is
|
|
|
1603 begin
|
|
|
1604 Check_For_Fd_Set (Socket);
|
|
|
1605
|
|
|
1606 return Item.Last /= No_Socket
|
|
|
1607 and then Socket <= Item.Last
|
|
|
1608 and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
|
|
|
1609 end Is_Set;
|
|
|
1610
|
|
|
1611 -------------------
|
|
|
1612 -- Listen_Socket --
|
|
|
1613 -------------------
|
|
|
1614
|
|
|
1615 procedure Listen_Socket
|
|
|
1616 (Socket : Socket_Type;
|
|
|
1617 Length : Natural := 15)
|
|
|
1618 is
|
|
|
1619 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
|
|
|
1620 begin
|
|
|
1621 if Res = Failure then
|
|
|
1622 Raise_Socket_Error (Socket_Errno);
|
|
|
1623 end if;
|
|
|
1624 end Listen_Socket;
|
|
|
1625
|
|
|
1626 ------------
|
|
|
1627 -- Narrow --
|
|
|
1628 ------------
|
|
|
1629
|
|
|
1630 procedure Narrow (Item : in out Socket_Set_Type) is
|
|
|
1631 Last : aliased C.int := C.int (Item.Last);
|
|
|
1632 begin
|
|
|
1633 if Item.Last /= No_Socket then
|
|
|
1634 Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
|
|
|
1635 Item.Last := Socket_Type (Last);
|
|
|
1636 end if;
|
|
|
1637 end Narrow;
|
|
|
1638
|
|
|
1639 ----------------
|
|
|
1640 -- Netdb_Lock --
|
|
|
1641 ----------------
|
|
|
1642
|
|
|
1643 procedure Netdb_Lock is
|
|
|
1644 begin
|
|
|
1645 if Need_Netdb_Lock then
|
|
|
1646 System.Task_Lock.Lock;
|
|
|
1647 end if;
|
|
|
1648 end Netdb_Lock;
|
|
|
1649
|
|
|
1650 ------------------
|
|
|
1651 -- Netdb_Unlock --
|
|
|
1652 ------------------
|
|
|
1653
|
|
|
1654 procedure Netdb_Unlock is
|
|
|
1655 begin
|
|
|
1656 if Need_Netdb_Lock then
|
|
|
1657 System.Task_Lock.Unlock;
|
|
|
1658 end if;
|
|
|
1659 end Netdb_Unlock;
|
|
|
1660
|
|
|
1661 --------------------------------
|
|
|
1662 -- Normalize_Empty_Socket_Set --
|
|
|
1663 --------------------------------
|
|
|
1664
|
|
|
1665 procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
|
|
|
1666 begin
|
|
|
1667 if S.Last = No_Socket then
|
|
|
1668 Reset_Socket_Set (S.Set'Access);
|
|
|
1669 end if;
|
|
|
1670 end Normalize_Empty_Socket_Set;
|
|
|
1671
|
|
|
1672 -------------------
|
|
|
1673 -- Official_Name --
|
|
|
1674 -------------------
|
|
|
1675
|
|
|
1676 function Official_Name (E : Host_Entry_Type) return String is
|
|
|
1677 begin
|
|
|
1678 return To_String (E.Official);
|
|
|
1679 end Official_Name;
|
|
|
1680
|
|
|
1681 -------------------
|
|
|
1682 -- Official_Name --
|
|
|
1683 -------------------
|
|
|
1684
|
|
|
1685 function Official_Name (S : Service_Entry_Type) return String is
|
|
|
1686 begin
|
|
|
1687 return To_String (S.Official);
|
|
|
1688 end Official_Name;
|
|
|
1689
|
|
|
1690 --------------------
|
|
|
1691 -- Wait_On_Socket --
|
|
|
1692 --------------------
|
|
|
1693
|
|
|
1694 procedure Wait_On_Socket
|
|
|
1695 (Socket : Socket_Type;
|
|
|
1696 For_Read : Boolean;
|
|
|
1697 Timeout : Selector_Duration;
|
|
|
1698 Selector : access Selector_Type := null;
|
|
|
1699 Status : out Selector_Status)
|
|
|
1700 is
|
|
|
1701 type Local_Selector_Access is access Selector_Type;
|
|
|
1702 for Local_Selector_Access'Storage_Size use Selector_Type'Size;
|
|
|
1703
|
|
|
1704 S : Selector_Access;
|
|
|
1705 -- Selector to use for waiting
|
|
|
1706
|
|
|
1707 R_Fd_Set : Socket_Set_Type;
|
|
|
1708 W_Fd_Set : Socket_Set_Type;
|
|
|
1709
|
|
|
1710 begin
|
|
|
1711 -- Create selector if not provided by the user
|
|
|
1712
|
|
|
1713 if Selector = null then
|
|
|
1714 declare
|
|
|
1715 Local_S : constant Local_Selector_Access := new Selector_Type;
|
|
|
1716 begin
|
|
|
1717 S := Local_S.all'Unchecked_Access;
|
|
|
1718 Create_Selector (S.all);
|
|
|
1719 end;
|
|
|
1720
|
|
|
1721 else
|
|
|
1722 S := Selector.all'Access;
|
|
|
1723 end if;
|
|
|
1724
|
|
|
1725 if For_Read then
|
|
|
1726 Set (R_Fd_Set, Socket);
|
|
|
1727 else
|
|
|
1728 Set (W_Fd_Set, Socket);
|
|
|
1729 end if;
|
|
|
1730
|
|
|
1731 Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
|
|
|
1732
|
|
|
1733 if Selector = null then
|
|
|
1734 Close_Selector (S.all);
|
|
|
1735 end if;
|
|
|
1736 end Wait_On_Socket;
|
|
|
1737
|
|
|
1738 -----------------
|
|
|
1739 -- Port_Number --
|
|
|
1740 -----------------
|
|
|
1741
|
|
|
1742 function Port_Number (S : Service_Entry_Type) return Port_Type is
|
|
|
1743 begin
|
|
|
1744 return S.Port;
|
|
|
1745 end Port_Number;
|
|
|
1746
|
|
|
1747 -------------------
|
|
|
1748 -- Protocol_Name --
|
|
|
1749 -------------------
|
|
|
1750
|
|
|
1751 function Protocol_Name (S : Service_Entry_Type) return String is
|
|
|
1752 begin
|
|
|
1753 return To_String (S.Protocol);
|
|
|
1754 end Protocol_Name;
|
|
|
1755
|
|
|
1756 ----------------------
|
|
|
1757 -- Raise_Host_Error --
|
|
|
1758 ----------------------
|
|
|
1759
|
|
|
1760 procedure Raise_Host_Error (H_Error : Integer; Name : String) is
|
|
|
1761 function Dedot (Value : String) return String is
|
|
|
1762 (if Value /= "" and then Value (Value'Last) = '.' then
|
|
|
1763 Value (Value'First .. Value'Last - 1)
|
|
|
1764 else
|
|
|
1765 Value);
|
|
|
1766 -- Removes dot at the end of error message
|
|
|
1767
|
|
|
1768 begin
|
|
|
1769 raise Host_Error with
|
|
|
1770 Err_Code_Image (H_Error)
|
|
|
1771 & Dedot (Host_Error_Messages.Host_Error_Message (H_Error))
|
|
|
1772 & ": " & Name;
|
|
|
1773 end Raise_Host_Error;
|
|
|
1774
|
|
|
1775 ------------------------
|
|
|
1776 -- Raise_Socket_Error --
|
|
|
1777 ------------------------
|
|
|
1778
|
|
|
1779 procedure Raise_Socket_Error (Error : Integer) is
|
|
|
1780 begin
|
|
|
1781 raise Socket_Error with
|
|
|
1782 Err_Code_Image (Error) & Socket_Error_Message (Error);
|
|
|
1783 end Raise_Socket_Error;
|
|
|
1784
|
|
|
1785 ----------
|
|
|
1786 -- Read --
|
|
|
1787 ----------
|
|
|
1788
|
|
|
1789 procedure Read
|
|
|
1790 (Stream : in out Datagram_Socket_Stream_Type;
|
|
|
1791 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
1792 Last : out Ada.Streams.Stream_Element_Offset)
|
|
|
1793 is
|
|
|
1794 begin
|
|
|
1795 Receive_Socket
|
|
|
1796 (Stream.Socket,
|
|
|
1797 Item,
|
|
|
1798 Last,
|
|
|
1799 Stream.From);
|
|
|
1800 end Read;
|
|
|
1801
|
|
|
1802 ----------
|
|
|
1803 -- Read --
|
|
|
1804 ----------
|
|
|
1805
|
|
|
1806 procedure Read
|
|
|
1807 (Stream : in out Stream_Socket_Stream_Type;
|
|
|
1808 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
1809 Last : out Ada.Streams.Stream_Element_Offset)
|
|
|
1810 is
|
|
|
1811 First : Ada.Streams.Stream_Element_Offset := Item'First;
|
|
|
1812 Index : Ada.Streams.Stream_Element_Offset := First - 1;
|
|
|
1813 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
|
|
|
1814
|
|
|
1815 begin
|
|
|
1816 loop
|
|
|
1817 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
|
|
|
1818 Last := Index;
|
|
|
1819
|
|
|
1820 -- Exit when all or zero data received. Zero means that the socket
|
|
|
1821 -- peer is closed.
|
|
|
1822
|
|
|
1823 exit when Index < First or else Index = Max;
|
|
|
1824
|
|
|
1825 First := Index + 1;
|
|
|
1826 end loop;
|
|
|
1827 end Read;
|
|
|
1828
|
|
|
1829 --------------------
|
|
|
1830 -- Receive_Socket --
|
|
|
1831 --------------------
|
|
|
1832
|
|
|
1833 procedure Receive_Socket
|
|
|
1834 (Socket : Socket_Type;
|
|
|
1835 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
1836 Last : out Ada.Streams.Stream_Element_Offset;
|
|
|
1837 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
1838 is
|
|
|
1839 Res : C.int;
|
|
|
1840
|
|
|
1841 begin
|
|
|
1842 Res :=
|
|
|
1843 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
|
|
|
1844
|
|
|
1845 if Res = Failure then
|
|
|
1846 Raise_Socket_Error (Socket_Errno);
|
|
|
1847 end if;
|
|
|
1848
|
|
|
1849 Last := Last_Index (First => Item'First, Count => size_t (Res));
|
|
|
1850 end Receive_Socket;
|
|
|
1851
|
|
|
1852 --------------------
|
|
|
1853 -- Receive_Socket --
|
|
|
1854 --------------------
|
|
|
1855
|
|
|
1856 procedure Receive_Socket
|
|
|
1857 (Socket : Socket_Type;
|
|
|
1858 Item : out Ada.Streams.Stream_Element_Array;
|
|
|
1859 Last : out Ada.Streams.Stream_Element_Offset;
|
|
|
1860 From : out Sock_Addr_Type;
|
|
|
1861 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
1862 is
|
|
|
1863 Res : C.int;
|
|
|
1864 Sin : aliased Sockaddr_In;
|
|
|
1865 Len : aliased C.int := Sin'Size / 8;
|
|
|
1866
|
|
|
1867 begin
|
|
|
1868 Res :=
|
|
|
1869 C_Recvfrom
|
|
|
1870 (C.int (Socket),
|
|
|
1871 Item'Address,
|
|
|
1872 Item'Length,
|
|
|
1873 To_Int (Flags),
|
|
|
1874 Sin'Address,
|
|
|
1875 Len'Access);
|
|
|
1876
|
|
|
1877 if Res = Failure then
|
|
|
1878 Raise_Socket_Error (Socket_Errno);
|
|
|
1879 end if;
|
|
|
1880
|
|
|
1881 Last := Last_Index (First => Item'First, Count => size_t (Res));
|
|
|
1882
|
|
|
1883 To_Inet_Addr (Sin.Sin_Addr, From.Addr);
|
|
|
1884 From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
|
|
|
1885 end Receive_Socket;
|
|
|
1886
|
|
|
1887 --------------------
|
|
|
1888 -- Receive_Vector --
|
|
|
1889 --------------------
|
|
|
1890
|
|
|
1891 procedure Receive_Vector
|
|
|
1892 (Socket : Socket_Type;
|
|
|
1893 Vector : Vector_Type;
|
|
|
1894 Count : out Ada.Streams.Stream_Element_Count;
|
|
|
1895 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
1896 is
|
|
|
1897 Res : ssize_t;
|
|
|
1898
|
|
|
1899 Msg : Msghdr :=
|
|
|
1900 (Msg_Name => System.Null_Address,
|
|
|
1901 Msg_Namelen => 0,
|
|
|
1902 Msg_Iov => Vector'Address,
|
|
|
1903
|
|
|
1904 -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
|
|
|
1905 -- platforms) when the supplied vector is longer than IOV_MAX,
|
|
|
1906 -- so use minimum of the two lengths.
|
|
|
1907
|
|
|
1908 Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
|
|
|
1909 (Vector'Length, SOSC.IOV_MAX),
|
|
|
1910
|
|
|
1911 Msg_Control => System.Null_Address,
|
|
|
1912 Msg_Controllen => 0,
|
|
|
1913 Msg_Flags => 0);
|
|
|
1914
|
|
|
1915 begin
|
|
|
1916 Res :=
|
|
|
1917 C_Recvmsg
|
|
|
1918 (C.int (Socket),
|
|
|
1919 Msg'Address,
|
|
|
1920 To_Int (Flags));
|
|
|
1921
|
|
|
1922 if Res = ssize_t (Failure) then
|
|
|
1923 Raise_Socket_Error (Socket_Errno);
|
|
|
1924 end if;
|
|
|
1925
|
|
|
1926 Count := Ada.Streams.Stream_Element_Count (Res);
|
|
|
1927 end Receive_Vector;
|
|
|
1928
|
|
|
1929 -------------------
|
|
|
1930 -- Resolve_Error --
|
|
|
1931 -------------------
|
|
|
1932
|
|
|
1933 function Resolve_Error
|
|
|
1934 (Error_Value : Integer;
|
|
|
1935 From_Errno : Boolean := True) return Error_Type
|
|
|
1936 is
|
|
|
1937 use GNAT.Sockets.SOSC;
|
|
|
1938
|
|
|
1939 begin
|
|
|
1940 if not From_Errno then
|
|
|
1941 case Error_Value is
|
|
|
1942 when SOSC.HOST_NOT_FOUND => return Unknown_Host;
|
|
|
1943 when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
|
|
|
1944 when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
|
|
|
1945 when SOSC.NO_DATA => return Unknown_Server_Error;
|
|
|
1946 when others => return Cannot_Resolve_Error;
|
|
|
1947 end case;
|
|
|
1948 end if;
|
|
|
1949
|
|
|
1950 -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
|
|
|
1951 -- can't include it in the case statement below.
|
|
|
1952
|
|
|
1953 pragma Warnings (Off);
|
|
|
1954 -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
|
|
|
1955
|
|
|
1956 if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
|
|
|
1957 return Resource_Temporarily_Unavailable;
|
|
|
1958 end if;
|
|
|
1959
|
|
|
1960 -- This is not a case statement because if a particular error
|
|
|
1961 -- number constant is not defined, s-oscons-tmplt.c defines
|
|
|
1962 -- it to -1. If multiple constants are not defined, they
|
|
|
1963 -- would each be -1 and result in a "duplicate value in case" error.
|
|
|
1964 --
|
|
|
1965 -- But we have to leave warnings off because the compiler is also
|
|
|
1966 -- smart enough to note that when two errnos have the same value,
|
|
|
1967 -- the second if condition is useless.
|
|
|
1968 if Error_Value = ENOERROR then
|
|
|
1969 return Success;
|
|
|
1970 elsif Error_Value = EACCES then
|
|
|
1971 return Permission_Denied;
|
|
|
1972 elsif Error_Value = EADDRINUSE then
|
|
|
1973 return Address_Already_In_Use;
|
|
|
1974 elsif Error_Value = EADDRNOTAVAIL then
|
|
|
1975 return Cannot_Assign_Requested_Address;
|
|
|
1976 elsif Error_Value = EAFNOSUPPORT then
|
|
|
1977 return Address_Family_Not_Supported_By_Protocol;
|
|
|
1978 elsif Error_Value = EALREADY then
|
|
|
1979 return Operation_Already_In_Progress;
|
|
|
1980 elsif Error_Value = EBADF then
|
|
|
1981 return Bad_File_Descriptor;
|
|
|
1982 elsif Error_Value = ECONNABORTED then
|
|
|
1983 return Software_Caused_Connection_Abort;
|
|
|
1984 elsif Error_Value = ECONNREFUSED then
|
|
|
1985 return Connection_Refused;
|
|
|
1986 elsif Error_Value = ECONNRESET then
|
|
|
1987 return Connection_Reset_By_Peer;
|
|
|
1988 elsif Error_Value = EDESTADDRREQ then
|
|
|
1989 return Destination_Address_Required;
|
|
|
1990 elsif Error_Value = EFAULT then
|
|
|
1991 return Bad_Address;
|
|
|
1992 elsif Error_Value = EHOSTDOWN then
|
|
|
1993 return Host_Is_Down;
|
|
|
1994 elsif Error_Value = EHOSTUNREACH then
|
|
|
1995 return No_Route_To_Host;
|
|
|
1996 elsif Error_Value = EINPROGRESS then
|
|
|
1997 return Operation_Now_In_Progress;
|
|
|
1998 elsif Error_Value = EINTR then
|
|
|
1999 return Interrupted_System_Call;
|
|
|
2000 elsif Error_Value = EINVAL then
|
|
|
2001 return Invalid_Argument;
|
|
|
2002 elsif Error_Value = EIO then
|
|
|
2003 return Input_Output_Error;
|
|
|
2004 elsif Error_Value = EISCONN then
|
|
|
2005 return Transport_Endpoint_Already_Connected;
|
|
|
2006 elsif Error_Value = ELOOP then
|
|
|
2007 return Too_Many_Symbolic_Links;
|
|
|
2008 elsif Error_Value = EMFILE then
|
|
|
2009 return Too_Many_Open_Files;
|
|
|
2010 elsif Error_Value = EMSGSIZE then
|
|
|
2011 return Message_Too_Long;
|
|
|
2012 elsif Error_Value = ENAMETOOLONG then
|
|
|
2013 return File_Name_Too_Long;
|
|
|
2014 elsif Error_Value = ENETDOWN then
|
|
|
2015 return Network_Is_Down;
|
|
|
2016 elsif Error_Value = ENETRESET then
|
|
|
2017 return Network_Dropped_Connection_Because_Of_Reset;
|
|
|
2018 elsif Error_Value = ENETUNREACH then
|
|
|
2019 return Network_Is_Unreachable;
|
|
|
2020 elsif Error_Value = ENOBUFS then
|
|
|
2021 return No_Buffer_Space_Available;
|
|
|
2022 elsif Error_Value = ENOPROTOOPT then
|
|
|
2023 return Protocol_Not_Available;
|
|
|
2024 elsif Error_Value = ENOTCONN then
|
|
|
2025 return Transport_Endpoint_Not_Connected;
|
|
|
2026 elsif Error_Value = ENOTSOCK then
|
|
|
2027 return Socket_Operation_On_Non_Socket;
|
|
|
2028 elsif Error_Value = EOPNOTSUPP then
|
|
|
2029 return Operation_Not_Supported;
|
|
|
2030 elsif Error_Value = EPFNOSUPPORT then
|
|
|
2031 return Protocol_Family_Not_Supported;
|
|
|
2032 elsif Error_Value = EPIPE then
|
|
|
2033 return Broken_Pipe;
|
|
|
2034 elsif Error_Value = EPROTONOSUPPORT then
|
|
|
2035 return Protocol_Not_Supported;
|
|
|
2036 elsif Error_Value = EPROTOTYPE then
|
|
|
2037 return Protocol_Wrong_Type_For_Socket;
|
|
|
2038 elsif Error_Value = ESHUTDOWN then
|
|
|
2039 return Cannot_Send_After_Transport_Endpoint_Shutdown;
|
|
|
2040 elsif Error_Value = ESOCKTNOSUPPORT then
|
|
|
2041 return Socket_Type_Not_Supported;
|
|
|
2042 elsif Error_Value = ETIMEDOUT then
|
|
|
2043 return Connection_Timed_Out;
|
|
|
2044 elsif Error_Value = ETOOMANYREFS then
|
|
|
2045 return Too_Many_References;
|
|
|
2046 elsif Error_Value = EWOULDBLOCK then
|
|
|
2047 return Resource_Temporarily_Unavailable;
|
|
|
2048 else
|
|
|
2049 return Cannot_Resolve_Error;
|
|
|
2050 end if;
|
|
|
2051 pragma Warnings (On);
|
|
|
2052
|
|
|
2053 end Resolve_Error;
|
|
|
2054
|
|
|
2055 -----------------------
|
|
|
2056 -- Resolve_Exception --
|
|
|
2057 -----------------------
|
|
|
2058
|
|
|
2059 function Resolve_Exception
|
|
|
2060 (Occurrence : Exception_Occurrence) return Error_Type
|
|
|
2061 is
|
|
|
2062 Id : constant Exception_Id := Exception_Identity (Occurrence);
|
|
|
2063 Msg : constant String := Exception_Message (Occurrence);
|
|
|
2064 First : Natural;
|
|
|
2065 Last : Natural;
|
|
|
2066 Val : Integer;
|
|
|
2067
|
|
|
2068 begin
|
|
|
2069 First := Msg'First;
|
|
|
2070 while First <= Msg'Last
|
|
|
2071 and then Msg (First) not in '0' .. '9'
|
|
|
2072 loop
|
|
|
2073 First := First + 1;
|
|
|
2074 end loop;
|
|
|
2075
|
|
|
2076 if First > Msg'Last then
|
|
|
2077 return Cannot_Resolve_Error;
|
|
|
2078 end if;
|
|
|
2079
|
|
|
2080 Last := First;
|
|
|
2081 while Last < Msg'Last
|
|
|
2082 and then Msg (Last + 1) in '0' .. '9'
|
|
|
2083 loop
|
|
|
2084 Last := Last + 1;
|
|
|
2085 end loop;
|
|
|
2086
|
|
|
2087 Val := Integer'Value (Msg (First .. Last));
|
|
|
2088
|
|
|
2089 if Id = Socket_Error_Id then
|
|
|
2090 return Resolve_Error (Val);
|
|
|
2091
|
|
|
2092 elsif Id = Host_Error_Id then
|
|
|
2093 return Resolve_Error (Val, False);
|
|
|
2094
|
|
|
2095 else
|
|
|
2096 return Cannot_Resolve_Error;
|
|
|
2097 end if;
|
|
|
2098 end Resolve_Exception;
|
|
|
2099
|
|
|
2100 -----------------
|
|
|
2101 -- Send_Socket --
|
|
|
2102 -----------------
|
|
|
2103
|
|
|
2104 procedure Send_Socket
|
|
|
2105 (Socket : Socket_Type;
|
|
|
2106 Item : Ada.Streams.Stream_Element_Array;
|
|
|
2107 Last : out Ada.Streams.Stream_Element_Offset;
|
|
|
2108 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
2109 is
|
|
|
2110 begin
|
|
|
2111 Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
|
|
|
2112 end Send_Socket;
|
|
|
2113
|
|
|
2114 -----------------
|
|
|
2115 -- Send_Socket --
|
|
|
2116 -----------------
|
|
|
2117
|
|
|
2118 procedure Send_Socket
|
|
|
2119 (Socket : Socket_Type;
|
|
|
2120 Item : Ada.Streams.Stream_Element_Array;
|
|
|
2121 Last : out Ada.Streams.Stream_Element_Offset;
|
|
|
2122 To : Sock_Addr_Type;
|
|
|
2123 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
2124 is
|
|
|
2125 begin
|
|
|
2126 Send_Socket
|
|
|
2127 (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
|
|
|
2128 end Send_Socket;
|
|
|
2129
|
|
|
2130 -----------------
|
|
|
2131 -- Send_Socket --
|
|
|
2132 -----------------
|
|
|
2133
|
|
|
2134 procedure Send_Socket
|
|
|
2135 (Socket : Socket_Type;
|
|
|
2136 Item : Ada.Streams.Stream_Element_Array;
|
|
|
2137 Last : out Ada.Streams.Stream_Element_Offset;
|
|
|
2138 To : access Sock_Addr_Type;
|
|
|
2139 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
2140 is
|
|
|
2141 Res : C.int;
|
|
|
2142
|
|
|
2143 Sin : aliased Sockaddr_In;
|
|
|
2144 C_To : System.Address;
|
|
|
2145 Len : C.int;
|
|
|
2146
|
|
|
2147 begin
|
|
|
2148 if To /= null then
|
|
|
2149 Set_Family (Sin.Sin_Family, To.Family);
|
|
|
2150 Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
|
|
|
2151 Set_Port
|
|
|
2152 (Sin'Unchecked_Access,
|
|
|
2153 Short_To_Network (C.unsigned_short (To.Port)));
|
|
|
2154 C_To := Sin'Address;
|
|
|
2155 Len := Sin'Size / 8;
|
|
|
2156
|
|
|
2157 else
|
|
|
2158 C_To := System.Null_Address;
|
|
|
2159 Len := 0;
|
|
|
2160 end if;
|
|
|
2161
|
|
|
2162 Res := C_Sendto
|
|
|
2163 (C.int (Socket),
|
|
|
2164 Item'Address,
|
|
|
2165 Item'Length,
|
|
|
2166 Set_Forced_Flags (To_Int (Flags)),
|
|
|
2167 C_To,
|
|
|
2168 Len);
|
|
|
2169
|
|
|
2170 if Res = Failure then
|
|
|
2171 Raise_Socket_Error (Socket_Errno);
|
|
|
2172 end if;
|
|
|
2173
|
|
|
2174 Last := Last_Index (First => Item'First, Count => size_t (Res));
|
|
|
2175 end Send_Socket;
|
|
|
2176
|
|
|
2177 -----------------
|
|
|
2178 -- Send_Vector --
|
|
|
2179 -----------------
|
|
|
2180
|
|
|
2181 procedure Send_Vector
|
|
|
2182 (Socket : Socket_Type;
|
|
|
2183 Vector : Vector_Type;
|
|
|
2184 Count : out Ada.Streams.Stream_Element_Count;
|
|
|
2185 Flags : Request_Flag_Type := No_Request_Flag)
|
|
|
2186 is
|
|
|
2187 use Interfaces.C;
|
|
|
2188
|
|
|
2189 Res : ssize_t;
|
|
|
2190 Iov_Count : SOSC.Msg_Iovlen_T;
|
|
|
2191 This_Iov_Count : SOSC.Msg_Iovlen_T;
|
|
|
2192 Msg : Msghdr;
|
|
|
2193
|
|
|
2194 begin
|
|
|
2195 Count := 0;
|
|
|
2196 Iov_Count := 0;
|
|
|
2197 while Iov_Count < Vector'Length loop
|
|
|
2198
|
|
|
2199 pragma Warnings (Off);
|
|
|
2200 -- Following test may be compile time known on some targets
|
|
|
2201
|
|
|
2202 This_Iov_Count :=
|
|
|
2203 (if Vector'Length - Iov_Count > SOSC.IOV_MAX
|
|
|
2204 then SOSC.IOV_MAX
|
|
|
2205 else Vector'Length - Iov_Count);
|
|
|
2206
|
|
|
2207 pragma Warnings (On);
|
|
|
2208
|
|
|
2209 Msg :=
|
|
|
2210 (Msg_Name => System.Null_Address,
|
|
|
2211 Msg_Namelen => 0,
|
|
|
2212 Msg_Iov => Vector
|
|
|
2213 (Vector'First + Integer (Iov_Count))'Address,
|
|
|
2214 Msg_Iovlen => This_Iov_Count,
|
|
|
2215 Msg_Control => System.Null_Address,
|
|
|
2216 Msg_Controllen => 0,
|
|
|
2217 Msg_Flags => 0);
|
|
|
2218
|
|
|
2219 Res :=
|
|
|
2220 C_Sendmsg
|
|
|
2221 (C.int (Socket),
|
|
|
2222 Msg'Address,
|
|
|
2223 Set_Forced_Flags (To_Int (Flags)));
|
|
|
2224
|
|
|
2225 if Res = ssize_t (Failure) then
|
|
|
2226 Raise_Socket_Error (Socket_Errno);
|
|
|
2227 end if;
|
|
|
2228
|
|
|
2229 Count := Count + Ada.Streams.Stream_Element_Count (Res);
|
|
|
2230 Iov_Count := Iov_Count + This_Iov_Count;
|
|
|
2231 end loop;
|
|
|
2232 end Send_Vector;
|
|
|
2233
|
|
|
2234 ---------
|
|
|
2235 -- Set --
|
|
|
2236 ---------
|
|
|
2237
|
|
|
2238 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
|
|
|
2239 begin
|
|
|
2240 Check_For_Fd_Set (Socket);
|
|
|
2241
|
|
|
2242 if Item.Last = No_Socket then
|
|
|
2243
|
|
|
2244 -- Uninitialized socket set, make sure it is properly zeroed out
|
|
|
2245
|
|
|
2246 Reset_Socket_Set (Item.Set'Access);
|
|
|
2247 Item.Last := Socket;
|
|
|
2248
|
|
|
2249 elsif Item.Last < Socket then
|
|
|
2250 Item.Last := Socket;
|
|
|
2251 end if;
|
|
|
2252
|
|
|
2253 Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
|
|
|
2254 end Set;
|
|
|
2255
|
|
|
2256 -----------------------
|
|
|
2257 -- Set_Close_On_Exec --
|
|
|
2258 -----------------------
|
|
|
2259
|
|
|
2260 procedure Set_Close_On_Exec
|
|
|
2261 (Socket : Socket_Type;
|
|
|
2262 Close_On_Exec : Boolean;
|
|
|
2263 Status : out Boolean)
|
|
|
2264 is
|
|
|
2265 function C_Set_Close_On_Exec
|
|
|
2266 (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
|
|
|
2267 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
|
|
|
2268 begin
|
|
|
2269 Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
|
|
|
2270 end Set_Close_On_Exec;
|
|
|
2271
|
|
|
2272 ----------------------
|
|
|
2273 -- Set_Forced_Flags --
|
|
|
2274 ----------------------
|
|
|
2275
|
|
|
2276 function Set_Forced_Flags (F : C.int) return C.int is
|
|
|
2277 use type C.unsigned;
|
|
|
2278 function To_unsigned is
|
|
|
2279 new Ada.Unchecked_Conversion (C.int, C.unsigned);
|
|
|
2280 function To_int is
|
|
|
2281 new Ada.Unchecked_Conversion (C.unsigned, C.int);
|
|
|
2282 begin
|
|
|
2283 return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
|
|
|
2284 end Set_Forced_Flags;
|
|
|
2285
|
|
|
2286 -----------------------
|
|
|
2287 -- Set_Socket_Option --
|
|
|
2288 -----------------------
|
|
|
2289
|
|
|
2290 procedure Set_Socket_Option
|
|
|
2291 (Socket : Socket_Type;
|
|
|
2292 Level : Level_Type := Socket_Level;
|
|
|
2293 Option : Option_Type)
|
|
|
2294 is
|
|
|
2295 use SOSC;
|
|
|
2296
|
|
|
2297 V8 : aliased Two_Ints;
|
|
|
2298 V4 : aliased C.int;
|
|
|
2299 V1 : aliased C.unsigned_char;
|
|
|
2300 VT : aliased Timeval;
|
|
|
2301 Len : C.int;
|
|
|
2302 Add : System.Address := Null_Address;
|
|
|
2303 Res : C.int;
|
|
|
2304 Onm : C.int;
|
|
|
2305
|
|
|
2306 begin
|
|
|
2307 case Option.Name is
|
|
|
2308 when Generic_Option =>
|
|
|
2309 V4 := Option.Optval;
|
|
|
2310 Len := V4'Size / 8;
|
|
|
2311 Add := V4'Address;
|
|
|
2312
|
|
|
2313 when Broadcast
|
|
|
2314 | Keep_Alive
|
|
|
2315 | No_Delay
|
|
|
2316 | Reuse_Address
|
|
|
2317 =>
|
|
|
2318 V4 := C.int (Boolean'Pos (Option.Enabled));
|
|
|
2319 Len := V4'Size / 8;
|
|
|
2320 Add := V4'Address;
|
|
|
2321
|
|
|
2322 when Busy_Polling =>
|
|
|
2323 V4 := C.int (Option.Microseconds);
|
|
|
2324 Len := V4'Size / 8;
|
|
|
2325 Add := V4'Address;
|
|
|
2326
|
|
|
2327 when Linger =>
|
|
|
2328 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
|
|
|
2329 V8 (V8'Last) := C.int (Option.Seconds);
|
|
|
2330 Len := V8'Size / 8;
|
|
|
2331 Add := V8'Address;
|
|
|
2332
|
|
|
2333 when Receive_Buffer
|
|
|
2334 | Send_Buffer
|
|
|
2335 =>
|
|
|
2336 V4 := C.int (Option.Size);
|
|
|
2337 Len := V4'Size / 8;
|
|
|
2338 Add := V4'Address;
|
|
|
2339
|
|
|
2340 when Error =>
|
|
|
2341 V4 := C.int (Boolean'Pos (True));
|
|
|
2342 Len := V4'Size / 8;
|
|
|
2343 Add := V4'Address;
|
|
|
2344
|
|
|
2345 when Add_Membership
|
|
|
2346 | Drop_Membership
|
|
|
2347 =>
|
|
|
2348 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
|
|
|
2349 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
|
|
|
2350 Len := V8'Size / 8;
|
|
|
2351 Add := V8'Address;
|
|
|
2352
|
|
|
2353 when Multicast_If =>
|
|
|
2354 V4 := To_Int (To_In_Addr (Option.Outgoing_If));
|
|
|
2355 Len := V4'Size / 8;
|
|
|
2356 Add := V4'Address;
|
|
|
2357
|
|
|
2358 when Multicast_TTL =>
|
|
|
2359 V1 := C.unsigned_char (Option.Time_To_Live);
|
|
|
2360 Len := V1'Size / 8;
|
|
|
2361 Add := V1'Address;
|
|
|
2362
|
|
|
2363 when Multicast_Loop
|
|
|
2364 | Receive_Packet_Info
|
|
|
2365 =>
|
|
|
2366 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
|
|
|
2367 Len := V1'Size / 8;
|
|
|
2368 Add := V1'Address;
|
|
|
2369
|
|
|
2370 when Receive_Timeout
|
|
|
2371 | Send_Timeout
|
|
|
2372 =>
|
|
|
2373 if Target_OS = Windows then
|
|
|
2374
|
|
|
2375 -- On Windows, the timeout is a DWORD in milliseconds, and
|
|
|
2376 -- the actual timeout is 500 ms + the given value (unless it
|
|
|
2377 -- is 0).
|
|
|
2378
|
|
|
2379 V4 := C.int (Option.Timeout / 0.001);
|
|
|
2380
|
|
|
2381 if V4 > 500 then
|
|
|
2382 V4 := V4 - 500;
|
|
|
2383
|
|
|
2384 elsif V4 > 0 then
|
|
|
2385 V4 := 1;
|
|
|
2386 end if;
|
|
|
2387
|
|
|
2388 Len := V4'Size / 8;
|
|
|
2389 Add := V4'Address;
|
|
|
2390
|
|
|
2391 else
|
|
|
2392 VT := To_Timeval (Option.Timeout);
|
|
|
2393 Len := VT'Size / 8;
|
|
|
2394 Add := VT'Address;
|
|
|
2395 end if;
|
|
|
2396 end case;
|
|
|
2397
|
|
|
2398 if Option.Name in Specific_Option_Name then
|
|
|
2399 Onm := Options (Option.Name);
|
|
|
2400
|
|
|
2401 elsif Option.Optname = -1 then
|
|
|
2402 raise Socket_Error with "optname must be specified";
|
|
|
2403
|
|
|
2404 else
|
|
|
2405 Onm := Option.Optname;
|
|
|
2406 end if;
|
|
|
2407
|
|
|
2408 Res := C_Setsockopt
|
|
|
2409 (C.int (Socket),
|
|
|
2410 Levels (Level),
|
|
|
2411 Onm,
|
|
|
2412 Add, Len);
|
|
|
2413
|
|
|
2414 if Res = Failure then
|
|
|
2415 Raise_Socket_Error (Socket_Errno);
|
|
|
2416 end if;
|
|
|
2417 end Set_Socket_Option;
|
|
|
2418
|
|
|
2419 ----------------------
|
|
|
2420 -- Short_To_Network --
|
|
|
2421 ----------------------
|
|
|
2422
|
|
|
2423 function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
|
|
|
2424 use type C.unsigned_short;
|
|
|
2425
|
|
|
2426 begin
|
|
|
2427 -- Big-endian case. No conversion needed. On these platforms, htons()
|
|
|
2428 -- defaults to a null procedure.
|
|
|
2429
|
|
|
2430 if Default_Bit_Order = High_Order_First then
|
|
|
2431 return S;
|
|
|
2432
|
|
|
2433 -- Little-endian case. We must swap the high and low bytes of this
|
|
|
2434 -- short to make the port number network compliant.
|
|
|
2435
|
|
|
2436 else
|
|
|
2437 return (S / 256) + (S mod 256) * 256;
|
|
|
2438 end if;
|
|
|
2439 end Short_To_Network;
|
|
|
2440
|
|
|
2441 ---------------------
|
|
|
2442 -- Shutdown_Socket --
|
|
|
2443 ---------------------
|
|
|
2444
|
|
|
2445 procedure Shutdown_Socket
|
|
|
2446 (Socket : Socket_Type;
|
|
|
2447 How : Shutmode_Type := Shut_Read_Write)
|
|
|
2448 is
|
|
|
2449 Res : C.int;
|
|
|
2450
|
|
|
2451 begin
|
|
|
2452 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
|
|
|
2453
|
|
|
2454 if Res = Failure then
|
|
|
2455 Raise_Socket_Error (Socket_Errno);
|
|
|
2456 end if;
|
|
|
2457 end Shutdown_Socket;
|
|
|
2458
|
|
|
2459 ------------
|
|
|
2460 -- Stream --
|
|
|
2461 ------------
|
|
|
2462
|
|
|
2463 function Stream
|
|
|
2464 (Socket : Socket_Type;
|
|
|
2465 Send_To : Sock_Addr_Type) return Stream_Access
|
|
|
2466 is
|
|
|
2467 S : Datagram_Socket_Stream_Access;
|
|
|
2468
|
|
|
2469 begin
|
|
|
2470 S := new Datagram_Socket_Stream_Type;
|
|
|
2471 S.Socket := Socket;
|
|
|
2472 S.To := Send_To;
|
|
|
2473 S.From := Get_Socket_Name (Socket);
|
|
|
2474 return Stream_Access (S);
|
|
|
2475 end Stream;
|
|
|
2476
|
|
|
2477 ------------
|
|
|
2478 -- Stream --
|
|
|
2479 ------------
|
|
|
2480
|
|
|
2481 function Stream (Socket : Socket_Type) return Stream_Access is
|
|
|
2482 S : Stream_Socket_Stream_Access;
|
|
|
2483 begin
|
|
|
2484 S := new Stream_Socket_Stream_Type;
|
|
|
2485 S.Socket := Socket;
|
|
|
2486 return Stream_Access (S);
|
|
|
2487 end Stream;
|
|
|
2488
|
|
|
2489 ------------
|
|
|
2490 -- To_Ada --
|
|
|
2491 ------------
|
|
|
2492
|
|
|
2493 function To_Ada (Fd : Integer) return Socket_Type is
|
|
|
2494 begin
|
|
|
2495 return Socket_Type (Fd);
|
|
|
2496 end To_Ada;
|
|
|
2497
|
|
|
2498 ----------
|
|
|
2499 -- To_C --
|
|
|
2500 ----------
|
|
|
2501
|
|
|
2502 function To_C (Socket : Socket_Type) return Integer is
|
|
|
2503 begin
|
|
|
2504 return Integer (Socket);
|
|
|
2505 end To_C;
|
|
|
2506
|
|
|
2507 -----------------
|
|
|
2508 -- To_Duration --
|
|
|
2509 -----------------
|
|
|
2510
|
|
|
2511 function To_Duration (Val : Timeval) return Timeval_Duration is
|
|
|
2512 begin
|
|
|
2513 return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
|
|
|
2514 end To_Duration;
|
|
|
2515
|
|
|
2516 -------------------
|
|
|
2517 -- To_Host_Entry --
|
|
|
2518 -------------------
|
|
|
2519
|
|
|
2520 function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
|
|
|
2521 use type C.size_t;
|
|
|
2522
|
|
|
2523 Aliases_Count, Addresses_Count : Natural;
|
|
|
2524
|
|
|
2525 -- H_Length is not used because it is currently only ever set to 4, as
|
|
|
2526 -- we only handle the case of H_Addrtype being AF_INET.
|
|
|
2527
|
|
|
2528 begin
|
|
|
2529 if Hostent_H_Addrtype (E) /= SOSC.AF_INET then
|
|
|
2530 Raise_Socket_Error (SOSC.EPFNOSUPPORT);
|
|
|
2531 end if;
|
|
|
2532
|
|
|
2533 Aliases_Count := 0;
|
|
|
2534 while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
|
|
|
2535 Aliases_Count := Aliases_Count + 1;
|
|
|
2536 end loop;
|
|
|
2537
|
|
|
2538 Addresses_Count := 0;
|
|
|
2539 while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
|
|
|
2540 Addresses_Count := Addresses_Count + 1;
|
|
|
2541 end loop;
|
|
|
2542
|
|
|
2543 return Result : Host_Entry_Type
|
|
|
2544 (Aliases_Length => Aliases_Count,
|
|
|
2545 Addresses_Length => Addresses_Count)
|
|
|
2546 do
|
|
|
2547 Result.Official := To_Name (Value (Hostent_H_Name (E)));
|
|
|
2548
|
|
|
2549 for J in Result.Aliases'Range loop
|
|
|
2550 Result.Aliases (J) :=
|
|
|
2551 To_Name (Value (Hostent_H_Alias
|
|
|
2552 (E, C.int (J - Result.Aliases'First))));
|
|
|
2553 end loop;
|
|
|
2554
|
|
|
2555 for J in Result.Addresses'Range loop
|
|
|
2556 declare
|
|
|
2557 Addr : In_Addr;
|
|
|
2558
|
|
|
2559 -- Hostent_H_Addr (E, <index>) may return an address that is
|
|
|
2560 -- not correctly aligned for In_Addr, so we need to use
|
|
|
2561 -- an intermediate copy operation on a type with an alignment
|
|
|
2562 -- of 1 to recover the value.
|
|
|
2563
|
|
|
2564 subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8);
|
|
|
2565 Unaligned_Addr : Addr_Buf_T;
|
|
|
2566 for Unaligned_Addr'Address
|
|
|
2567 use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
|
|
|
2568 pragma Import (Ada, Unaligned_Addr);
|
|
|
2569
|
|
|
2570 Aligned_Addr : Addr_Buf_T;
|
|
|
2571 for Aligned_Addr'Address use Addr'Address;
|
|
|
2572 pragma Import (Ada, Aligned_Addr);
|
|
|
2573
|
|
|
2574 begin
|
|
|
2575 Aligned_Addr := Unaligned_Addr;
|
|
|
2576 To_Inet_Addr (Addr, Result.Addresses (J));
|
|
|
2577 end;
|
|
|
2578 end loop;
|
|
|
2579 end return;
|
|
|
2580 end To_Host_Entry;
|
|
|
2581
|
|
|
2582 ----------------
|
|
|
2583 -- To_In_Addr --
|
|
|
2584 ----------------
|
|
|
2585
|
|
|
2586 function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
|
|
|
2587 begin
|
|
|
2588 if Addr.Family = Family_Inet then
|
|
|
2589 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
|
|
|
2590 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
|
|
|
2591 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
|
|
|
2592 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
|
|
|
2593 end if;
|
|
|
2594
|
|
|
2595 raise Socket_Error with "IPv6 not supported";
|
|
|
2596 end To_In_Addr;
|
|
|
2597
|
|
|
2598 ------------------
|
|
|
2599 -- To_Inet_Addr --
|
|
|
2600 ------------------
|
|
|
2601
|
|
|
2602 procedure To_Inet_Addr
|
|
|
2603 (Addr : In_Addr;
|
|
|
2604 Result : out Inet_Addr_Type) is
|
|
|
2605 begin
|
|
|
2606 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
|
|
|
2607 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
|
|
|
2608 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
|
|
|
2609 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
|
|
|
2610 end To_Inet_Addr;
|
|
|
2611
|
|
|
2612 ------------
|
|
|
2613 -- To_Int --
|
|
|
2614 ------------
|
|
|
2615
|
|
|
2616 function To_Int (F : Request_Flag_Type) return C.int
|
|
|
2617 is
|
|
|
2618 Current : Request_Flag_Type := F;
|
|
|
2619 Result : C.int := 0;
|
|
|
2620
|
|
|
2621 begin
|
|
|
2622 for J in Flags'Range loop
|
|
|
2623 exit when Current = 0;
|
|
|
2624
|
|
|
2625 if Current mod 2 /= 0 then
|
|
|
2626 if Flags (J) = -1 then
|
|
|
2627 Raise_Socket_Error (SOSC.EOPNOTSUPP);
|
|
|
2628 end if;
|
|
|
2629
|
|
|
2630 Result := Result + Flags (J);
|
|
|
2631 end if;
|
|
|
2632
|
|
|
2633 Current := Current / 2;
|
|
|
2634 end loop;
|
|
|
2635
|
|
|
2636 return Result;
|
|
|
2637 end To_Int;
|
|
|
2638
|
|
|
2639 -------------
|
|
|
2640 -- To_Name --
|
|
|
2641 -------------
|
|
|
2642
|
|
|
2643 function To_Name (N : String) return Name_Type is
|
|
|
2644 begin
|
|
|
2645 return Name_Type'(N'Length, N);
|
|
|
2646 end To_Name;
|
|
|
2647
|
|
|
2648 ----------------------
|
|
|
2649 -- To_Service_Entry --
|
|
|
2650 ----------------------
|
|
|
2651
|
|
|
2652 function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
|
|
|
2653 Aliases_Count : Natural;
|
|
|
2654
|
|
|
2655 begin
|
|
|
2656 Aliases_Count := 0;
|
|
|
2657 while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
|
|
|
2658 Aliases_Count := Aliases_Count + 1;
|
|
|
2659 end loop;
|
|
|
2660
|
|
|
2661 return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do
|
|
|
2662 Result.Official := To_Name (Value (Servent_S_Name (E)));
|
|
|
2663
|
|
|
2664 for J in Result.Aliases'Range loop
|
|
|
2665 Result.Aliases (J) :=
|
|
|
2666 To_Name (Value (Servent_S_Alias
|
|
|
2667 (E, C.int (J - Result.Aliases'First))));
|
|
|
2668 end loop;
|
|
|
2669
|
|
|
2670 Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
|
|
|
2671 Result.Port :=
|
|
|
2672 Port_Type (Network_To_Short (Servent_S_Port (E)));
|
|
|
2673 end return;
|
|
|
2674 end To_Service_Entry;
|
|
|
2675
|
|
|
2676 ---------------
|
|
|
2677 -- To_String --
|
|
|
2678 ---------------
|
|
|
2679
|
|
|
2680 function To_String (HN : Name_Type) return String is
|
|
|
2681 begin
|
|
|
2682 return HN.Name (1 .. HN.Length);
|
|
|
2683 end To_String;
|
|
|
2684
|
|
|
2685 ----------------
|
|
|
2686 -- To_Timeval --
|
|
|
2687 ----------------
|
|
|
2688
|
|
|
2689 function To_Timeval (Val : Timeval_Duration) return Timeval is
|
|
|
2690 S : time_t;
|
|
|
2691 uS : suseconds_t;
|
|
|
2692
|
|
|
2693 begin
|
|
|
2694 -- If zero, set result as zero (otherwise it gets rounded down to -1)
|
|
|
2695
|
|
|
2696 if Val = 0.0 then
|
|
|
2697 S := 0;
|
|
|
2698 uS := 0;
|
|
|
2699
|
|
|
2700 -- Normal case where we do round down
|
|
|
2701
|
|
|
2702 else
|
|
|
2703 S := time_t (Val - 0.5);
|
|
|
2704 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
|
|
|
2705 end if;
|
|
|
2706
|
|
|
2707 return (S, uS);
|
|
|
2708 end To_Timeval;
|
|
|
2709
|
|
|
2710 -----------
|
|
|
2711 -- Value --
|
|
|
2712 -----------
|
|
|
2713
|
|
|
2714 function Value (S : System.Address) return String is
|
|
|
2715 Str : String (1 .. Positive'Last);
|
|
|
2716 for Str'Address use S;
|
|
|
2717 pragma Import (Ada, Str);
|
|
|
2718
|
|
|
2719 Terminator : Positive := Str'First;
|
|
|
2720
|
|
|
2721 begin
|
|
|
2722 while Str (Terminator) /= ASCII.NUL loop
|
|
|
2723 Terminator := Terminator + 1;
|
|
|
2724 end loop;
|
|
|
2725
|
|
|
2726 return Str (1 .. Terminator - 1);
|
|
|
2727 end Value;
|
|
|
2728
|
|
|
2729 -----------
|
|
|
2730 -- Write --
|
|
|
2731 -----------
|
|
|
2732
|
|
|
2733 procedure Write
|
|
|
2734 (Stream : in out Datagram_Socket_Stream_Type;
|
|
|
2735 Item : Ada.Streams.Stream_Element_Array)
|
|
|
2736 is
|
|
|
2737 Last : Stream_Element_Offset;
|
|
|
2738
|
|
|
2739 begin
|
|
|
2740 Send_Socket
|
|
|
2741 (Stream.Socket,
|
|
|
2742 Item,
|
|
|
2743 Last,
|
|
|
2744 Stream.To);
|
|
|
2745
|
|
|
2746 -- It is an error if not all of the data has been sent
|
|
|
2747
|
|
|
2748 if Last /= Item'Last then
|
|
|
2749 Raise_Socket_Error (Socket_Errno);
|
|
|
2750 end if;
|
|
|
2751 end Write;
|
|
|
2752
|
|
|
2753 -----------
|
|
|
2754 -- Write --
|
|
|
2755 -----------
|
|
|
2756
|
|
|
2757 procedure Write
|
|
|
2758 (Stream : in out Stream_Socket_Stream_Type;
|
|
|
2759 Item : Ada.Streams.Stream_Element_Array)
|
|
|
2760 is
|
|
|
2761 First : Ada.Streams.Stream_Element_Offset;
|
|
|
2762 Index : Ada.Streams.Stream_Element_Offset;
|
|
|
2763 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
|
|
|
2764
|
|
|
2765 begin
|
|
|
2766 First := Item'First;
|
|
|
2767 Index := First - 1;
|
|
|
2768 while First <= Max loop
|
|
|
2769 Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
|
|
|
2770
|
|
|
2771 -- Exit when all or zero data sent. Zero means that the socket has
|
|
|
2772 -- been closed by peer.
|
|
|
2773
|
|
|
2774 exit when Index < First or else Index = Max;
|
|
|
2775
|
|
|
2776 First := Index + 1;
|
|
|
2777 end loop;
|
|
|
2778
|
|
|
2779 -- For an empty array, we have First > Max, and hence Index >= Max (no
|
|
|
2780 -- error, the loop above is never executed). After a successful send,
|
|
|
2781 -- Index = Max. The only remaining case, Index < Max, is therefore
|
|
|
2782 -- always an actual send failure.
|
|
|
2783
|
|
|
2784 if Index < Max then
|
|
|
2785 Raise_Socket_Error (Socket_Errno);
|
|
|
2786 end if;
|
|
|
2787 end Write;
|
|
|
2788
|
|
|
2789 Sockets_Library_Controller_Object : Sockets_Library_Controller;
|
|
|
2790 pragma Unreferenced (Sockets_Library_Controller_Object);
|
|
|
2791 -- The elaboration and finalization of this object perform the required
|
|
|
2792 -- initialization and cleanup actions for the sockets library.
|
|
|
2793
|
|
131
|
2794 --------------------
|
|
|
2795 -- Create_Address --
|
|
|
2796 --------------------
|
|
|
2797
|
|
|
2798 function Create_Address
|
|
|
2799 (Family : Family_Type; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
|
|
|
2800 is
|
|
|
2801 (case Family is
|
|
|
2802 when Family_Inet => (Family_Inet, Bytes),
|
|
|
2803 when Family_Inet6 => (Family_Inet6, Bytes));
|
|
|
2804
|
|
|
2805 ---------------
|
|
|
2806 -- Get_Bytes --
|
|
|
2807 ---------------
|
|
|
2808
|
|
|
2809 function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is
|
|
|
2810 (case Addr.Family is
|
|
|
2811 when Family_Inet => Addr.Sin_V4,
|
|
|
2812 when Family_Inet6 => Addr.Sin_V6);
|
|
|
2813
|
|
|
2814 ----------
|
|
|
2815 -- Mask --
|
|
|
2816 ----------
|
|
|
2817
|
|
|
2818 function Mask
|
|
|
2819 (Family : Family_Type;
|
|
|
2820 Length : Natural;
|
|
|
2821 Host : Boolean := False) return Inet_Addr_Type
|
|
|
2822 is
|
|
|
2823 Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family);
|
|
|
2824 begin
|
|
|
2825 if Length > 8 * Addr_Len then
|
|
|
2826 raise Constraint_Error with
|
|
|
2827 "invalid mask length for address family " & Family'Img;
|
|
|
2828 end if;
|
|
|
2829
|
|
|
2830 declare
|
|
|
2831 B : Inet_Addr_Bytes (1 .. Addr_Len);
|
|
|
2832 Part : Inet_Addr_Comp_Type;
|
|
|
2833 begin
|
|
|
2834 for J in 1 .. Length / 8 loop
|
|
|
2835 B (J) := (if Host then 0 else 255);
|
|
|
2836 end loop;
|
|
|
2837
|
|
|
2838 if Length < 8 * Addr_Len then
|
|
|
2839 Part := 2 ** (8 - Length mod 8) - 1;
|
|
|
2840 B (Length / 8 + 1) := (if Host then Part else not Part);
|
|
|
2841
|
|
|
2842 for J in Length / 8 + 2 .. B'Last loop
|
|
|
2843 B (J) := (if Host then 255 else 0);
|
|
|
2844 end loop;
|
|
|
2845 end if;
|
|
|
2846
|
|
|
2847 return Create_Address (Family, B);
|
|
|
2848 end;
|
|
|
2849 end Mask;
|
|
|
2850
|
|
|
2851 -----------
|
|
|
2852 -- "and" --
|
|
|
2853 -----------
|
|
|
2854
|
|
|
2855 function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is
|
|
|
2856 begin
|
|
|
2857 if Addr.Family /= Mask.Family then
|
|
|
2858 raise Constraint_Error with "incompatible address families";
|
|
|
2859 end if;
|
|
|
2860
|
|
|
2861 declare
|
|
|
2862 A : constant Inet_Addr_Bytes := Get_Bytes (Addr);
|
|
|
2863 M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
|
|
|
2864 R : Inet_Addr_Bytes (A'Range);
|
|
|
2865
|
|
|
2866 begin
|
|
|
2867 for J in A'Range loop
|
|
|
2868 R (J) := A (J) and M (J);
|
|
|
2869 end loop;
|
|
|
2870 return Create_Address (Addr.Family, R);
|
|
|
2871 end;
|
|
|
2872 end "and";
|
|
|
2873
|
|
|
2874 ----------
|
|
|
2875 -- "or" --
|
|
|
2876 ----------
|
|
|
2877
|
|
|
2878 function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is
|
|
|
2879 begin
|
|
|
2880 if Net.Family /= Host.Family then
|
|
|
2881 raise Constraint_Error with "incompatible address families";
|
|
|
2882 end if;
|
|
|
2883
|
|
|
2884 declare
|
|
|
2885 N : constant Inet_Addr_Bytes := Get_Bytes (Net);
|
|
|
2886 H : constant Inet_Addr_Bytes := Get_Bytes (Host);
|
|
|
2887 R : Inet_Addr_Bytes (N'Range);
|
|
|
2888
|
|
|
2889 begin
|
|
|
2890 for J in N'Range loop
|
|
|
2891 R (J) := N (J) or H (J);
|
|
|
2892 end loop;
|
|
|
2893 return Create_Address (Net.Family, R);
|
|
|
2894 end;
|
|
|
2895 end "or";
|
|
|
2896
|
|
|
2897 -----------
|
|
|
2898 -- "not" --
|
|
|
2899 -----------
|
|
|
2900
|
|
|
2901 function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is
|
|
|
2902 M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
|
|
|
2903 R : Inet_Addr_Bytes (M'Range);
|
|
|
2904 begin
|
|
|
2905 for J in R'Range loop
|
|
|
2906 R (J) := not M (J);
|
|
|
2907 end loop;
|
|
|
2908 return Create_Address (Mask.Family, R);
|
|
|
2909 end "not";
|
|
|
2910
|
|
111
|
2911 end GNAT.Sockets;
|
