?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / g-socket.adb
blob3b794b729302f113bbc921ad5d4e1b7f4767f582
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 -- $Revision$
10 -- --
11 -- Copyright (C) 2001 Ada Core Technologies, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
30 -- --
31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
32 -- --
33 ------------------------------------------------------------------------------
34
35 with Ada.Streams; use Ada.Streams;
36 with Ada.Exceptions; use Ada.Exceptions;
37 with Ada.Unchecked_Deallocation;
38 with Ada.Unchecked_Conversion;
39
40 with Interfaces.C.Strings;
41
42 with GNAT.OS_Lib; use GNAT.OS_Lib;
43 with GNAT.Sockets.Constants;
44 with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
45 with GNAT.Task_Lock;
46
47 with GNAT.Sockets.Linker_Options;
48 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
49 -- Need to include pragma Linker_Options which is platform dependent.
50
51 with System; use System;
52
53 package body GNAT.Sockets is
54
55 use type C.int, System.Address;
56
57 Finalized : Boolean := False;
58 Initialized : Boolean := False;
59
60 -- Correspondance tables
61
62 Families : constant array (Family_Type) of C.int :=
63 (Family_Inet => Constants.AF_INET,
64 Family_Inet6 => Constants.AF_INET6);
65
66 Levels : constant array (Level_Type) of C.int :=
67 (Socket_Level => Constants.SOL_SOCKET,
68 IP_Protocol_For_IP_Level => Constants.IPPROTO_IP,
69 IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
70 IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);
71
72 Modes : constant array (Mode_Type) of C.int :=
73 (Socket_Stream => Constants.SOCK_STREAM,
74 Socket_Datagram => Constants.SOCK_DGRAM);
75
76 Shutmodes : constant array (Shutmode_Type) of C.int :=
77 (Shut_Read => Constants.SHUT_RD,
78 Shut_Write => Constants.SHUT_WR,
79 Shut_Read_Write => Constants.SHUT_RDWR);
80
81 Requests : constant array (Request_Name) of C.int :=
82 (Non_Blocking_IO => Constants.FIONBIO,
83 N_Bytes_To_Read => Constants.FIONREAD);
84
85 Options : constant array (Option_Name) of C.int :=
86 (Keep_Alive => Constants.SO_KEEPALIVE,
87 Reuse_Address => Constants.SO_REUSEADDR,
88 Broadcast => Constants.SO_BROADCAST,
89 Send_Buffer => Constants.SO_SNDBUF,
90 Receive_Buffer => Constants.SO_RCVBUF,
91 Linger => Constants.SO_LINGER,
92 Error => Constants.SO_ERROR,
93 No_Delay => Constants.TCP_NODELAY,
94 Add_Membership => Constants.IP_ADD_MEMBERSHIP,
95 Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
96 Multicast_TTL => Constants.IP_MULTICAST_TTL,
97 Multicast_Loop => Constants.IP_MULTICAST_LOOP);
98
99 Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
100 Host_Error_Id : constant Exception_Id := Host_Error'Identity;
101
102 Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
103 -- Use to print in hexadecimal format
104
105 function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
106 function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int);
107
108 -----------------------
109 -- Local subprograms --
110 -----------------------
111
112 function Resolve_Error
113 (Error_Value : Integer;
114 From_Errno : Boolean := True)
115 return Error_Type;
116 -- Associate an enumeration value (error_type) to en error value
117 -- (errno). From_Errno prevents from mixing h_errno with errno.
118
119 function To_Host_Name (N : String) return Host_Name_Type;
120 function To_String (HN : Host_Name_Type) return String;
121 -- Conversion functions
122
123 function Port_To_Network
124 (Port : C.unsigned_short)
125 return C.unsigned_short;
126 pragma Inline (Port_To_Network);
127 -- Convert a port number into a network port number
128
129 function Network_To_Port
130 (Net_Port : C.unsigned_short)
131 return C.unsigned_short
132 renames Port_To_Network;
133 -- Symetric operation
134
135 function Image
136 (Val : Inet_Addr_VN_Type;
137 Hex : Boolean := False)
138 return String;
139 -- Output an array of inet address components either in
140 -- hexadecimal or in decimal mode.
141
142 function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr;
143 function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type;
144 -- Conversion functions
145
146 function To_Host_Entry (Host : Hostent) return Host_Entry_Type;
147 -- Conversion function
148
149 function To_Timeval (Val : Duration) return Timeval;
150 -- Separate Val in seconds and microseconds
151
152 procedure Raise_Socket_Error (Error : Integer);
153 -- Raise Socket_Error with an exception message describing
154 -- the error code.
155
156 procedure Raise_Host_Error (Error : Integer);
157 -- Raise Host_Error exception with message describing error code
158 -- (note hstrerror seems to be obsolete).
159
160 -- Types needed for Socket_Set_Type
161
162 type Socket_Set_Record is new Fd_Set;
163
164 procedure Free is
165 new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type);
166
167 -- Types needed for Datagram_Socket_Stream_Type
168
169 type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
170 Socket : Socket_Type;
171 To : Sock_Addr_Type;
172 From : Sock_Addr_Type;
173 end record;
174
175 type Datagram_Socket_Stream_Access is
176 access all Datagram_Socket_Stream_Type;
177
178 procedure Read
179 (Stream : in out Datagram_Socket_Stream_Type;
180 Item : out Ada.Streams.Stream_Element_Array;
181 Last : out Ada.Streams.Stream_Element_Offset);
182
183 procedure Write
184 (Stream : in out Datagram_Socket_Stream_Type;
185 Item : Ada.Streams.Stream_Element_Array);
186
187 -- Types needed for Stream_Socket_Stream_Type
188
189 type Stream_Socket_Stream_Type is new Root_Stream_Type with record
190 Socket : Socket_Type;
191 end record;
192
193 type Stream_Socket_Stream_Access is
194 access all Stream_Socket_Stream_Type;
195
196 procedure Read
197 (Stream : in out Stream_Socket_Stream_Type;
198 Item : out Ada.Streams.Stream_Element_Array;
199 Last : out Ada.Streams.Stream_Element_Offset);
200
201 procedure Write
202 (Stream : in out Stream_Socket_Stream_Type;
203 Item : Ada.Streams.Stream_Element_Array);
204
205 --------------------
206 -- Abort_Selector --
207 --------------------
208
209 procedure Abort_Selector (Selector : Selector_Type) is
210 begin
211 -- Send an empty array to unblock C select system call
212
213 if Selector.In_Progress then
214 declare
215 Buf : Character;
216 Res : C.int;
217 begin
218 Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0);
219 end;
220 end if;
221 end Abort_Selector;
222
223 -------------------
224 -- Accept_Socket --
225 -------------------
226
227 procedure Accept_Socket
228 (Server : Socket_Type;
229 Socket : out Socket_Type;
230 Address : out Sock_Addr_Type)
231 is
232 Res : C.int;
233 Sin : aliased Sockaddr_In;
234 Len : aliased C.int := Sin'Size / 8;
235
236 begin
237 Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
238 if Res = Failure then
239 Raise_Socket_Error (Socket_Errno);
240 end if;
241
242 Socket := Socket_Type (Res);
243
244 Address.Addr := To_Inet_Addr (Sin.Sin_Addr);
245 Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
246 end Accept_Socket;
247
248 ---------------
249 -- Addresses --
250 ---------------
251
252 function Addresses
253 (E : Host_Entry_Type;
254 N : Positive := 1)
255 return Inet_Addr_Type
256 is
257 begin
258 return E.Addresses (N);
259 end Addresses;
260
261 ----------------------
262 -- Addresses_Length --
263 ----------------------
264
265 function Addresses_Length (E : Host_Entry_Type) return Natural is
266 begin
267 return E.Addresses_Length;
268 end Addresses_Length;
269
270 -------------
271 -- Aliases --
272 -------------
273
274 function Aliases
275 (E : Host_Entry_Type;
276 N : Positive := 1)
277 return String
278 is
279 begin
280 return To_String (E.Aliases (N));
281 end Aliases;
282
283 --------------------
284 -- Aliases_Length --
285 --------------------
286
287 function Aliases_Length (E : Host_Entry_Type) return Natural is
288 begin
289 return E.Aliases_Length;
290 end Aliases_Length;
291
292 -----------------
293 -- Bind_Socket --
294 -----------------
295
296 procedure Bind_Socket
297 (Socket : Socket_Type;
298 Address : Sock_Addr_Type)
299 is
300 Res : C.int;
301 Sin : aliased Sockaddr_In;
302 Len : aliased C.int := Sin'Size / 8;
303
304 begin
305 if Address.Family = Family_Inet6 then
306 raise Socket_Error;
307 end if;
308
309 Sin.Sin_Family := C.unsigned_short (Families (Address.Family));
310 Sin.Sin_Port := Port_To_Network (C.unsigned_short (Address.Port));
311
312 Res := C_Bind (C.int (Socket), Sin'Address, Len);
313
314 if Res = Failure then
315 Raise_Socket_Error (Socket_Errno);
316 end if;
317 end Bind_Socket;
318
319 --------------------
320 -- Check_Selector --
321 --------------------
322
323 procedure Check_Selector
324 (Selector : in out Selector_Type;
325 R_Socket_Set : in out Socket_Set_Type;
326 W_Socket_Set : in out Socket_Set_Type;
327 Status : out Selector_Status;
328 Timeout : Duration := Forever)
329 is
330 Res : C.int;
331 Len : C.int;
332 RSet : aliased Fd_Set;
333 WSet : aliased Fd_Set;
334 TVal : aliased Timeval;
335 TPtr : Timeval_Access;
336
337 begin
338 Status := Completed;
339
340 -- No timeout or Forever is indicated by a null timeval pointer.
341
342 if Timeout = Forever then
343 TPtr := null;
344 else
345 TVal := To_Timeval (Timeout);
346 TPtr := TVal'Unchecked_Access;
347 end if;
348
349 -- Copy R_Socket_Set in RSet and add read signalling socket.
350
351 if R_Socket_Set = null then
352 RSet := Null_Fd_Set;
353 else
354 RSet := Fd_Set (R_Socket_Set.all);
355 end if;
356
357 Set (RSet, C.int (Selector.R_Sig_Socket));
358 Len := Max (RSet) + 1;
359
360 -- Copy W_Socket_Set in WSet.
361
362 if W_Socket_Set = null then
363 WSet := Null_Fd_Set;
364 else
365 WSet := Fd_Set (W_Socket_Set.all);
366 end if;
367 Len := C.int'Max (Max (RSet) + 1, Len);
368
369 Selector.In_Progress := True;
370 Res :=
371 C_Select
372 (Len,
373 RSet'Unchecked_Access,
374 WSet'Unchecked_Access,
375 null, TPtr);
376 Selector.In_Progress := False;
377
378 -- If Select was resumed because of read signalling socket,
379 -- read this data and remove socket from set.
380
381 if Is_Set (RSet, C.int (Selector.R_Sig_Socket)) then
382 Clear (RSet, C.int (Selector.R_Sig_Socket));
383
384 declare
385 Buf : Character;
386 begin
387 Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0);
388 end;
389
390 -- Select was resumed because of read signalling socket, but
391 -- the call is said aborted only when there is no other read
392 -- or write event.
393
394 if Is_Empty (RSet)
395 and then Is_Empty (WSet)
396 then
397 Status := Aborted;
398 end if;
399
400 elsif Res = 0 then
401 Status := Expired;
402 end if;
403
404 if R_Socket_Set /= null then
405 R_Socket_Set.all := Socket_Set_Record (RSet);
406 end if;
407
408 if W_Socket_Set /= null then
409 W_Socket_Set.all := Socket_Set_Record (WSet);
410 end if;
411 end Check_Selector;
412
413 -----------
414 -- Clear --
415 -----------
416
417 procedure Clear
418 (Item : in out Socket_Set_Type;
419 Socket : Socket_Type)
420 is
421 begin
422 if Item = null then
423 Item := new Socket_Set_Record;
424 Empty (Fd_Set (Item.all));
425 end if;
426
427 Clear (Fd_Set (Item.all), C.int (Socket));
428 end Clear;
429
430 --------------------
431 -- Close_Selector --
432 --------------------
433
434 procedure Close_Selector (Selector : in out Selector_Type) is
435 begin
436 begin
437 Close_Socket (Selector.R_Sig_Socket);
438 exception when Socket_Error =>
439 null;
440 end;
441
442 begin
443 Close_Socket (Selector.W_Sig_Socket);
444 exception when Socket_Error =>
445 null;
446 end;
447 end Close_Selector;
448
449 ------------------
450 -- Close_Socket --
451 ------------------
452
453 procedure Close_Socket (Socket : Socket_Type) is
454 Res : C.int;
455
456 begin
457 Res := C_Close (C.int (Socket));
458
459 if Res = Failure then
460 Raise_Socket_Error (Socket_Errno);
461 end if;
462 end Close_Socket;
463
464 --------------------
465 -- Connect_Socket --
466 --------------------
467
468 procedure Connect_Socket
469 (Socket : Socket_Type;
470 Server : in out Sock_Addr_Type)
471 is
472 Res : C.int;
473 Sin : aliased Sockaddr_In;
474 Len : aliased C.int := Sin'Size / 8;
475
476 begin
477 if Server.Family = Family_Inet6 then
478 raise Socket_Error;
479 end if;
480
481 Sin.Sin_Family := C.unsigned_short (Families (Server.Family));
482 Sin.Sin_Addr := To_In_Addr (Server.Addr);
483 Sin.Sin_Port := Port_To_Network (C.unsigned_short (Server.Port));
484
485 Res := C_Connect (C.int (Socket), Sin'Address, Len);
486
487 if Res = Failure then
488 Raise_Socket_Error (Socket_Errno);
489 end if;
490 end Connect_Socket;
491
492 --------------------
493 -- Control_Socket --
494 --------------------
495
496 procedure Control_Socket
497 (Socket : Socket_Type;
498 Request : in out Request_Type)
499 is
500 Arg : aliased C.int;
501 Res : C.int;
502
503 begin
504 case Request.Name is
505 when Non_Blocking_IO =>
506 Arg := C.int (Boolean'Pos (Request.Enabled));
507
508 when N_Bytes_To_Read =>
509 null;
510
511 end case;
512
513 Res := C_Ioctl
514 (C.int (Socket),
515 Requests (Request.Name),
516 Arg'Unchecked_Access);
517
518 if Res = Failure then
519 Raise_Socket_Error (Socket_Errno);
520 end if;
521
522 case Request.Name is
523 when Non_Blocking_IO =>
524 null;
525
526 when N_Bytes_To_Read =>
527 Request.Size := Natural (Arg);
528
529 end case;
530 end Control_Socket;
531
532 ---------------------
533 -- Create_Selector --
534 ---------------------
535
536 procedure Create_Selector (Selector : out Selector_Type) is
537 S0 : C.int;
538 S1 : C.int;
539 S2 : C.int;
540 Res : C.int;
541 Sin : aliased Sockaddr_In;
542 Len : aliased C.int := Sin'Size / 8;
543 Err : Integer;
544
545 begin
546 -- We open two signalling sockets. One socket to send a signal
547 -- to a another socket that always included in a C_Select
548 -- socket set. When received, it resumes the task suspended in
549 -- C_Select.
550
551 -- Create a listening socket
552
553 S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
554 if S0 = Failure then
555 Raise_Socket_Error (Socket_Errno);
556 end if;
557
558 -- Sin is already correctly initialized. Bind the socket to any
559 -- unused port.
560
561 Res := C_Bind (S0, Sin'Address, Len);
562 if Res = Failure then
563 Err := Socket_Errno;
564 Res := C_Close (S0);
565 Raise_Socket_Error (Err);
566 end if;
567
568 -- Get the port used by the socket
569
570 Res := C_Getsockname (S0, Sin'Address, Len'Access);
571 if Res = Failure then
572 Err := Socket_Errno;
573 Res := C_Close (S0);
574 Raise_Socket_Error (Err);
575 end if;
576
577 Res := C_Listen (S0, 2);
578 if Res = Failure then
579 Err := Socket_Errno;
580 Res := C_Close (S0);
581 Raise_Socket_Error (Err);
582 end if;
583
584 S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
585 if S1 = Failure then
586 Err := Socket_Errno;
587 Res := C_Close (S0);
588 Raise_Socket_Error (Err);
589 end if;
590
591 -- Use INADDR_LOOPBACK
592
593 Sin.Sin_Addr.S_B1 := 127;
594 Sin.Sin_Addr.S_B2 := 0;
595 Sin.Sin_Addr.S_B3 := 0;
596 Sin.Sin_Addr.S_B4 := 1;
597
598 -- Do a connect and accept the connection
599
600 Res := C_Connect (S1, Sin'Address, Len);
601 if Res = Failure then
602 Err := Socket_Errno;
603 Res := C_Close (S0);
604 Res := C_Close (S1);
605 Raise_Socket_Error (Err);
606 end if;
607
608 S2 := C_Accept (S0, Sin'Address, Len'Access);
609 if S2 = Failure then
610 Err := Socket_Errno;
611 Res := C_Close (S0);
612 Res := C_Close (S1);
613 Raise_Socket_Error (Err);
614 end if;
615
616 Res := C_Close (S0);
617 if Res = Failure then
618 Raise_Socket_Error (Socket_Errno);
619 end if;
620
621 Selector.R_Sig_Socket := Socket_Type (S1);
622 Selector.W_Sig_Socket := Socket_Type (S2);
623 end Create_Selector;
624
625 -------------------
626 -- Create_Socket --
627 -------------------
628
629 procedure Create_Socket
630 (Socket : out Socket_Type;
631 Family : Family_Type := Family_Inet;
632 Mode : Mode_Type := Socket_Stream)
633 is
634 Res : C.int;
635
636 begin
637 Res := C_Socket (Families (Family), Modes (Mode), 0);
638
639 if Res = Failure then
640 Raise_Socket_Error (Socket_Errno);
641 end if;
642
643 Socket := Socket_Type (Res);
644 end Create_Socket;
645
646 -----------
647 -- Empty --
648 -----------
649
650 procedure Empty (Item : in out Socket_Set_Type) is
651 begin
652 if Item /= null then
653 Free (Item);
654 end if;
655 end Empty;
656
657 --------------
658 -- Finalize --
659 --------------
660
661 procedure Finalize is
662 begin
663 if not Finalized
664 and then Initialized
665 then
666 Finalized := True;
667 Thin.Finalize;
668 end if;
669 end Finalize;
670
671 -----------------
672 -- Get_Address --
673 -----------------
674
675 function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is
676 begin
677 if Stream = null then
678 raise Socket_Error;
679
680 elsif Stream.all in Datagram_Socket_Stream_Type then
681 return Datagram_Socket_Stream_Type (Stream.all).From;
682
683 else
684 return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
685 end if;
686 end Get_Address;
687
688 -------------------------
689 -- Get_Host_By_Address --
690 -------------------------
691
692 function Get_Host_By_Address
693 (Address : Inet_Addr_Type;
694 Family : Family_Type := Family_Inet)
695 return Host_Entry_Type
696 is
697 HA : aliased In_Addr := To_In_Addr (Address);
698 Res : Hostent_Access;
699 Err : Integer;
700
701 begin
702 -- This C function is not always thread-safe. Protect against
703 -- concurrent access.
704
705 Task_Lock.Lock;
706 Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET);
707
708 if Res = null then
709 Err := Socket_Errno;
710 Task_Lock.Unlock;
711 Raise_Host_Error (Err);
712 end if;
713
714 -- Translate from the C format to the API format
715
716 declare
717 HE : Host_Entry_Type := To_Host_Entry (Res.all);
718
719 begin
720 Task_Lock.Unlock;
721 return HE;
722 end;
723 end Get_Host_By_Address;
724
725 ----------------------
726 -- Get_Host_By_Name --
727 ----------------------
728
729 function Get_Host_By_Name
730 (Name : String)
731 return Host_Entry_Type
732 is
733 HN : C.char_array := C.To_C (Name);
734 Res : Hostent_Access;
735 Err : Integer;
736
737 begin
738 -- This C function is not always thread-safe. Protect against
739 -- concurrent access.
740
741 Task_Lock.Lock;
742 Res := C_Gethostbyname (HN);
743
744 if Res = null then
745 Err := Socket_Errno;
746 Task_Lock.Unlock;
747 Raise_Host_Error (Err);
748 end if;
749
750 -- Translate from the C format to the API format
751
752 declare
753 HE : Host_Entry_Type := To_Host_Entry (Res.all);
754
755 begin
756 Task_Lock.Unlock;
757 return HE;
758 end;
759 end Get_Host_By_Name;
760
761 -------------------
762 -- Get_Peer_Name --
763 -------------------
764
765 function Get_Peer_Name
766 (Socket : Socket_Type)
767 return Sock_Addr_Type
768 is
769 Sin : aliased Sockaddr_In;
770 Len : aliased C.int := Sin'Size / 8;
771 Res : Sock_Addr_Type (Family_Inet);
772
773 begin
774 if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
775 Raise_Socket_Error (Socket_Errno);
776 end if;
777
778 Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
779 Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
780
781 return Res;
782 end Get_Peer_Name;
783
784 ---------------------
785 -- Get_Socket_Name --
786 ---------------------
787
788 function Get_Socket_Name
789 (Socket : Socket_Type)
790 return Sock_Addr_Type
791 is
792 Sin : aliased Sockaddr_In;
793 Len : aliased C.int := Sin'Size / 8;
794 Res : Sock_Addr_Type (Family_Inet);
795
796 begin
797 if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then
798 Raise_Socket_Error (Socket_Errno);
799 end if;
800
801 Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
802 Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
803
804 return Res;
805 end Get_Socket_Name;
806
807 -----------------------
808 -- Get_Socket_Option --
809 -----------------------
810
811 function Get_Socket_Option
812 (Socket : Socket_Type;
813 Level : Level_Type := Socket_Level;
814 Name : Option_Name)
815 return Option_Type
816 is
817 use type C.unsigned_char;
818
819 V8 : aliased Two_Int;
820 V4 : aliased C.int;
821 V1 : aliased C.unsigned_char;
822 Len : aliased C.int;
823 Add : System.Address;
824 Res : C.int;
825 Opt : Option_Type (Name);
826
827 begin
828 case Name is
829 when Multicast_Loop |
830 Multicast_TTL =>
831 Len := V1'Size / 8;
832 Add := V1'Address;
833
834 when Keep_Alive |
835 Reuse_Address |
836 Broadcast |
837 No_Delay |
838 Send_Buffer |
839 Receive_Buffer |
840 Error =>
841 Len := V4'Size / 8;
842 Add := V4'Address;
843
844 when Linger |
845 Add_Membership |
846 Drop_Membership =>
847 Len := V8'Size / 8;
848 Add := V8'Address;
849
850 end case;
851
852 Res := C_Getsockopt
853 (C.int (Socket),
854 Levels (Level),
855 Options (Name),
856 Add, Len'Unchecked_Access);
857
858 if Res = Failure then
859 Raise_Socket_Error (Socket_Errno);
860 end if;
861
862 case Name is
863 when Keep_Alive |
864 Reuse_Address |
865 Broadcast |
866 No_Delay =>
867 Opt.Enabled := (V4 /= 0);
868
869 when Linger =>
870 Opt.Enabled := (V8 (V8'First) /= 0);
871 Opt.Seconds := Natural (V8 (V8'Last));
872
873 when Send_Buffer |
874 Receive_Buffer =>
875 Opt.Size := Natural (V4);
876
877 when Error =>
878 Opt.Error := Resolve_Error (Integer (V4));
879
880 when Add_Membership |
881 Drop_Membership =>
882 Opt.Multiaddr := To_Inet_Addr (To_In_Addr (V8 (V8'First)));
883 Opt.Interface := To_Inet_Addr (To_In_Addr (V8 (V8'Last)));
884
885 when Multicast_TTL =>
886 Opt.Time_To_Live := Integer (V1);
887
888 when Multicast_Loop =>
889 Opt.Enabled := (V1 /= 0);
890
891 end case;
892
893 return Opt;
894 end Get_Socket_Option;
895
896 ---------------
897 -- Host_Name --
898 ---------------
899
900 function Host_Name return String is
901 Name : aliased C.char_array (1 .. 64);
902 Res : C.int;
903
904 begin
905 Res := C_Gethostname (Name'Address, Name'Length);
906
907 if Res = Failure then
908 Raise_Socket_Error (Socket_Errno);
909 end if;
910
911 return C.To_Ada (Name);
912 end Host_Name;
913
914 -----------
915 -- Image --
916 -----------
917
918 function Image
919 (Val : Inet_Addr_VN_Type;
920 Hex : Boolean := False)
921 return String
922 is
923 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
924 -- has at most a length of 3 plus one '.' character.
925
926 Buffer : String (1 .. 4 * Val'Length);
927 Length : Natural := 1;
928 Separator : Character;
929
930 procedure Img10 (V : Inet_Addr_Comp_Type);
931 -- Append to Buffer image of V in decimal format
932
933 procedure Img16 (V : Inet_Addr_Comp_Type);
934 -- Append to Buffer image of V in hexadecimal format
935
936 procedure Img10 (V : Inet_Addr_Comp_Type) is
937 Img : constant String := V'Img;
938 Len : Natural := Img'Length - 1;
939
940 begin
941 Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
942 Length := Length + Len;
943 end Img10;
944
945 procedure Img16 (V : Inet_Addr_Comp_Type) is
946 begin
947 Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
948 Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
949 Length := Length + 2;
950 end Img16;
951
952 -- Start of processing for Image
953
954 begin
955 if Hex then
956 Separator := ':';
957 else
958 Separator := '.';
959 end if;
960
961 for J in Val'Range loop
962 if Hex then
963 Img16 (Val (J));
964 else
965 Img10 (Val (J));
966 end if;
967
968 if J /= Val'Last then
969 Buffer (Length) := Separator;
970 Length := Length + 1;
971 end if;
972 end loop;
973
974 return Buffer (1 .. Length - 1);
975 end Image;
976
977 -----------
978 -- Image --
979 -----------
980
981 function Image (Value : Inet_Addr_Type) return String is
982 begin
983 if Value.Family = Family_Inet then
984 return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
985 else
986 return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
987 end if;
988 end Image;
989
990 -----------
991 -- Image --
992 -----------
993
994 function Image (Value : Sock_Addr_Type) return String is
995 Port : constant String := Value.Port'Img;
996
997 begin
998 return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
999 end Image;
1000
1001 -----------
1002 -- Image --
1003 -----------
1004
1005 function Image (Socket : Socket_Type) return String is
1006 begin
1007 return Socket'Img;
1008 end Image;
1009
1010 ---------------
1011 -- Inet_Addr --
1012 ---------------
1013
1014 function Inet_Addr (Image : String) return Inet_Addr_Type is
1015 use Interfaces.C.Strings;
1016
1017 Img : chars_ptr := New_String (Image);
1018 Res : C.int;
1019 Err : Integer;
1020
1021 begin
1022 Res := C_Inet_Addr (Img);
1023 Err := Errno;
1024 Free (Img);
1025
1026 if Res = Failure then
1027 Raise_Socket_Error (Err);
1028 end if;
1029
1030 return To_Inet_Addr (To_In_Addr (Res));
1031 end Inet_Addr;
1032
1033 ----------------
1034 -- Initialize --
1035 ----------------
1036
1037 procedure Initialize (Process_Blocking_IO : Boolean := False) is
1038 begin
1039 if not Initialized then
1040 Initialized := True;
1041 Thin.Initialize (Process_Blocking_IO);
1042 end if;
1043 end Initialize;
1044
1045 --------------
1046 -- Is_Empty --
1047 --------------
1048
1049 function Is_Empty (Item : Socket_Set_Type) return Boolean is
1050 begin
1051 return Item = null or else Is_Empty (Fd_Set (Item.all));
1052 end Is_Empty;
1053
1054 ------------
1055 -- Is_Set --
1056 ------------
1057
1058 function Is_Set
1059 (Item : Socket_Set_Type;
1060 Socket : Socket_Type) return Boolean
1061 is
1062 begin
1063 return Item /= null
1064 and then Is_Set (Fd_Set (Item.all), C.int (Socket));
1065 end Is_Set;
1066
1067 -------------------
1068 -- Listen_Socket --
1069 -------------------
1070
1071 procedure Listen_Socket
1072 (Socket : Socket_Type;
1073 Length : Positive := 15)
1074 is
1075 Res : C.int;
1076
1077 begin
1078 Res := C_Listen (C.int (Socket), C.int (Length));
1079 if Res = Failure then
1080 Raise_Socket_Error (Socket_Errno);
1081 end if;
1082 end Listen_Socket;
1083
1084 -------------------
1085 -- Official_Name --
1086 -------------------
1087
1088 function Official_Name (E : Host_Entry_Type) return String is
1089 begin
1090 return To_String (E.Official);
1091 end Official_Name;
1092
1093 ---------------------
1094 -- Port_To_Network --
1095 ---------------------
1096
1097 function Port_To_Network
1098 (Port : C.unsigned_short)
1099 return C.unsigned_short
1100 is
1101 use type C.unsigned_short;
1102 begin
1103 if Default_Bit_Order = High_Order_First then
1104
1105 -- No conversion needed. On these platforms, htons() defaults
1106 -- to a null procedure.
1107
1108 return Port;
1109
1110 else
1111 -- We need to swap the high and low byte on this short to make
1112 -- the port number network compliant.
1113
1114 return (Port / 256) + (Port mod 256) * 256;
1115 end if;
1116 end Port_To_Network;
1117
1118 ----------------------
1119 -- Raise_Host_Error --
1120 ----------------------
1121
1122 procedure Raise_Host_Error (Error : Integer) is
1123
1124 function Error_Message return String;
1125 -- We do not use a C function like strerror because hstrerror
1126 -- that would correspond seems to be obsolete. Return
1127 -- appropriate string for error value.
1128
1129 function Error_Message return String is
1130 begin
1131 case Error is
1132 when Constants.HOST_NOT_FOUND => return "Host not found";
1133 when Constants.TRY_AGAIN => return "Try again";
1134 when Constants.NO_RECOVERY => return "No recovery";
1135 when Constants.NO_ADDRESS => return "No address";
1136 when others => return "Unknown error";
1137 end case;
1138 end Error_Message;
1139
1140 -- Start of processing for Raise_Host_Error
1141
1142 begin
1143 Ada.Exceptions.Raise_Exception (Host_Error'Identity, Error_Message);
1144 end Raise_Host_Error;
1145
1146 ------------------------
1147 -- Raise_Socket_Error --
1148 ------------------------
1149
1150 procedure Raise_Socket_Error (Error : Integer) is
1151 use type C.Strings.chars_ptr;
1152
1153 function Image (E : Integer) return String;
1154 function Image (E : Integer) return String is
1155 Msg : String := E'Img & "] ";
1156 begin
1157 Msg (Msg'First) := '[';
1158 return Msg;
1159 end Image;
1160
1161 begin
1162 Ada.Exceptions.Raise_Exception
1163 (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error));
1164 end Raise_Socket_Error;
1165
1166 ----------
1167 -- Read --
1168 ----------
1169
1170 procedure Read
1171 (Stream : in out Datagram_Socket_Stream_Type;
1172 Item : out Ada.Streams.Stream_Element_Array;
1173 Last : out Ada.Streams.Stream_Element_Offset)
1174 is
1175 First : Ada.Streams.Stream_Element_Offset := Item'First;
1176 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1177 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1178
1179 begin
1180 loop
1181 Receive_Socket
1182 (Stream.Socket,
1183 Item (First .. Max),
1184 Index,
1185 Stream.From);
1186
1187 Last := Index;
1188
1189 -- Exit when all or zero data received. Zero means that
1190 -- the socket peer is closed.
1191
1192 exit when Index < First or else Index = Max;
1193
1194 First := Index + 1;
1195 end loop;
1196 end Read;
1197
1198 ----------
1199 -- Read --
1200 ----------
1201
1202 procedure Read
1203 (Stream : in out Stream_Socket_Stream_Type;
1204 Item : out Ada.Streams.Stream_Element_Array;
1205 Last : out Ada.Streams.Stream_Element_Offset)
1206 is
1207 First : Ada.Streams.Stream_Element_Offset := Item'First;
1208 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1209 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1210
1211 begin
1212 loop
1213 Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1214 Last := Index;
1215
1216 -- Exit when all or zero data received. Zero means that
1217 -- the socket peer is closed.
1218
1219 exit when Index < First or else Index = Max;
1220
1221 First := Index + 1;
1222 end loop;
1223 end Read;
1224
1225 -------------------
1226 -- Resolve_Error --
1227 -------------------
1228
1229 function Resolve_Error
1230 (Error_Value : Integer;
1231 From_Errno : Boolean := True)
1232 return Error_Type
1233 is
1234 use GNAT.Sockets.Constants;
1235
1236 begin
1237 if not From_Errno then
1238 case Error_Value is
1239 when HOST_NOT_FOUND => return Unknown_Host;
1240 when TRY_AGAIN => return Host_Name_Lookup_Failure;
1241 when NO_RECOVERY => return No_Address_Associated_With_Name;
1242 when NO_ADDRESS => return Unknown_Server_Error;
1243 when others => return Cannot_Resolve_Error;
1244 end case;
1245 end if;
1246 case Error_Value is
1247 when EACCES => return Permission_Denied;
1248 when EADDRINUSE => return Address_Already_In_Use;
1249 when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address;
1250 when EAFNOSUPPORT =>
1251 return Address_Family_Not_Supported_By_Protocol;
1252 when EALREADY => return Operation_Already_In_Progress;
1253 when EBADF => return Bad_File_Descriptor;
1254 when ECONNREFUSED => return Connection_Refused;
1255 when EFAULT => return Bad_Address;
1256 when EINPROGRESS => return Operation_Now_In_Progress;
1257 when EINTR => return Interrupted_System_Call;
1258 when EINVAL => return Invalid_Argument;
1259 when EIO => return Input_Output_Error;
1260 when EISCONN => return Transport_Endpoint_Already_Connected;
1261 when EMSGSIZE => return Message_Too_Long;
1262 when ENETUNREACH => return Network_Is_Unreachable;
1263 when ENOBUFS => return No_Buffer_Space_Available;
1264 when ENOPROTOOPT => return Protocol_Not_Available;
1265 when ENOTCONN => return Transport_Endpoint_Not_Connected;
1266 when EOPNOTSUPP => return Operation_Not_Supported;
1267 when EPROTONOSUPPORT => return Protocol_Not_Supported;
1268 when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1269 when ETIMEDOUT => return Connection_Timed_Out;
1270 when EWOULDBLOCK => return Resource_Temporarily_Unavailable;
1271 when others => return Cannot_Resolve_Error;
1272 end case;
1273 end Resolve_Error;
1274
1275 -----------------------
1276 -- Resolve_Exception --
1277 -----------------------
1278
1279 function Resolve_Exception
1280 (Occurrence : Exception_Occurrence)
1281 return Error_Type
1282 is
1283 Id : Exception_Id := Exception_Identity (Occurrence);
1284 Msg : constant String := Exception_Message (Occurrence);
1285 First : Natural := Msg'First;
1286 Last : Natural;
1287 Val : Integer;
1288
1289 begin
1290 while First <= Msg'Last
1291 and then Msg (First) not in '0' .. '9'
1292 loop
1293 First := First + 1;
1294 end loop;
1295
1296 if First > Msg'Last then
1297 return Cannot_Resolve_Error;
1298 end if;
1299
1300 Last := First;
1301
1302 while Last < Msg'Last
1303 and then Msg (Last + 1) in '0' .. '9'
1304 loop
1305 Last := Last + 1;
1306 end loop;
1307
1308 Val := Integer'Value (Msg (First .. Last));
1309
1310 if Id = Socket_Error_Id then
1311 return Resolve_Error (Val);
1312
1313 elsif Id = Host_Error_Id then
1314 return Resolve_Error (Val, False);
1315
1316 else
1317 return Cannot_Resolve_Error;
1318 end if;
1319 end Resolve_Exception;
1320
1321 --------------------
1322 -- Receive_Socket --
1323 --------------------
1324
1325 procedure Receive_Socket
1326 (Socket : Socket_Type;
1327 Item : out Ada.Streams.Stream_Element_Array;
1328 Last : out Ada.Streams.Stream_Element_Offset)
1329 is
1330 use type Ada.Streams.Stream_Element_Offset;
1331
1332 Res : C.int;
1333
1334 begin
1335 Res := C_Recv
1336 (C.int (Socket),
1337 Item (Item'First)'Address,
1338 Item'Length, 0);
1339
1340 if Res = Failure then
1341 Raise_Socket_Error (Socket_Errno);
1342 end if;
1343
1344 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1345 end Receive_Socket;
1346
1347 --------------------
1348 -- Receive_Socket --
1349 --------------------
1350
1351 procedure Receive_Socket
1352 (Socket : Socket_Type;
1353 Item : out Ada.Streams.Stream_Element_Array;
1354 Last : out Ada.Streams.Stream_Element_Offset;
1355 From : out Sock_Addr_Type)
1356 is
1357 use type Ada.Streams.Stream_Element_Offset;
1358
1359 Res : C.int;
1360 Sin : aliased Sockaddr_In;
1361 Len : aliased C.int := Sin'Size / 8;
1362
1363 begin
1364 Res := C_Recvfrom
1365 (C.int (Socket),
1366 Item (Item'First)'Address,
1367 Item'Length, 0,
1368 Sin'Unchecked_Access,
1369 Len'Unchecked_Access);
1370
1371 if Res = Failure then
1372 Raise_Socket_Error (Socket_Errno);
1373 end if;
1374
1375 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1376
1377 From.Addr := To_Inet_Addr (Sin.Sin_Addr);
1378 From.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
1379 end Receive_Socket;
1380
1381 -----------------
1382 -- Send_Socket --
1383 -----------------
1384
1385 procedure Send_Socket
1386 (Socket : Socket_Type;
1387 Item : Ada.Streams.Stream_Element_Array;
1388 Last : out Ada.Streams.Stream_Element_Offset)
1389 is
1390 use type Ada.Streams.Stream_Element_Offset;
1391
1392 Res : C.int;
1393
1394 begin
1395 Res := C_Send
1396 (C.int (Socket),
1397 Item (Item'First)'Address,
1398 Item'Length, 0);
1399
1400 if Res = Failure then
1401 Raise_Socket_Error (Socket_Errno);
1402 end if;
1403
1404 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1405 end Send_Socket;
1406
1407 -----------------
1408 -- Send_Socket --
1409 -----------------
1410
1411 procedure Send_Socket
1412 (Socket : Socket_Type;
1413 Item : Ada.Streams.Stream_Element_Array;
1414 Last : out Ada.Streams.Stream_Element_Offset;
1415 To : Sock_Addr_Type)
1416 is
1417 use type Ada.Streams.Stream_Element_Offset;
1418
1419 Res : C.int;
1420 Sin : aliased Sockaddr_In;
1421 Len : aliased C.int := Sin'Size / 8;
1422
1423 begin
1424 Sin.Sin_Family := C.unsigned_short (Families (To.Family));
1425 Sin.Sin_Addr := To_In_Addr (To.Addr);
1426 Sin.Sin_Port := Port_To_Network (C.unsigned_short (To.Port));
1427
1428 Res := C_Sendto
1429 (C.int (Socket),
1430 Item (Item'First)'Address,
1431 Item'Length, 0,
1432 Sin'Unchecked_Access,
1433 Len);
1434
1435 if Res = Failure then
1436 Raise_Socket_Error (Socket_Errno);
1437 end if;
1438
1439 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1440 end Send_Socket;
1441
1442 ---------
1443 -- Set --
1444 ---------
1445
1446 procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1447 begin
1448 if Item = null then
1449 Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set));
1450 end if;
1451
1452 Set (Fd_Set (Item.all), C.int (Socket));
1453 end Set;
1454
1455 -----------------------
1456 -- Set_Socket_Option --
1457 -----------------------
1458
1459 procedure Set_Socket_Option
1460 (Socket : Socket_Type;
1461 Level : Level_Type := Socket_Level;
1462 Option : Option_Type)
1463 is
1464 V8 : aliased Two_Int;
1465 V4 : aliased C.int;
1466 V1 : aliased C.unsigned_char;
1467 Len : aliased C.int;
1468 Add : System.Address := Null_Address;
1469 Res : C.int;
1470
1471 begin
1472 case Option.Name is
1473 when Keep_Alive |
1474 Reuse_Address |
1475 Broadcast |
1476 No_Delay =>
1477 V4 := C.int (Boolean'Pos (Option.Enabled));
1478 Len := V4'Size / 8;
1479 Add := V4'Address;
1480
1481 when Linger =>
1482 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1483 V8 (V8'Last) := C.int (Option.Seconds);
1484 Len := V8'Size / 8;
1485 Add := V8'Address;
1486
1487 when Send_Buffer |
1488 Receive_Buffer =>
1489 V4 := C.int (Option.Size);
1490 Len := V4'Size / 8;
1491 Add := V4'Address;
1492
1493 when Error =>
1494 V4 := C.int (Boolean'Pos (True));
1495 Len := V4'Size / 8;
1496 Add := V4'Address;
1497
1498 when Add_Membership |
1499 Drop_Membership =>
1500 V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr));
1501 V8 (V8'Last) := To_Int (To_In_Addr (Option.Interface));
1502 Len := V8'Size / 8;
1503 Add := V8'Address;
1504
1505 when Multicast_TTL =>
1506 V1 := C.unsigned_char (Option.Time_To_Live);
1507 Len := V1'Size / 8;
1508 Add := V1'Address;
1509
1510 when Multicast_Loop =>
1511 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
1512 Len := V1'Size / 8;
1513 Add := V1'Address;
1514
1515 end case;
1516
1517 Res := C_Setsockopt
1518 (C.int (Socket),
1519 Levels (Level),
1520 Options (Option.Name),
1521 Add, Len);
1522
1523 if Res = Failure then
1524 Raise_Socket_Error (Socket_Errno);
1525 end if;
1526 end Set_Socket_Option;
1527
1528 ---------------------
1529 -- Shutdown_Socket --
1530 ---------------------
1531
1532 procedure Shutdown_Socket
1533 (Socket : Socket_Type;
1534 How : Shutmode_Type := Shut_Read_Write)
1535 is
1536 Res : C.int;
1537
1538 begin
1539 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1540 if Res = Failure then
1541 Raise_Socket_Error (Socket_Errno);
1542 end if;
1543 end Shutdown_Socket;
1544
1545 ------------
1546 -- Stream --
1547 ------------
1548
1549 function Stream
1550 (Socket : Socket_Type;
1551 Send_To : Sock_Addr_Type)
1552 return Stream_Access
1553 is
1554 S : Datagram_Socket_Stream_Access;
1555
1556 begin
1557 S := new Datagram_Socket_Stream_Type;
1558 S.Socket := Socket;
1559 S.To := Send_To;
1560 S.From := Get_Socket_Name (Socket);
1561 return Stream_Access (S);
1562 end Stream;
1563
1564 ------------
1565 -- Stream --
1566 ------------
1567
1568 function Stream
1569 (Socket : Socket_Type)
1570 return Stream_Access
1571 is
1572 S : Stream_Socket_Stream_Access;
1573
1574 begin
1575 S := new Stream_Socket_Stream_Type;
1576 S.Socket := Socket;
1577 return Stream_Access (S);
1578 end Stream;
1579
1580 ----------
1581 -- To_C --
1582 ----------
1583
1584 function To_C (Socket : Socket_Type) return Integer is
1585 begin
1586 return Integer (Socket);
1587 end To_C;
1588
1589 -------------------
1590 -- To_Host_Entry --
1591 -------------------
1592
1593 function To_Host_Entry
1594 (Host : Hostent)
1595 return Host_Entry_Type
1596 is
1597 use type C.size_t;
1598
1599 Official : constant String :=
1600 C.Strings.Value (Host.H_Name);
1601
1602 Aliases : constant Chars_Ptr_Array :=
1603 Chars_Ptr_Pointers.Value (Host.H_Aliases);
1604 -- H_Aliases points to a list of name aliases. The list is
1605 -- terminated by a NULL pointer.
1606
1607 Addresses : constant In_Addr_Access_Array :=
1608 In_Addr_Access_Pointers.Value (Host.H_Addr_List);
1609 -- H_Addr_List points to a list of binary addresses (in network
1610 -- byte order). The list is terminated by a NULL pointer.
1611
1612 -- H_Length is not used because it is currently only set to 4.
1613 -- H_Addrtype is always AF_INET
1614
1615 Result : Host_Entry_Type
1616 (Aliases_Length => Aliases'Length - 1,
1617 Addresses_Length => Addresses'Length - 1);
1618 -- The last element is a null pointer.
1619
1620 Source : C.size_t;
1621 Target : Natural;
1622
1623 begin
1624 Result.Official := To_Host_Name (Official);
1625
1626 Source := Aliases'First;
1627 Target := Result.Aliases'First;
1628 while Target <= Result.Aliases_Length loop
1629 Result.Aliases (Target) :=
1630 To_Host_Name (C.Strings.Value (Aliases (Source)));
1631 Source := Source + 1;
1632 Target := Target + 1;
1633 end loop;
1634
1635 Source := Addresses'First;
1636 Target := Result.Addresses'First;
1637 while Target <= Result.Addresses_Length loop
1638 Result.Addresses (Target) :=
1639 To_Inet_Addr (Addresses (Source).all);
1640 Source := Source + 1;
1641 Target := Target + 1;
1642 end loop;
1643
1644 return Result;
1645 end To_Host_Entry;
1646
1647 ------------------
1648 -- To_Host_Name --
1649 ------------------
1650
1651 function To_Host_Name (N : String) return Host_Name_Type is
1652 begin
1653 return (N'Length, N);
1654 end To_Host_Name;
1655
1656 ----------------
1657 -- To_In_Addr --
1658 ----------------
1659
1660 function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1661 begin
1662 if Addr.Family = Family_Inet then
1663 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1664 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1665 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1666 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1667 end if;
1668
1669 raise Socket_Error;
1670 end To_In_Addr;
1671
1672 ------------------
1673 -- To_Inet_Addr --
1674 ------------------
1675
1676 function To_Inet_Addr
1677 (Addr : In_Addr)
1678 return Inet_Addr_Type
1679 is
1680 Result : Inet_Addr_Type;
1681
1682 begin
1683 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1684 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1685 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
1686 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
1687
1688 return Result;
1689 end To_Inet_Addr;
1690
1691 ---------------
1692 -- To_String --
1693 ---------------
1694
1695 function To_String (HN : Host_Name_Type) return String is
1696 begin
1697 return HN.Name (1 .. HN.Length);
1698 end To_String;
1699
1700 ----------------
1701 -- To_Timeval --
1702 ----------------
1703
1704 function To_Timeval (Val : Duration) return Timeval is
1705 S : Timeval_Unit := Timeval_Unit (Val);
1706 MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S)));
1707
1708 begin
1709 return (S, MS);
1710 end To_Timeval;
1711
1712 -----------
1713 -- Write --
1714 -----------
1715
1716 procedure Write
1717 (Stream : in out Datagram_Socket_Stream_Type;
1718 Item : Ada.Streams.Stream_Element_Array)
1719 is
1720 First : Ada.Streams.Stream_Element_Offset := Item'First;
1721 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1722 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1723
1724 begin
1725 loop
1726 Send_Socket
1727 (Stream.Socket,
1728 Item (First .. Max),
1729 Index,
1730 Stream.To);
1731
1732 -- Exit when all or zero data sent. Zero means that the
1733 -- socket has been closed by peer.
1734
1735 exit when Index < First or else Index = Max;
1736
1737 First := Index + 1;
1738 end loop;
1739
1740 if Index /= Max then
1741 raise Socket_Error;
1742 end if;
1743 end Write;
1744
1745 -----------
1746 -- Write --
1747 -----------
1748
1749 procedure Write
1750 (Stream : in out Stream_Socket_Stream_Type;
1751 Item : Ada.Streams.Stream_Element_Array)
1752 is
1753 First : Ada.Streams.Stream_Element_Offset := Item'First;
1754 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1755 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1756
1757 begin
1758 loop
1759 Send_Socket (Stream.Socket, Item (First .. Max), Index);
1760
1761 -- Exit when all or zero data sent. Zero means that the
1762 -- socket has been closed by peer.
1763
1764 exit when Index < First or else Index = Max;
1765
1766 First := Index + 1;
1767 end loop;
1768
1769 if Index /= Max then
1770 raise Socket_Error;
1771 end if;
1772 end Write;
1773
1774 end GNAT.Sockets;
Mirror of the offical gcc git repository hosted at gcc.gnu.org