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