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