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