?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge -r 127928:132243 from trunk
[official-gcc.git] / gcc / ada / g-socket.adb
blob04cfdd74d018ece9a109847a29fa41facd7c5144
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-2007, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 with Ada.Streams; use Ada.Streams;
35 with Ada.Exceptions; use Ada.Exceptions;
36 with Ada.Unchecked_Conversion;
37
38 with Interfaces.C.Strings;
39 with GNAT.Sockets.Constants;
40 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
41 with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB;
42
43 with GNAT.Sockets.Linker_Options;
44 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
45 -- Need to include pragma Linker_Options which is platform dependent
46
47 with System; use System;
48
49 package body GNAT.Sockets is
50
51 use type C.int;
52
53 Finalized : Boolean := False;
54 Initialized : Boolean := False;
55
56 ENOERROR : constant := 0;
57
58 Netdb_Buffer_Size : constant := Constants.Need_Netdb_Buffer * 1024;
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 -- Correspondance tables
65
66 Families : constant array (Family_Type) of C.int :=
67 (Family_Inet => Constants.AF_INET,
68 Family_Inet6 => Constants.AF_INET6);
69
70 Levels : constant array (Level_Type) of C.int :=
71 (Socket_Level => Constants.SOL_SOCKET,
72 IP_Protocol_For_IP_Level => Constants.IPPROTO_IP,
73 IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
74 IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);
75
76 Modes : constant array (Mode_Type) of C.int :=
77 (Socket_Stream => Constants.SOCK_STREAM,
78 Socket_Datagram => Constants.SOCK_DGRAM);
79
80 Shutmodes : constant array (Shutmode_Type) of C.int :=
81 (Shut_Read => Constants.SHUT_RD,
82 Shut_Write => Constants.SHUT_WR,
83 Shut_Read_Write => Constants.SHUT_RDWR);
84
85 Requests : constant array (Request_Name) of C.int :=
86 (Non_Blocking_IO => Constants.FIONBIO,
87 N_Bytes_To_Read => Constants.FIONREAD);
88
89 Options : constant array (Option_Name) of C.int :=
90 (Keep_Alive => Constants.SO_KEEPALIVE,
91 Reuse_Address => Constants.SO_REUSEADDR,
92 Broadcast => Constants.SO_BROADCAST,
93 Send_Buffer => Constants.SO_SNDBUF,
94 Receive_Buffer => Constants.SO_RCVBUF,
95 Linger => Constants.SO_LINGER,
96 Error => Constants.SO_ERROR,
97 No_Delay => Constants.TCP_NODELAY,
98 Add_Membership => Constants.IP_ADD_MEMBERSHIP,
99 Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
100 Multicast_If => Constants.IP_MULTICAST_IF,
101 Multicast_TTL => Constants.IP_MULTICAST_TTL,
102 Multicast_Loop => Constants.IP_MULTICAST_LOOP,
103 Send_Timeout => Constants.SO_SNDTIMEO,
104 Receive_Timeout => Constants.SO_RCVTIMEO);
105
106 Flags : constant array (0 .. 3) of C.int :=
107 (0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data
108 1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data
109 2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception
110 3 => Constants.MSG_EOR); -- Send_End_Of_Record
111
112 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
113 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
114
115 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
116 -- Use to print in hexadecimal format
117
118 function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
119 function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int);
120
121 function Err_Code_Image (E : Integer) return String;
122 -- Return the value of E surrounded with brackets
123
124 -----------------------
125 -- Local subprograms --
126 -----------------------
127
128 function Resolve_Error
129 (Error_Value : Integer;
130 From_Errno : Boolean := True) return Error_Type;
131 -- Associate an enumeration value (error_type) to en error value (errno).
132 -- From_Errno prevents from mixing h_errno with errno.
133
134 function To_Name (N : String) return Name_Type;
135 function To_String (HN : Name_Type) return String;
136 -- Conversion functions
137
138 function To_Int (F : Request_Flag_Type) return C.int;
139 -- Return the int value corresponding to the specified flags combination
140
141 function Set_Forced_Flags (F : C.int) return C.int;
142 -- Return F with the bits from Constants.MSG_Forced_Flags forced set
143
144 function Short_To_Network
145 (S : C.unsigned_short) return C.unsigned_short;
146 pragma Inline (Short_To_Network);
147 -- Convert a port number into a network port number
148
149 function Network_To_Short
150 (S : C.unsigned_short) return C.unsigned_short
151 renames Short_To_Network;
152 -- Symetric operation
153
154 function Image
155 (Val : Inet_Addr_VN_Type;
156 Hex : Boolean := False) return String;
157 -- Output an array of inet address components in hex or decimal mode
158
159 function Is_IP_Address (Name : String) return Boolean;
160 -- Return true when Name is an IP address in standard dot notation
161
162 function To_In_Addr (Addr : Inet_Addr_Type) return Thin.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) return Host_Entry_Type;
169 -- Conversion function
170
171 function To_Service_Entry (E : Servent) return Service_Entry_Type;
172 -- Conversion function
173
174 function To_Timeval (Val : Timeval_Duration) return Timeval;
175 -- Separate Val in seconds and microseconds
176
177 function To_Duration (Val : Timeval) return Timeval_Duration;
178 -- Reconstruct a Duration value from a Timeval record (seconds and
179 -- microseconds).
180
181 procedure Raise_Socket_Error (Error : Integer);
182 -- Raise Socket_Error with an exception message describing the error code
183 -- from errno.
184
185 procedure Raise_Host_Error (H_Error : Integer);
186 -- Raise Host_Error exception with message describing error code (note
187 -- hstrerror seems to be obsolete) from h_errno.
188
189 procedure Narrow (Item : in out Socket_Set_Type);
190 -- Update Last as it may be greater than the real last socket
191
192 -- Types needed for Datagram_Socket_Stream_Type
193
194 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
195 Socket : Socket_Type;
196 To : Sock_Addr_Type;
197 From : Sock_Addr_Type;
198 end record;
199
200 type Datagram_Socket_Stream_Access is
201 access all Datagram_Socket_Stream_Type;
202
203 procedure Read
204 (Stream : in out Datagram_Socket_Stream_Type;
205 Item : out Ada.Streams.Stream_Element_Array;
206 Last : out Ada.Streams.Stream_Element_Offset);
207
208 procedure Write
209 (Stream : in out Datagram_Socket_Stream_Type;
210 Item : Ada.Streams.Stream_Element_Array);
211
212 -- Types needed for Stream_Socket_Stream_Type
213
214 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
215 Socket : Socket_Type;
216 end record;
217
218 type Stream_Socket_Stream_Access is
219 access all Stream_Socket_Stream_Type;
220
221 procedure Read
222 (Stream : in out Stream_Socket_Stream_Type;
223 Item : out Ada.Streams.Stream_Element_Array;
224 Last : out Ada.Streams.Stream_Element_Offset);
225
226 procedure Write
227 (Stream : in out Stream_Socket_Stream_Type;
228 Item : Ada.Streams.Stream_Element_Array);
229
230 ---------
231 -- "+" --
232 ---------
233
234 function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
235 begin
236 return L or R;
237 end "+";
238
239 --------------------
240 -- Abort_Selector --
241 --------------------
242
243 procedure Abort_Selector (Selector : Selector_Type) is
244 Res : C.int;
245
246 begin
247 -- Send one byte to unblock select system call
248
249 Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
250
251 if Res = Failure then
252 Raise_Socket_Error (Socket_Errno);
253 end if;
254 end Abort_Selector;
255
256 -------------------
257 -- Accept_Socket --
258 -------------------
259
260 procedure Accept_Socket
261 (Server : Socket_Type;
262 Socket : out Socket_Type;
263 Address : out Sock_Addr_Type)
264 is
265 Res : C.int;
266 Sin : aliased Sockaddr_In;
267 Len : aliased C.int := Sin'Size / 8;
268
269 begin
270 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
271
272 if Res = Failure then
273 Raise_Socket_Error (Socket_Errno);
274 end if;
275
276 Socket := Socket_Type (Res);
277
278 To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
279 Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
280 end Accept_Socket;
281
282 ---------------
283 -- Addresses --
284 ---------------
285
286 function Addresses
287 (E : Host_Entry_Type;
288 N : Positive := 1) return Inet_Addr_Type
289 is
290 begin
291 return E.Addresses (N);
292 end Addresses;
293
294 ----------------------
295 -- Addresses_Length --
296 ----------------------
297
298 function Addresses_Length (E : Host_Entry_Type) return Natural is
299 begin
300 return E.Addresses_Length;
301 end Addresses_Length;
302
303 -------------
304 -- Aliases --
305 -------------
306
307 function Aliases
308 (E : Host_Entry_Type;
309 N : Positive := 1) return String
310 is
311 begin
312 return To_String (E.Aliases (N));
313 end Aliases;
314
315 -------------
316 -- Aliases --
317 -------------
318
319 function Aliases
320 (S : Service_Entry_Type;
321 N : Positive := 1) return String
322 is
323 begin
324 return To_String (S.Aliases (N));
325 end Aliases;
326
327 --------------------
328 -- Aliases_Length --
329 --------------------
330
331 function Aliases_Length (E : Host_Entry_Type) return Natural is
332 begin
333 return E.Aliases_Length;
334 end Aliases_Length;
335
336 --------------------
337 -- Aliases_Length --
338 --------------------
339
340 function Aliases_Length (S : Service_Entry_Type) return Natural is
341 begin
342 return S.Aliases_Length;
343 end Aliases_Length;
344
345 -----------------
346 -- Bind_Socket --
347 -----------------
348
349 procedure Bind_Socket
350 (Socket : Socket_Type;
351 Address : Sock_Addr_Type)
352 is
353 Res : C.int;
354 Sin : aliased Sockaddr_In;
355 Len : constant C.int := Sin'Size / 8;
356
357 begin
358 if Address.Family = Family_Inet6 then
359 raise Socket_Error;
360 end if;
361
362 Set_Length (Sin'Unchecked_Access, Len);
363 Set_Family (Sin'Unchecked_Access, Families (Address.Family));
364 Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
365 Set_Port
366 (Sin'Unchecked_Access,
367 Short_To_Network (C.unsigned_short (Address.Port)));
368
369 Res := C_Bind (C.int (Socket), Sin'Address, Len);
370
371 if Res = Failure then
372 Raise_Socket_Error (Socket_Errno);
373 end if;
374 end Bind_Socket;
375
376 --------------------
377 -- Check_Selector --
378 --------------------
379
380 procedure Check_Selector
381 (Selector : in out Selector_Type;
382 R_Socket_Set : in out Socket_Set_Type;
383 W_Socket_Set : in out Socket_Set_Type;
384 Status : out Selector_Status;
385 Timeout : Selector_Duration := Forever)
386 is
387 E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Socket_Set)
388 begin
389 Check_Selector
390 (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
391 end Check_Selector;
392
393 procedure Check_Selector
394 (Selector : in out Selector_Type;
395 R_Socket_Set : in out Socket_Set_Type;
396 W_Socket_Set : in out Socket_Set_Type;
397 E_Socket_Set : in out Socket_Set_Type;
398 Status : out Selector_Status;
399 Timeout : Selector_Duration := Forever)
400 is
401 Res : C.int;
402 Last : C.int;
403 RSig : Socket_Type renames Selector.R_Sig_Socket;
404 RSet : Socket_Set_Type;
405 WSet : Socket_Set_Type;
406 ESet : Socket_Set_Type;
407 TVal : aliased Timeval;
408 TPtr : Timeval_Access;
409
410 begin
411 begin
412 Status := Completed;
413
414 -- No timeout or Forever is indicated by a null timeval pointer
415
416 if Timeout = Forever then
417 TPtr := null;
418 else
419 TVal := To_Timeval (Timeout);
420 TPtr := TVal'Unchecked_Access;
421 end if;
422
423 -- Copy R_Socket_Set in RSet and add read signalling socket
424
425 RSet := (Set => New_Socket_Set (R_Socket_Set.Set),
426 Last => R_Socket_Set.Last);
427 Set (RSet, RSig);
428
429 -- Copy W_Socket_Set in WSet
430
431 WSet := (Set => New_Socket_Set (W_Socket_Set.Set),
432 Last => W_Socket_Set.Last);
433
434 -- Copy E_Socket_Set in ESet
435
436 ESet := (Set => New_Socket_Set (E_Socket_Set.Set),
437 Last => E_Socket_Set.Last);
438
439 Last := C.int'Max (C.int'Max (C.int (RSet.Last),
440 C.int (WSet.Last)),
441 C.int (ESet.Last));
442
443 Res :=
444 C_Select
445 (Last + 1,
446 RSet.Set,
447 WSet.Set,
448 ESet.Set,
449 TPtr);
450
451 if Res = Failure then
452 Raise_Socket_Error (Socket_Errno);
453 end if;
454
455 -- If Select was resumed because of read signalling socket, read this
456 -- data and remove socket from set.
457
458 if Is_Set (RSet, RSig) then
459 Clear (RSet, RSig);
460
461 Res := Signalling_Fds.Read (C.int (RSig));
462
463 if Res = Failure then
464 Raise_Socket_Error (Socket_Errno);
465 end if;
466
467 Status := Aborted;
468
469 elsif Res = 0 then
470 Status := Expired;
471 end if;
472
473 -- Update RSet, WSet and ESet in regard to their new socket sets
474
475 Narrow (RSet);
476 Narrow (WSet);
477 Narrow (ESet);
478
479 -- Reset RSet as it should be if R_Sig_Socket was not added
480
481 if Is_Empty (RSet) then
482 Empty (RSet);
483 end if;
484
485 if Is_Empty (WSet) then
486 Empty (WSet);
487 end if;
488
489 if Is_Empty (ESet) then
490 Empty (ESet);
491 end if;
492
493 -- Deliver RSet, WSet and ESet
494
495 Empty (R_Socket_Set);
496 R_Socket_Set := RSet;
497
498 Empty (W_Socket_Set);
499 W_Socket_Set := WSet;
500
501 Empty (E_Socket_Set);
502 E_Socket_Set := ESet;
503
504 exception
505 when Socket_Error =>
506
507 -- The local socket sets must be emptied before propagating
508 -- Socket_Error so the associated storage is freed.
509
510 Empty (RSet);
511 Empty (WSet);
512 Empty (ESet);
513 raise;
514 end;
515 end Check_Selector;
516
517 -----------
518 -- Clear --
519 -----------
520
521 procedure Clear
522 (Item : in out Socket_Set_Type;
523 Socket : Socket_Type)
524 is
525 Last : aliased C.int := C.int (Item.Last);
526 begin
527 if Item.Last /= No_Socket then
528 Remove_Socket_From_Set (Item.Set, C.int (Socket));
529 Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
530 Item.Last := Socket_Type (Last);
531 end if;
532 end Clear;
533
534 --------------------
535 -- Close_Selector --
536 --------------------
537
538 procedure Close_Selector (Selector : in out Selector_Type) is
539 begin
540 -- Close the signalling file descriptors used internally for the
541 -- implementation of Abort_Selector.
542
543 Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
544 Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
545
546 -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
547 -- (errneous) subsequent attempt to use this selector properly fails.
548
549 Selector.R_Sig_Socket := No_Socket;
550 Selector.W_Sig_Socket := No_Socket;
551 end Close_Selector;
552
553 ------------------
554 -- Close_Socket --
555 ------------------
556
557 procedure Close_Socket (Socket : Socket_Type) is
558 Res : C.int;
559
560 begin
561 Res := C_Close (C.int (Socket));
562
563 if Res = Failure then
564 Raise_Socket_Error (Socket_Errno);
565 end if;
566 end Close_Socket;
567
568 --------------------
569 -- Connect_Socket --
570 --------------------
571
572 procedure Connect_Socket
573 (Socket : Socket_Type;
574 Server : in out Sock_Addr_Type)
575 is
576 pragma Warnings (Off, Server);
577
578 Res : C.int;
579 Sin : aliased Sockaddr_In;
580 Len : constant C.int := Sin'Size / 8;
581
582 begin
583 if Server.Family = Family_Inet6 then
584 raise Socket_Error;
585 end if;
586
587 Set_Length (Sin'Unchecked_Access, Len);
588 Set_Family (Sin'Unchecked_Access, Families (Server.Family));
589 Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
590 Set_Port
591 (Sin'Unchecked_Access,
592 Short_To_Network (C.unsigned_short (Server.Port)));
593
594 Res := C_Connect (C.int (Socket), Sin'Address, Len);
595
596 if Res = Failure then
597 Raise_Socket_Error (Socket_Errno);
598 end if;
599 end Connect_Socket;
600
601 --------------------
602 -- Control_Socket --
603 --------------------
604
605 procedure Control_Socket
606 (Socket : Socket_Type;
607 Request : in out Request_Type)
608 is
609 Arg : aliased C.int;
610 Res : C.int;
611
612 begin
613 case Request.Name is
614 when Non_Blocking_IO =>
615 Arg := C.int (Boolean'Pos (Request.Enabled));
616
617 when N_Bytes_To_Read =>
618 null;
619 end case;
620
621 Res := C_Ioctl
622 (C.int (Socket),
623 Requests (Request.Name),
624 Arg'Unchecked_Access);
625
626 if Res = Failure then
627 Raise_Socket_Error (Socket_Errno);
628 end if;
629
630 case Request.Name is
631 when Non_Blocking_IO =>
632 null;
633
634 when N_Bytes_To_Read =>
635 Request.Size := Natural (Arg);
636 end case;
637 end Control_Socket;
638
639 ----------
640 -- Copy --
641 ----------
642
643 procedure Copy
644 (Source : Socket_Set_Type;
645 Target : in out Socket_Set_Type)
646 is
647 begin
648 Empty (Target);
649 if Source.Last /= No_Socket then
650 Target.Set := New_Socket_Set (Source.Set);
651 Target.Last := Source.Last;
652 end if;
653 end Copy;
654
655 ---------------------
656 -- Create_Selector --
657 ---------------------
658
659 procedure Create_Selector (Selector : out Selector_Type) is
660 Two_Fds : aliased Fd_Pair;
661 Res : C.int;
662
663 begin
664 -- We open two signalling file descriptors. One of them is used to send
665 -- data to the other, which is included in a C_Select socket set. The
666 -- communication is used to force a call to C_Select to complete, and
667 -- the waiting task to resume its execution.
668
669 Res := Signalling_Fds.Create (Two_Fds'Access);
670
671 if Res = Failure then
672 Raise_Socket_Error (Socket_Errno);
673 end if;
674
675 Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
676 Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
677 end Create_Selector;
678
679 -------------------
680 -- Create_Socket --
681 -------------------
682
683 procedure Create_Socket
684 (Socket : out Socket_Type;
685 Family : Family_Type := Family_Inet;
686 Mode : Mode_Type := Socket_Stream)
687 is
688 Res : C.int;
689
690 begin
691 Res := C_Socket (Families (Family), Modes (Mode), 0);
692
693 if Res = Failure then
694 Raise_Socket_Error (Socket_Errno);
695 end if;
696
697 Socket := Socket_Type (Res);
698 end Create_Socket;
699
700 -----------
701 -- Empty --
702 -----------
703
704 procedure Empty (Item : in out Socket_Set_Type) is
705 begin
706 if Item.Set /= No_Socket_Set then
707 Free_Socket_Set (Item.Set);
708 Item.Set := No_Socket_Set;
709 end if;
710
711 Item.Last := No_Socket;
712 end Empty;
713
714 --------------------
715 -- Err_Code_Image --
716 --------------------
717
718 function Err_Code_Image (E : Integer) return String is
719 Msg : String := E'Img & "] ";
720 begin
721 Msg (Msg'First) := '[';
722 return Msg;
723 end Err_Code_Image;
724
725 --------------
726 -- Finalize --
727 --------------
728
729 procedure Finalize is
730 begin
731 if not Finalized
732 and then Initialized
733 then
734 Finalized := True;
735 Thin.Finalize;
736 end if;
737 end Finalize;
738
739 ---------
740 -- Get --
741 ---------
742
743 procedure Get
744 (Item : in out Socket_Set_Type;
745 Socket : out Socket_Type)
746 is
747 S : aliased C.int;
748 L : aliased C.int := C.int (Item.Last);
749
750 begin
751 if Item.Last /= No_Socket then
752 Get_Socket_From_Set
753 (Item.Set, L'Unchecked_Access, S'Unchecked_Access);
754 Item.Last := Socket_Type (L);
755 Socket := Socket_Type (S);
756 else
757 Socket := No_Socket;
758 end if;
759 end Get;
760
761 -----------------
762 -- Get_Address --
763 -----------------
764
765 function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is
766 begin
767 if Stream = null then
768 raise Socket_Error;
769 elsif Stream.all in Datagram_Socket_Stream_Type then
770 return Datagram_Socket_Stream_Type (Stream.all).From;
771 else
772 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
773 end if;
774 end Get_Address;
775
776 -------------------------
777 -- Get_Host_By_Address --
778 -------------------------
779
780 function Get_Host_By_Address
781 (Address : Inet_Addr_Type;
782 Family : Family_Type := Family_Inet) return Host_Entry_Type
783 is
784 pragma Unreferenced (Family);
785
786 HA : aliased In_Addr := To_In_Addr (Address);
787 Buflen : constant C.int := Netdb_Buffer_Size;
788 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
789 Res : aliased Hostent;
790 Err : aliased C.int;
791
792 begin
793 if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET,
794 Res'Access, Buf'Address, Buflen, Err'Access) /= 0
795 then
796 Raise_Host_Error (Integer (Err));
797 end if;
798
799 return To_Host_Entry (Res);
800 end Get_Host_By_Address;
801
802 ----------------------
803 -- Get_Host_By_Name --
804 ----------------------
805
806 function Get_Host_By_Name (Name : String) return Host_Entry_Type is
807 begin
808 -- Detect IP address name and redirect to Inet_Addr
809
810 if Is_IP_Address (Name) then
811 return Get_Host_By_Address (Inet_Addr (Name));
812 end if;
813
814 declare
815 HN : constant C.char_array := C.To_C (Name);
816 Buflen : constant C.int := Netdb_Buffer_Size;
817 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
818 Res : aliased Hostent;
819 Err : aliased C.int;
820
821 begin
822 if Safe_Gethostbyname
823 (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
824 then
825 Raise_Host_Error (Integer (Err));
826 end if;
827
828 return To_Host_Entry (Res);
829 end;
830 end Get_Host_By_Name;
831
832 -------------------
833 -- Get_Peer_Name --
834 -------------------
835
836 function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
837 Sin : aliased Sockaddr_In;
838 Len : aliased C.int := Sin'Size / 8;
839 Res : Sock_Addr_Type (Family_Inet);
840
841 begin
842 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
843 Raise_Socket_Error (Socket_Errno);
844 end if;
845
846 To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
847 Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
848
849 return Res;
850 end Get_Peer_Name;
851
852 -------------------------
853 -- Get_Service_By_Name --
854 -------------------------
855
856 function Get_Service_By_Name
857 (Name : String;
858 Protocol : String) return Service_Entry_Type
859 is
860 SN : constant C.char_array := C.To_C (Name);
861 SP : constant C.char_array := C.To_C (Protocol);
862 Buflen : constant C.int := Netdb_Buffer_Size;
863 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
864 Res : aliased Servent;
865
866 begin
867 if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
868 Ada.Exceptions.Raise_Exception
869 (Service_Error'Identity, "Service not found");
870 end if;
871
872 -- Translate from the C format to the API format
873
874 return To_Service_Entry (Res);
875 end Get_Service_By_Name;
876
877 -------------------------
878 -- Get_Service_By_Port --
879 -------------------------
880
881 function Get_Service_By_Port
882 (Port : Port_Type;
883 Protocol : String) return Service_Entry_Type
884 is
885 SP : constant C.char_array := C.To_C (Protocol);
886 Buflen : constant C.int := Netdb_Buffer_Size;
887 Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
888 Res : aliased Servent;
889
890 begin
891 if Safe_Getservbyport
892 (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
893 Res'Access, Buf'Address, Buflen) /= 0
894 then
895 Ada.Exceptions.Raise_Exception
896 (Service_Error'Identity, "Service not found");
897 end if;
898
899 -- Translate from the C format to the API format
900
901 return To_Service_Entry (Res);
902 end Get_Service_By_Port;
903
904 ---------------------
905 -- Get_Socket_Name --
906 ---------------------
907
908 function Get_Socket_Name
909 (Socket : Socket_Type) return Sock_Addr_Type
910 is
911 Sin : aliased Sockaddr_In;
912 Len : aliased C.int := Sin'Size / 8;
913 Res : C.int;
914 Addr : Sock_Addr_Type := No_Sock_Addr;
915
916 begin
917 Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
918
919 if Res /= Failure then
920 To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
921 Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
922 end if;
923
924 return Addr;
925 end Get_Socket_Name;
926
927 -----------------------
928 -- Get_Socket_Option --
929 -----------------------
930
931 function Get_Socket_Option
932 (Socket : Socket_Type;
933 Level : Level_Type := Socket_Level;
934 Name : Option_Name) return Option_Type
935 is
936 use type C.unsigned_char;
937
938 V8 : aliased Two_Ints;
939 V4 : aliased C.int;
940 V1 : aliased C.unsigned_char;
941 VT : aliased Timeval;
942 Len : aliased C.int;
943 Add : System.Address;
944 Res : C.int;
945 Opt : Option_Type (Name);
946
947 begin
948 case Name is
949 when Multicast_Loop |
950 Multicast_TTL =>
951 Len := V1'Size / 8;
952 Add := V1'Address;
953
954 when Keep_Alive |
955 Reuse_Address |
956 Broadcast |
957 No_Delay |
958 Send_Buffer |
959 Receive_Buffer |
960 Multicast_If |
961 Error =>
962 Len := V4'Size / 8;
963 Add := V4'Address;
964
965 when Send_Timeout |
966 Receive_Timeout =>
967 Len := VT'Size / 8;
968 Add := VT'Address;
969
970 when Linger |
971 Add_Membership |
972 Drop_Membership =>
973 Len := V8'Size / 8;
974 Add := V8'Address;
975
976 end case;
977
978 Res :=
979 C_Getsockopt
980 (C.int (Socket),
981 Levels (Level),
982 Options (Name),
983 Add, Len'Access);
984
985 if Res = Failure then
986 Raise_Socket_Error (Socket_Errno);
987 end if;
988
989 case Name is
990 when Keep_Alive |
991 Reuse_Address |
992 Broadcast |
993 No_Delay =>
994 Opt.Enabled := (V4 /= 0);
995
996 when Linger =>
997 Opt.Enabled := (V8 (V8'First) /= 0);
998 Opt.Seconds := Natural (V8 (V8'Last));
999
1000 when Send_Buffer |
1001 Receive_Buffer =>
1002 Opt.Size := Natural (V4);
1003
1004 when Error =>
1005 Opt.Error := Resolve_Error (Integer (V4));
1006
1007 when Add_Membership |
1008 Drop_Membership =>
1009 To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1010 To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1011
1012 when Multicast_If =>
1013 To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1014
1015 when Multicast_TTL =>
1016 Opt.Time_To_Live := Integer (V1);
1017
1018 when Multicast_Loop =>
1019 Opt.Enabled := (V1 /= 0);
1020
1021 when Send_Timeout |
1022 Receive_Timeout =>
1023 Opt.Timeout := To_Duration (VT);
1024 end case;
1025
1026 return Opt;
1027 end Get_Socket_Option;
1028
1029 ---------------
1030 -- Host_Name --
1031 ---------------
1032
1033 function Host_Name return String is
1034 Name : aliased C.char_array (1 .. 64);
1035 Res : C.int;
1036
1037 begin
1038 Res := C_Gethostname (Name'Address, Name'Length);
1039
1040 if Res = Failure then
1041 Raise_Socket_Error (Socket_Errno);
1042 end if;
1043
1044 return C.To_Ada (Name);
1045 end Host_Name;
1046
1047 -----------
1048 -- Image --
1049 -----------
1050
1051 function Image
1052 (Val : Inet_Addr_VN_Type;
1053 Hex : Boolean := False) return String
1054 is
1055 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1056 -- has at most a length of 3 plus one '.' character.
1057
1058 Buffer : String (1 .. 4 * Val'Length);
1059 Length : Natural := 1;
1060 Separator : Character;
1061
1062 procedure Img10 (V : Inet_Addr_Comp_Type);
1063 -- Append to Buffer image of V in decimal format
1064
1065 procedure Img16 (V : Inet_Addr_Comp_Type);
1066 -- Append to Buffer image of V in hexadecimal format
1067
1068 -----------
1069 -- Img10 --
1070 -----------
1071
1072 procedure Img10 (V : Inet_Addr_Comp_Type) is
1073 Img : constant String := V'Img;
1074 Len : constant Natural := Img'Length - 1;
1075 begin
1076 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1077 Length := Length + Len;
1078 end Img10;
1079
1080 -----------
1081 -- Img16 --
1082 -----------
1083
1084 procedure Img16 (V : Inet_Addr_Comp_Type) is
1085 begin
1086 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
1087 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1088 Length := Length + 2;
1089 end Img16;
1090
1091 -- Start of processing for Image
1092
1093 begin
1094 if Hex then
1095 Separator := ':';
1096 else
1097 Separator := '.';
1098 end if;
1099
1100 for J in Val'Range loop
1101 if Hex then
1102 Img16 (Val (J));
1103 else
1104 Img10 (Val (J));
1105 end if;
1106
1107 if J /= Val'Last then
1108 Buffer (Length) := Separator;
1109 Length := Length + 1;
1110 end if;
1111 end loop;
1112
1113 return Buffer (1 .. Length - 1);
1114 end Image;
1115
1116 -----------
1117 -- Image --
1118 -----------
1119
1120 function Image (Value : Inet_Addr_Type) return String is
1121 begin
1122 if Value.Family = Family_Inet then
1123 return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1124 else
1125 return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1126 end if;
1127 end Image;
1128
1129 -----------
1130 -- Image --
1131 -----------
1132
1133 function Image (Value : Sock_Addr_Type) return String is
1134 Port : constant String := Value.Port'Img;
1135 begin
1136 return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1137 end Image;
1138
1139 -----------
1140 -- Image --
1141 -----------
1142
1143 function Image (Socket : Socket_Type) return String is
1144 begin
1145 return Socket'Img;
1146 end Image;
1147
1148 ---------------
1149 -- Inet_Addr --
1150 ---------------
1151
1152 function Inet_Addr (Image : String) return Inet_Addr_Type is
1153 use Interfaces.C.Strings;
1154
1155 Img : chars_ptr;
1156 Res : C.int;
1157 Result : Inet_Addr_Type;
1158
1159 begin
1160 -- Special case for the all-ones broadcast address: this address has the
1161 -- same in_addr_t value as Failure, and thus cannot be properly returned
1162 -- by inet_addr(3).
1163
1164 if Image = "255.255.255.255" then
1165 return Broadcast_Inet_Addr;
1166
1167 -- Special case for an empty Image as on some platforms (e.g. Windows)
1168 -- calling Inet_Addr("") will not return an error.
1169
1170 elsif Image = "" then
1171 Raise_Socket_Error (Constants.EINVAL);
1172 end if;
1173
1174 Img := New_String (Image);
1175 Res := C_Inet_Addr (Img);
1176 Free (Img);
1177
1178 if Res = Failure then
1179 Raise_Socket_Error (Constants.EINVAL);
1180 end if;
1181
1182 To_Inet_Addr (To_In_Addr (Res), Result);
1183 return Result;
1184 end Inet_Addr;
1185
1186 ----------------
1187 -- Initialize --
1188 ----------------
1189
1190 procedure Initialize (Process_Blocking_IO : Boolean) is
1191 Expected : constant Boolean := not Constants.Thread_Blocking_IO;
1192 begin
1193 if Process_Blocking_IO /= Expected then
1194 raise Socket_Error with
1195 "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1196 end if;
1197
1198 Initialize;
1199 end Initialize;
1200
1201 ----------------
1202 -- Initialize --
1203 ----------------
1204
1205 procedure Initialize is
1206 begin
1207 if not Initialized then
1208 Initialized := True;
1209 Thin.Initialize;
1210 end if;
1211 end Initialize;
1212
1213 --------------
1214 -- Is_Empty --
1215 --------------
1216
1217 function Is_Empty (Item : Socket_Set_Type) return Boolean is
1218 begin
1219 return Item.Last = No_Socket;
1220 end Is_Empty;
1221
1222 -------------------
1223 -- Is_IP_Address --
1224 -------------------
1225
1226 function Is_IP_Address (Name : String) return Boolean is
1227 begin
1228 for J in Name'Range loop
1229 if Name (J) /= '.'
1230 and then Name (J) not in '0' .. '9'
1231 then
1232 return False;
1233 end if;
1234 end loop;
1235
1236 return True;
1237 end Is_IP_Address;
1238
1239 ------------
1240 -- Is_Set --
1241 ------------
1242
1243 function Is_Set
1244 (Item : Socket_Set_Type;
1245 Socket : Socket_Type) return Boolean
1246 is
1247 begin
1248 return Item.Last /= No_Socket
1249 and then Socket <= Item.Last
1250 and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
1251 end Is_Set;
1252
1253 -------------------
1254 -- Listen_Socket --
1255 -------------------
1256
1257 procedure Listen_Socket
1258 (Socket : Socket_Type;
1259 Length : Positive := 15)
1260 is
1261 Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1262 begin
1263 if Res = Failure then
1264 Raise_Socket_Error (Socket_Errno);
1265 end if;
1266 end Listen_Socket;
1267
1268 ------------
1269 -- Narrow --
1270 ------------
1271
1272 procedure Narrow (Item : in out Socket_Set_Type) is
1273 Last : aliased C.int := C.int (Item.Last);
1274 begin
1275 if Item.Set /= No_Socket_Set then
1276 Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
1277 Item.Last := Socket_Type (Last);
1278 end if;
1279 end Narrow;
1280
1281 -------------------
1282 -- Official_Name --
1283 -------------------
1284
1285 function Official_Name (E : Host_Entry_Type) return String is
1286 begin
1287 return To_String (E.Official);
1288 end Official_Name;
1289
1290 -------------------
1291 -- Official_Name --
1292 -------------------
1293
1294 function Official_Name (S : Service_Entry_Type) return String is
1295 begin
1296 return To_String (S.Official);
1297 end Official_Name;
1298
1299 -----------------
1300 -- Port_Number --
1301 -----------------
1302
1303 function Port_Number (S : Service_Entry_Type) return Port_Type is
1304 begin
1305 return S.Port;
1306 end Port_Number;
1307
1308 -------------------
1309 -- Protocol_Name --
1310 -------------------
1311
1312 function Protocol_Name (S : Service_Entry_Type) return String is
1313 begin
1314 return To_String (S.Protocol);
1315 end Protocol_Name;
1316
1317 ----------------------
1318 -- Raise_Host_Error --
1319 ----------------------
1320
1321 procedure Raise_Host_Error (H_Error : Integer) is
1322 begin
1323 Ada.Exceptions.Raise_Exception (Host_Error'Identity,
1324 Err_Code_Image (H_Error)
1325 & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error)));
1326 end Raise_Host_Error;
1327
1328 ------------------------
1329 -- Raise_Socket_Error --
1330 ------------------------
1331
1332 procedure Raise_Socket_Error (Error : Integer) is
1333 use type C.Strings.chars_ptr;
1334 begin
1335 Ada.Exceptions.Raise_Exception (Socket_Error'Identity,
1336 Err_Code_Image (Error)
1337 & C.Strings.Value (Socket_Error_Message (Error)));
1338 end Raise_Socket_Error;
1339
1340 ----------
1341 -- Read --
1342 ----------
1343
1344 procedure Read
1345 (Stream : in out Datagram_Socket_Stream_Type;
1346 Item : out Ada.Streams.Stream_Element_Array;
1347 Last : out Ada.Streams.Stream_Element_Offset)
1348 is
1349 First : Ada.Streams.Stream_Element_Offset := Item'First;
1350 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1351 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1352
1353 begin
1354 loop
1355 Receive_Socket
1356 (Stream.Socket,
1357 Item (First .. Max),
1358 Index,
1359 Stream.From);
1360
1361 Last := Index;
1362
1363 -- Exit when all or zero data received. Zero means that the socket
1364 -- peer is closed.
1365
1366 exit when Index < First or else Index = Max;
1367
1368 First := Index + 1;
1369 end loop;
1370 end Read;
1371
1372 ----------
1373 -- Read --
1374 ----------
1375
1376 procedure Read
1377 (Stream : in out Stream_Socket_Stream_Type;
1378 Item : out Ada.Streams.Stream_Element_Array;
1379 Last : out Ada.Streams.Stream_Element_Offset)
1380 is
1381 pragma Warnings (Off, Stream);
1382
1383 First : Ada.Streams.Stream_Element_Offset := Item'First;
1384 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1385 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1386
1387 begin
1388 loop
1389 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1390 Last := Index;
1391
1392 -- Exit when all or zero data received. Zero means that the socket
1393 -- peer is closed.
1394
1395 exit when Index < First or else Index = Max;
1396
1397 First := Index + 1;
1398 end loop;
1399 end Read;
1400
1401 --------------------
1402 -- Receive_Socket --
1403 --------------------
1404
1405 procedure Receive_Socket
1406 (Socket : Socket_Type;
1407 Item : out Ada.Streams.Stream_Element_Array;
1408 Last : out Ada.Streams.Stream_Element_Offset;
1409 Flags : Request_Flag_Type := No_Request_Flag)
1410 is
1411 Res : C.int;
1412
1413 begin
1414 Res :=
1415 C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1416
1417 if Res = Failure then
1418 Raise_Socket_Error (Socket_Errno);
1419 end if;
1420
1421 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1422 end Receive_Socket;
1423
1424 --------------------
1425 -- Receive_Socket --
1426 --------------------
1427
1428 procedure Receive_Socket
1429 (Socket : Socket_Type;
1430 Item : out Ada.Streams.Stream_Element_Array;
1431 Last : out Ada.Streams.Stream_Element_Offset;
1432 From : out Sock_Addr_Type;
1433 Flags : Request_Flag_Type := No_Request_Flag)
1434 is
1435 Res : C.int;
1436 Sin : aliased Sockaddr_In;
1437 Len : aliased C.int := Sin'Size / 8;
1438
1439 begin
1440 Res :=
1441 C_Recvfrom
1442 (C.int (Socket),
1443 Item'Address,
1444 Item'Length,
1445 To_Int (Flags),
1446 Sin'Unchecked_Access,
1447 Len'Access);
1448
1449 if Res = Failure then
1450 Raise_Socket_Error (Socket_Errno);
1451 end if;
1452
1453 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1454
1455 To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1456 From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1457 end Receive_Socket;
1458
1459 -------------------
1460 -- Resolve_Error --
1461 -------------------
1462
1463 function Resolve_Error
1464 (Error_Value : Integer;
1465 From_Errno : Boolean := True) return Error_Type
1466 is
1467 use GNAT.Sockets.Constants;
1468
1469 begin
1470 if not From_Errno then
1471 case Error_Value is
1472 when Constants.HOST_NOT_FOUND => return Unknown_Host;
1473 when Constants.TRY_AGAIN => return Host_Name_Lookup_Failure;
1474 when Constants.NO_RECOVERY => return Non_Recoverable_Error;
1475 when Constants.NO_DATA => return Unknown_Server_Error;
1476 when others => return Cannot_Resolve_Error;
1477 end case;
1478 end if;
1479
1480 case Error_Value is
1481 when ENOERROR => return Success;
1482 when EACCES => return Permission_Denied;
1483 when EADDRINUSE => return Address_Already_In_Use;
1484 when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address;
1485 when EAFNOSUPPORT => return
1486 Address_Family_Not_Supported_By_Protocol;
1487 when EALREADY => return Operation_Already_In_Progress;
1488 when EBADF => return Bad_File_Descriptor;
1489 when ECONNABORTED => return Software_Caused_Connection_Abort;
1490 when ECONNREFUSED => return Connection_Refused;
1491 when ECONNRESET => return Connection_Reset_By_Peer;
1492 when EDESTADDRREQ => return Destination_Address_Required;
1493 when EFAULT => return Bad_Address;
1494 when EHOSTDOWN => return Host_Is_Down;
1495 when EHOSTUNREACH => return No_Route_To_Host;
1496 when EINPROGRESS => return Operation_Now_In_Progress;
1497 when EINTR => return Interrupted_System_Call;
1498 when EINVAL => return Invalid_Argument;
1499 when EIO => return Input_Output_Error;
1500 when EISCONN => return Transport_Endpoint_Already_Connected;
1501 when ELOOP => return Too_Many_Symbolic_Links;
1502 when EMFILE => return Too_Many_Open_Files;
1503 when EMSGSIZE => return Message_Too_Long;
1504 when ENAMETOOLONG => return File_Name_Too_Long;
1505 when ENETDOWN => return Network_Is_Down;
1506 when ENETRESET => return
1507 Network_Dropped_Connection_Because_Of_Reset;
1508 when ENETUNREACH => return Network_Is_Unreachable;
1509 when ENOBUFS => return No_Buffer_Space_Available;
1510 when ENOPROTOOPT => return Protocol_Not_Available;
1511 when ENOTCONN => return Transport_Endpoint_Not_Connected;
1512 when ENOTSOCK => return Socket_Operation_On_Non_Socket;
1513 when EOPNOTSUPP => return Operation_Not_Supported;
1514 when EPFNOSUPPORT => return Protocol_Family_Not_Supported;
1515 when EPROTONOSUPPORT => return Protocol_Not_Supported;
1516 when EPROTOTYPE => return Protocol_Wrong_Type_For_Socket;
1517 when ESHUTDOWN => return
1518 Cannot_Send_After_Transport_Endpoint_Shutdown;
1519 when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1520 when ETIMEDOUT => return Connection_Timed_Out;
1521 when ETOOMANYREFS => return Too_Many_References;
1522 when EWOULDBLOCK => return Resource_Temporarily_Unavailable;
1523 when others => null;
1524 end case;
1525
1526 return Cannot_Resolve_Error;
1527 end Resolve_Error;
1528
1529 -----------------------
1530 -- Resolve_Exception --
1531 -----------------------
1532
1533 function Resolve_Exception
1534 (Occurrence : Exception_Occurrence) return Error_Type
1535 is
1536 Id : constant Exception_Id := Exception_Identity (Occurrence);
1537 Msg : constant String := Exception_Message (Occurrence);
1538 First : Natural;
1539 Last : Natural;
1540 Val : Integer;
1541
1542 begin
1543 First := Msg'First;
1544 while First <= Msg'Last
1545 and then Msg (First) not in '0' .. '9'
1546 loop
1547 First := First + 1;
1548 end loop;
1549
1550 if First > Msg'Last then
1551 return Cannot_Resolve_Error;
1552 end if;
1553
1554 Last := First;
1555 while Last < Msg'Last
1556 and then Msg (Last + 1) in '0' .. '9'
1557 loop
1558 Last := Last + 1;
1559 end loop;
1560
1561 Val := Integer'Value (Msg (First .. Last));
1562
1563 if Id = Socket_Error_Id then
1564 return Resolve_Error (Val);
1565 elsif Id = Host_Error_Id then
1566 return Resolve_Error (Val, False);
1567 else
1568 return Cannot_Resolve_Error;
1569 end if;
1570 end Resolve_Exception;
1571
1572 --------------------
1573 -- Receive_Vector --
1574 --------------------
1575
1576 procedure Receive_Vector
1577 (Socket : Socket_Type;
1578 Vector : Vector_Type;
1579 Count : out Ada.Streams.Stream_Element_Count)
1580 is
1581 Res : C.int;
1582
1583 begin
1584 Res :=
1585 C_Readv
1586 (C.int (Socket),
1587 Vector'Address,
1588 Vector'Length);
1589
1590 if Res = Failure then
1591 Raise_Socket_Error (Socket_Errno);
1592 end if;
1593
1594 Count := Ada.Streams.Stream_Element_Count (Res);
1595 end Receive_Vector;
1596
1597 -----------------
1598 -- Send_Socket --
1599 -----------------
1600
1601 procedure Send_Socket
1602 (Socket : Socket_Type;
1603 Item : Ada.Streams.Stream_Element_Array;
1604 Last : out Ada.Streams.Stream_Element_Offset;
1605 Flags : Request_Flag_Type := No_Request_Flag)
1606 is
1607 Res : C.int;
1608
1609 begin
1610 Res :=
1611 C_Send
1612 (C.int (Socket),
1613 Item'Address,
1614 Item'Length,
1615 Set_Forced_Flags (To_Int (Flags)));
1616
1617 if Res = Failure then
1618 Raise_Socket_Error (Socket_Errno);
1619 end if;
1620
1621 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1622 end Send_Socket;
1623
1624 -----------------
1625 -- Send_Socket --
1626 -----------------
1627
1628 procedure Send_Socket
1629 (Socket : Socket_Type;
1630 Item : Ada.Streams.Stream_Element_Array;
1631 Last : out Ada.Streams.Stream_Element_Offset;
1632 To : Sock_Addr_Type;
1633 Flags : Request_Flag_Type := No_Request_Flag)
1634 is
1635 Res : C.int;
1636 Sin : aliased Sockaddr_In;
1637 Len : constant C.int := Sin'Size / 8;
1638
1639 begin
1640 Set_Length (Sin'Unchecked_Access, Len);
1641 Set_Family (Sin'Unchecked_Access, Families (To.Family));
1642 Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
1643 Set_Port
1644 (Sin'Unchecked_Access,
1645 Short_To_Network (C.unsigned_short (To.Port)));
1646
1647 Res := C_Sendto
1648 (C.int (Socket),
1649 Item'Address,
1650 Item'Length,
1651 Set_Forced_Flags (To_Int (Flags)),
1652 Sin'Unchecked_Access,
1653 Len);
1654
1655 if Res = Failure then
1656 Raise_Socket_Error (Socket_Errno);
1657 end if;
1658
1659 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1660 end Send_Socket;
1661
1662 -----------------
1663 -- Send_Vector --
1664 -----------------
1665
1666 procedure Send_Vector
1667 (Socket : Socket_Type;
1668 Vector : Vector_Type;
1669 Count : out Ada.Streams.Stream_Element_Count)
1670 is
1671 Res : C.int;
1672 Iov_Count : C.int;
1673 This_Iov_Count : C.int;
1674
1675 begin
1676 Count := 0;
1677 Iov_Count := 0;
1678 while Iov_Count < Vector'Length loop
1679
1680 pragma Warnings (Off);
1681 -- Following test may be compile time known on some targets
1682
1683 if Vector'Length - Iov_Count > Constants.IOV_MAX then
1684 This_Iov_Count := Constants.IOV_MAX;
1685 else
1686 This_Iov_Count := Vector'Length - Iov_Count;
1687 end if;
1688
1689 pragma Warnings (On);
1690
1691 Res :=
1692 C_Writev
1693 (C.int (Socket),
1694 Vector (Vector'First + Integer (Iov_Count))'Address,
1695 This_Iov_Count);
1696
1697 if Res = Failure then
1698 Raise_Socket_Error (Socket_Errno);
1699 end if;
1700
1701 Count := Count + Ada.Streams.Stream_Element_Count (Res);
1702 Iov_Count := Iov_Count + This_Iov_Count;
1703 end loop;
1704 end Send_Vector;
1705
1706 ---------
1707 -- Set --
1708 ---------
1709
1710 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1711 begin
1712 if Item.Set = No_Socket_Set then
1713 Item.Set := New_Socket_Set (No_Socket_Set);
1714 Item.Last := Socket;
1715
1716 elsif Item.Last < Socket then
1717 Item.Last := Socket;
1718 end if;
1719
1720 Insert_Socket_In_Set (Item.Set, C.int (Socket));
1721 end Set;
1722
1723 ----------------------
1724 -- Set_Forced_Flags --
1725 ----------------------
1726
1727 function Set_Forced_Flags (F : C.int) return C.int is
1728 use type C.unsigned;
1729 function To_unsigned is
1730 new Ada.Unchecked_Conversion (C.int, C.unsigned);
1731 function To_int is
1732 new Ada.Unchecked_Conversion (C.unsigned, C.int);
1733 begin
1734 return To_int (To_unsigned (F) or Constants.MSG_Forced_Flags);
1735 end Set_Forced_Flags;
1736
1737 -----------------------
1738 -- Set_Socket_Option --
1739 -----------------------
1740
1741 procedure Set_Socket_Option
1742 (Socket : Socket_Type;
1743 Level : Level_Type := Socket_Level;
1744 Option : Option_Type)
1745 is
1746 V8 : aliased Two_Ints;
1747 V4 : aliased C.int;
1748 V1 : aliased C.unsigned_char;
1749 VT : aliased Timeval;
1750 Len : C.int;
1751 Add : System.Address := Null_Address;
1752 Res : C.int;
1753
1754 begin
1755 case Option.Name is
1756 when Keep_Alive |
1757 Reuse_Address |
1758 Broadcast |
1759 No_Delay =>
1760 V4 := C.int (Boolean'Pos (Option.Enabled));
1761 Len := V4'Size / 8;
1762 Add := V4'Address;
1763
1764 when Linger =>
1765 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1766 V8 (V8'Last) := C.int (Option.Seconds);
1767 Len := V8'Size / 8;
1768 Add := V8'Address;
1769
1770 when Send_Buffer |
1771 Receive_Buffer =>
1772 V4 := C.int (Option.Size);
1773 Len := V4'Size / 8;
1774 Add := V4'Address;
1775
1776 when Error =>
1777 V4 := C.int (Boolean'Pos (True));
1778 Len := V4'Size / 8;
1779 Add := V4'Address;
1780
1781 when Add_Membership |
1782 Drop_Membership =>
1783 V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
1784 V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
1785 Len := V8'Size / 8;
1786 Add := V8'Address;
1787
1788 when Multicast_If =>
1789 V4 := To_Int (To_In_Addr (Option.Outgoing_If));
1790 Len := V4'Size / 8;
1791 Add := V4'Address;
1792
1793 when Multicast_TTL =>
1794 V1 := C.unsigned_char (Option.Time_To_Live);
1795 Len := V1'Size / 8;
1796 Add := V1'Address;
1797
1798 when Multicast_Loop =>
1799 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
1800 Len := V1'Size / 8;
1801 Add := V1'Address;
1802
1803 when Send_Timeout |
1804 Receive_Timeout =>
1805 VT := To_Timeval (Option.Timeout);
1806 Len := VT'Size / 8;
1807 Add := VT'Address;
1808
1809 end case;
1810
1811 Res := C_Setsockopt
1812 (C.int (Socket),
1813 Levels (Level),
1814 Options (Option.Name),
1815 Add, Len);
1816
1817 if Res = Failure then
1818 Raise_Socket_Error (Socket_Errno);
1819 end if;
1820 end Set_Socket_Option;
1821
1822 ----------------------
1823 -- Short_To_Network --
1824 ----------------------
1825
1826 function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
1827 use type C.unsigned_short;
1828
1829 begin
1830 -- Big-endian case. No conversion needed. On these platforms,
1831 -- htons() defaults to a null procedure.
1832
1833 pragma Warnings (Off);
1834 -- Since the test can generate "always True/False" warning
1835
1836 if Default_Bit_Order = High_Order_First then
1837 return S;
1838
1839 pragma Warnings (On);
1840
1841 -- Little-endian case. We must swap the high and low bytes of this
1842 -- short to make the port number network compliant.
1843
1844 else
1845 return (S / 256) + (S mod 256) * 256;
1846 end if;
1847 end Short_To_Network;
1848
1849 ---------------------
1850 -- Shutdown_Socket --
1851 ---------------------
1852
1853 procedure Shutdown_Socket
1854 (Socket : Socket_Type;
1855 How : Shutmode_Type := Shut_Read_Write)
1856 is
1857 Res : C.int;
1858
1859 begin
1860 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1861
1862 if Res = Failure then
1863 Raise_Socket_Error (Socket_Errno);
1864 end if;
1865 end Shutdown_Socket;
1866
1867 ------------
1868 -- Stream --
1869 ------------
1870
1871 function Stream
1872 (Socket : Socket_Type;
1873 Send_To : Sock_Addr_Type) return Stream_Access
1874 is
1875 S : Datagram_Socket_Stream_Access;
1876
1877 begin
1878 S := new Datagram_Socket_Stream_Type;
1879 S.Socket := Socket;
1880 S.To := Send_To;
1881 S.From := Get_Socket_Name (Socket);
1882 return Stream_Access (S);
1883 end Stream;
1884
1885 ------------
1886 -- Stream --
1887 ------------
1888
1889 function Stream (Socket : Socket_Type) return Stream_Access is
1890 S : Stream_Socket_Stream_Access;
1891 begin
1892 S := new Stream_Socket_Stream_Type;
1893 S.Socket := Socket;
1894 return Stream_Access (S);
1895 end Stream;
1896
1897 ----------
1898 -- To_C --
1899 ----------
1900
1901 function To_C (Socket : Socket_Type) return Integer is
1902 begin
1903 return Integer (Socket);
1904 end To_C;
1905
1906 -----------------
1907 -- To_Duration --
1908 -----------------
1909
1910 function To_Duration (Val : Timeval) return Timeval_Duration is
1911 begin
1912 return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
1913 end To_Duration;
1914
1915 -------------------
1916 -- To_Host_Entry --
1917 -------------------
1918
1919 function To_Host_Entry (E : Hostent) return Host_Entry_Type is
1920 use type C.size_t;
1921
1922 Official : constant String :=
1923 C.Strings.Value (E.H_Name);
1924
1925 Aliases : constant Chars_Ptr_Array :=
1926 Chars_Ptr_Pointers.Value (E.H_Aliases);
1927 -- H_Aliases points to a list of name aliases. The list is terminated by
1928 -- a NULL pointer.
1929
1930 Addresses : constant In_Addr_Access_Array :=
1931 In_Addr_Access_Pointers.Value (E.H_Addr_List);
1932 -- H_Addr_List points to a list of binary addresses (in network byte
1933 -- order). The list is terminated by a NULL pointer.
1934 --
1935 -- H_Length is not used because it is currently only set to 4.
1936 -- H_Addrtype is always AF_INET
1937
1938 Result : Host_Entry_Type
1939 (Aliases_Length => Aliases'Length - 1,
1940 Addresses_Length => Addresses'Length - 1);
1941 -- The last element is a null pointer
1942
1943 Source : C.size_t;
1944 Target : Natural;
1945
1946 begin
1947 Result.Official := To_Name (Official);
1948
1949 Source := Aliases'First;
1950 Target := Result.Aliases'First;
1951 while Target <= Result.Aliases_Length loop
1952 Result.Aliases (Target) :=
1953 To_Name (C.Strings.Value (Aliases (Source)));
1954 Source := Source + 1;
1955 Target := Target + 1;
1956 end loop;
1957
1958 Source := Addresses'First;
1959 Target := Result.Addresses'First;
1960 while Target <= Result.Addresses_Length loop
1961 To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
1962 Source := Source + 1;
1963 Target := Target + 1;
1964 end loop;
1965
1966 return Result;
1967 end To_Host_Entry;
1968
1969 ----------------
1970 -- To_In_Addr --
1971 ----------------
1972
1973 function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1974 begin
1975 if Addr.Family = Family_Inet then
1976 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1977 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1978 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1979 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1980 end if;
1981
1982 raise Socket_Error;
1983 end To_In_Addr;
1984
1985 ------------------
1986 -- To_Inet_Addr --
1987 ------------------
1988
1989 procedure To_Inet_Addr
1990 (Addr : In_Addr;
1991 Result : out Inet_Addr_Type) is
1992 begin
1993 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1994 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1995 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
1996 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
1997 end To_Inet_Addr;
1998
1999 ------------
2000 -- To_Int --
2001 ------------
2002
2003 function To_Int (F : Request_Flag_Type) return C.int
2004 is
2005 Current : Request_Flag_Type := F;
2006 Result : C.int := 0;
2007
2008 begin
2009 for J in Flags'Range loop
2010 exit when Current = 0;
2011
2012 if Current mod 2 /= 0 then
2013 if Flags (J) = -1 then
2014 Raise_Socket_Error (Constants.EOPNOTSUPP);
2015 end if;
2016
2017 Result := Result + Flags (J);
2018 end if;
2019
2020 Current := Current / 2;
2021 end loop;
2022
2023 return Result;
2024 end To_Int;
2025
2026 -------------
2027 -- To_Name --
2028 -------------
2029
2030 function To_Name (N : String) return Name_Type is
2031 begin
2032 return Name_Type'(N'Length, N);
2033 end To_Name;
2034
2035 ----------------------
2036 -- To_Service_Entry --
2037 ----------------------
2038
2039 function To_Service_Entry (E : Servent) return Service_Entry_Type is
2040 use type C.size_t;
2041
2042 Official : constant String := C.Strings.Value (E.S_Name);
2043
2044 Aliases : constant Chars_Ptr_Array :=
2045 Chars_Ptr_Pointers.Value (E.S_Aliases);
2046 -- S_Aliases points to a list of name aliases. The list is
2047 -- terminated by a NULL pointer.
2048
2049 Protocol : constant String := C.Strings.Value (E.S_Proto);
2050
2051 Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
2052 -- The last element is a null pointer
2053
2054 Source : C.size_t;
2055 Target : Natural;
2056
2057 begin
2058 Result.Official := To_Name (Official);
2059
2060 Source := Aliases'First;
2061 Target := Result.Aliases'First;
2062 while Target <= Result.Aliases_Length loop
2063 Result.Aliases (Target) :=
2064 To_Name (C.Strings.Value (Aliases (Source)));
2065 Source := Source + 1;
2066 Target := Target + 1;
2067 end loop;
2068
2069 Result.Port :=
2070 Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2071
2072 Result.Protocol := To_Name (Protocol);
2073 return Result;
2074 end To_Service_Entry;
2075
2076 ---------------
2077 -- To_String --
2078 ---------------
2079
2080 function To_String (HN : Name_Type) return String is
2081 begin
2082 return HN.Name (1 .. HN.Length);
2083 end To_String;
2084
2085 ----------------
2086 -- To_Timeval --
2087 ----------------
2088
2089 function To_Timeval (Val : Timeval_Duration) return Timeval is
2090 S : time_t;
2091 uS : suseconds_t;
2092
2093 begin
2094 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2095
2096 if Val = 0.0 then
2097 S := 0;
2098 uS := 0;
2099
2100 -- Normal case where we do round down
2101
2102 else
2103 S := time_t (Val - 0.5);
2104 uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2105 end if;
2106
2107 return (S, uS);
2108 end To_Timeval;
2109
2110 -----------
2111 -- Write --
2112 -----------
2113
2114 procedure Write
2115 (Stream : in out Datagram_Socket_Stream_Type;
2116 Item : Ada.Streams.Stream_Element_Array)
2117 is
2118 pragma Warnings (Off, Stream);
2119
2120 First : Ada.Streams.Stream_Element_Offset := Item'First;
2121 Index : Ada.Streams.Stream_Element_Offset := First - 1;
2122 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2123
2124 begin
2125 loop
2126 Send_Socket
2127 (Stream.Socket,
2128 Item (First .. Max),
2129 Index,
2130 Stream.To);
2131
2132 -- Exit when all or zero data sent. Zero means that the socket has
2133 -- been closed by peer.
2134
2135 exit when Index < First or else Index = Max;
2136
2137 First := Index + 1;
2138 end loop;
2139
2140 if Index /= Max then
2141 raise Socket_Error;
2142 end if;
2143 end Write;
2144
2145 -----------
2146 -- Write --
2147 -----------
2148
2149 procedure Write
2150 (Stream : in out Stream_Socket_Stream_Type;
2151 Item : Ada.Streams.Stream_Element_Array)
2152 is
2153 pragma Warnings (Off, Stream);
2154
2155 First : Ada.Streams.Stream_Element_Offset := Item'First;
2156 Index : Ada.Streams.Stream_Element_Offset := First - 1;
2157 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2158
2159 begin
2160 loop
2161 Send_Socket (Stream.Socket, Item (First .. Max), Index);
2162
2163 -- Exit when all or zero data sent. Zero means that the socket has
2164 -- been closed by peer.
2165
2166 exit when Index < First or else Index = Max;
2167
2168 First := Index + 1;
2169 end loop;
2170
2171 if Index /= Max then
2172 raise Socket_Error;
2173 end if;
2174 end Write;
2175
2176 end GNAT.Sockets;
Mirror of the offical gcc git repository hosted at gcc.gnu.org