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