1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2005 Ada Core Technologies, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Streams
; use Ada
.Streams
;
35 with Ada
.Exceptions
; use Ada
.Exceptions
;
36 with Ada
.Unchecked_Conversion
;
38 with Interfaces
.C
.Strings
;
40 with GNAT
.Sockets
.Constants
;
41 with GNAT
.Sockets
.Thin
; use GNAT
.Sockets
.Thin
;
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
48 with System
; use System
;
50 package body GNAT
.Sockets
is
52 use type C
.int
, System
.Address
;
54 Finalized
: Boolean := False;
55 Initialized
: Boolean := False;
57 ENOERROR
: constant := 0;
59 -- Correspondance tables
61 Families
: constant array (Family_Type
) of C
.int
:=
62 (Family_Inet
=> Constants
.AF_INET
,
63 Family_Inet6
=> Constants
.AF_INET6
);
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
);
71 Modes
: constant array (Mode_Type
) of C
.int
:=
72 (Socket_Stream
=> Constants
.SOCK_STREAM
,
73 Socket_Datagram
=> Constants
.SOCK_DGRAM
);
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
);
80 Requests
: constant array (Request_Name
) of C
.int
:=
81 (Non_Blocking_IO
=> Constants
.FIONBIO
,
82 N_Bytes_To_Read
=> Constants
.FIONREAD
);
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
);
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
104 Socket_Error_Id
: constant Exception_Id
:= Socket_Error
'Identity;
105 Host_Error_Id
: constant Exception_Id
:= Host_Error
'Identity;
107 Hex_To_Char
: constant String (1 .. 16) := "0123456789ABCDEF";
108 -- Use to print in hexadecimal format
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
);
113 -----------------------
114 -- Local subprograms --
115 -----------------------
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 (errno).
121 -- From_Errno prevents from mixing h_errno with errno.
123 function To_Name
(N
: String) return Name_Type
;
124 function To_String
(HN
: Name_Type
) return String;
125 -- Conversion functions
127 function To_Int
(F
: Request_Flag_Type
) return C
.int
;
128 -- Return the int value corresponding to the specified flags combination
130 function Set_Forced_Flags
(F
: C
.int
) return C
.int
;
131 -- Return F with the bits from Constants.MSG_Forced_Flags forced set
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
138 function Network_To_Short
139 (S
: C
.unsigned_short
) return C
.unsigned_short
140 renames Short_To_Network
;
141 -- Symetric operation
144 (Val
: Inet_Addr_VN_Type
;
145 Hex
: Boolean := False) return String;
146 -- Output an array of inet address components in hex or decimal mode
148 function Is_IP_Address
(Name
: String) return Boolean;
149 -- Return true when Name is an IP address in standard dot notation
151 function To_In_Addr
(Addr
: Inet_Addr_Type
) return Thin
.In_Addr
;
152 procedure To_Inet_Addr
154 Result
: out Inet_Addr_Type
);
155 -- Conversion functions
157 function To_Host_Entry
(E
: Hostent
) return Host_Entry_Type
;
158 -- Conversion function
160 function To_Service_Entry
(E
: Servent
) return Service_Entry_Type
;
161 -- Conversion function
163 function To_Timeval
(Val
: Selector_Duration
) return Timeval
;
164 -- Separate Val in seconds and microseconds
166 procedure Raise_Socket_Error
(Error
: Integer);
167 -- Raise Socket_Error with an exception message describing the error code
169 procedure Raise_Host_Error
(Error
: Integer);
170 -- Raise Host_Error exception with message describing error code (note
171 -- hstrerror seems to be obsolete).
173 procedure Narrow
(Item
: in out Socket_Set_Type
);
174 -- Update Last as it may be greater than the real last socket
176 -- Types needed for Datagram_Socket_Stream_Type
178 type Datagram_Socket_Stream_Type
is new Root_Stream_Type
with record
179 Socket
: Socket_Type
;
181 From
: Sock_Addr_Type
;
184 type Datagram_Socket_Stream_Access
is
185 access all Datagram_Socket_Stream_Type
;
188 (Stream
: in out Datagram_Socket_Stream_Type
;
189 Item
: out Ada
.Streams
.Stream_Element_Array
;
190 Last
: out Ada
.Streams
.Stream_Element_Offset
);
193 (Stream
: in out Datagram_Socket_Stream_Type
;
194 Item
: Ada
.Streams
.Stream_Element_Array
);
196 -- Types needed for Stream_Socket_Stream_Type
198 type Stream_Socket_Stream_Type
is new Root_Stream_Type
with record
199 Socket
: Socket_Type
;
202 type Stream_Socket_Stream_Access
is
203 access all Stream_Socket_Stream_Type
;
206 (Stream
: in out Stream_Socket_Stream_Type
;
207 Item
: out Ada
.Streams
.Stream_Element_Array
;
208 Last
: out Ada
.Streams
.Stream_Element_Offset
);
211 (Stream
: in out Stream_Socket_Stream_Type
;
212 Item
: Ada
.Streams
.Stream_Element_Array
);
218 function "+" (L
, R
: Request_Flag_Type
) return Request_Flag_Type
is
227 procedure Abort_Selector
(Selector
: Selector_Type
) is
228 Buf
: aliased Character := ASCII
.NUL
;
232 -- Send an empty array to unblock C select system call
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
);
245 procedure Accept_Socket
246 (Server
: Socket_Type
;
247 Socket
: out Socket_Type
;
248 Address
: out Sock_Addr_Type
)
251 Sin
: aliased Sockaddr_In
;
252 Len
: aliased C
.int
:= Sin
'Size / 8;
255 Res
:= C_Accept
(C
.int
(Server
), Sin
'Address, Len
'Access);
257 if Res
= Failure
then
258 Raise_Socket_Error
(Socket_Errno
);
261 Socket
:= Socket_Type
(Res
);
263 To_Inet_Addr
(Sin
.Sin_Addr
, Address
.Addr
);
264 Address
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
272 (E
: Host_Entry_Type
;
273 N
: Positive := 1) return Inet_Addr_Type
276 return E
.Addresses
(N
);
279 ----------------------
280 -- Addresses_Length --
281 ----------------------
283 function Addresses_Length
(E
: Host_Entry_Type
) return Natural is
285 return E
.Addresses_Length
;
286 end Addresses_Length
;
293 (E
: Host_Entry_Type
;
294 N
: Positive := 1) return String
297 return To_String
(E
.Aliases
(N
));
305 (S
: Service_Entry_Type
;
306 N
: Positive := 1) return String
309 return To_String
(S
.Aliases
(N
));
316 function Aliases_Length
(E
: Host_Entry_Type
) return Natural is
318 return E
.Aliases_Length
;
325 function Aliases_Length
(S
: Service_Entry_Type
) return Natural is
327 return S
.Aliases_Length
;
334 procedure Bind_Socket
335 (Socket
: Socket_Type
;
336 Address
: Sock_Addr_Type
)
339 Sin
: aliased Sockaddr_In
;
340 Len
: constant C
.int
:= Sin
'Size / 8;
343 if Address
.Family
= Family_Inet6
then
347 Set_Length
(Sin
'Unchecked_Access, Len
);
348 Set_Family
(Sin
'Unchecked_Access, Families
(Address
.Family
));
350 (Sin
'Unchecked_Access,
351 Short_To_Network
(C
.unsigned_short
(Address
.Port
)));
353 Res
:= C_Bind
(C
.int
(Socket
), Sin
'Address, Len
);
355 if Res
= Failure
then
356 Raise_Socket_Error
(Socket_Errno
);
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
)
371 E_Socket_Set
: Socket_Set_Type
; -- (No_Socket, No_Socket_Set)
374 (Selector
, R_Socket_Set
, W_Socket_Set
, E_Socket_Set
, Status
, Timeout
);
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
)
387 RSet
: Socket_Set_Type
;
388 WSet
: Socket_Set_Type
;
389 ESet
: Socket_Set_Type
;
390 TVal
: aliased Timeval
;
391 TPtr
: Timeval_Access
;
396 -- No timeout or Forever is indicated by a null timeval pointer
398 if Timeout
= Forever
then
401 TVal
:= To_Timeval
(Timeout
);
402 TPtr
:= TVal
'Unchecked_Access;
405 -- Copy R_Socket_Set in RSet and add read signalling socket
407 RSet
:= (Set
=> New_Socket_Set
(R_Socket_Set
.Set
),
408 Last
=> R_Socket_Set
.Last
);
409 Set
(RSet
, Selector
.R_Sig_Socket
);
411 -- Copy W_Socket_Set in WSet
413 WSet
:= (Set
=> New_Socket_Set
(W_Socket_Set
.Set
),
414 Last
=> W_Socket_Set
.Last
);
416 -- Copy E_Socket_Set in ESet
418 ESet
:= (Set
=> New_Socket_Set
(E_Socket_Set
.Set
),
419 Last
=> E_Socket_Set
.Last
);
421 Last
:= C
.int
'Max (C
.int
'Max (C
.int
(RSet
.Last
),
433 if Res
= Failure
then
434 Raise_Socket_Error
(Socket_Errno
);
437 -- If Select was resumed because of read signalling socket, read this
438 -- data and remove socket from set.
440 if Is_Set
(RSet
, Selector
.R_Sig_Socket
) then
441 Clear
(RSet
, Selector
.R_Sig_Socket
);
447 Res
:= C_Recv
(C
.int
(Selector
.R_Sig_Socket
), Buf
'Address, 1, 0);
449 if Res
= Failure
then
450 Raise_Socket_Error
(Socket_Errno
);
460 -- Update RSet, WSet and ESet in regard to their new socket sets
466 -- Reset RSet as it should be if R_Sig_Socket was not added
468 if Is_Empty
(RSet
) then
472 if Is_Empty
(WSet
) then
476 if Is_Empty
(ESet
) then
480 -- Deliver RSet, WSet and ESet
482 Empty
(R_Socket_Set
);
483 R_Socket_Set
:= RSet
;
485 Empty
(W_Socket_Set
);
486 W_Socket_Set
:= WSet
;
488 Empty
(E_Socket_Set
);
489 E_Socket_Set
:= ESet
;
497 (Item
: in out Socket_Set_Type
;
498 Socket
: Socket_Type
)
500 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
502 if Item
.Last
/= No_Socket
then
503 Remove_Socket_From_Set
(Item
.Set
, C
.int
(Socket
));
504 Last_Socket_In_Set
(Item
.Set
, Last
'Unchecked_Access);
505 Item
.Last
:= Socket_Type
(Last
);
513 -- Comments needed below ???
514 -- Why are exceptions ignored ???
516 procedure Close_Selector
(Selector
: in out Selector_Type
) is
519 Close_Socket
(Selector
.R_Sig_Socket
);
526 Close_Socket
(Selector
.W_Sig_Socket
);
537 procedure Close_Socket
(Socket
: Socket_Type
) is
541 Res
:= C_Close
(C
.int
(Socket
));
543 if Res
= Failure
then
544 Raise_Socket_Error
(Socket_Errno
);
552 procedure Connect_Socket
553 (Socket
: Socket_Type
;
554 Server
: in out Sock_Addr_Type
)
557 Sin
: aliased Sockaddr_In
;
558 Len
: constant C
.int
:= Sin
'Size / 8;
561 if Server
.Family
= Family_Inet6
then
565 Set_Length
(Sin
'Unchecked_Access, Len
);
566 Set_Family
(Sin
'Unchecked_Access, Families
(Server
.Family
));
567 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(Server
.Addr
));
569 (Sin
'Unchecked_Access,
570 Short_To_Network
(C
.unsigned_short
(Server
.Port
)));
572 Res
:= C_Connect
(C
.int
(Socket
), Sin
'Address, Len
);
574 if Res
= Failure
then
575 Raise_Socket_Error
(Socket_Errno
);
583 procedure Control_Socket
584 (Socket
: Socket_Type
;
585 Request
: in out Request_Type
)
592 when Non_Blocking_IO
=>
593 Arg
:= C
.int
(Boolean'Pos (Request
.Enabled
));
595 when N_Bytes_To_Read
=>
602 Requests
(Request
.Name
),
603 Arg
'Unchecked_Access);
605 if Res
= Failure
then
606 Raise_Socket_Error
(Socket_Errno
);
610 when Non_Blocking_IO
=>
613 when N_Bytes_To_Read
=>
614 Request
.Size
:= Natural (Arg
);
623 (Source
: Socket_Set_Type
;
624 Target
: in out Socket_Set_Type
)
628 if Source
.Last
/= No_Socket
then
629 Target
.Set
:= New_Socket_Set
(Source
.Set
);
630 Target
.Last
:= Source
.Last
;
634 ---------------------
635 -- Create_Selector --
636 ---------------------
638 procedure Create_Selector
(Selector
: out Selector_Type
) is
643 Sin
: aliased Sockaddr_In
;
644 Len
: aliased C
.int
:= Sin
'Size / 8;
648 -- We open two signalling sockets. One of them is used to send data to
649 -- the other, which is included in a C_Select socket set. The
650 -- communication is used to force the call to C_Select to complete, and
651 -- the waiting task to resume its execution.
653 -- Create a listening socket
655 S0
:= C_Socket
(Constants
.AF_INET
, Constants
.SOCK_STREAM
, 0);
658 Raise_Socket_Error
(Socket_Errno
);
661 -- Bind the socket to any unused port on localhost
663 Sin
.Sin_Addr
.S_B1
:= 127;
664 Sin
.Sin_Addr
.S_B2
:= 0;
665 Sin
.Sin_Addr
.S_B3
:= 0;
666 Sin
.Sin_Addr
.S_B4
:= 1;
669 Res
:= C_Bind
(S0
, Sin
'Address, Len
);
671 if Res
= Failure
then
674 Raise_Socket_Error
(Err
);
677 -- Get the port used by the socket
679 Res
:= C_Getsockname
(S0
, Sin
'Address, Len
'Access);
681 if Res
= Failure
then
684 Raise_Socket_Error
(Err
);
687 -- Set backlog to 1 to guarantee that exactly one call to connect(2)
690 Res
:= C_Listen
(S0
, 1);
692 if Res
= Failure
then
695 Raise_Socket_Error
(Err
);
698 S1
:= C_Socket
(Constants
.AF_INET
, Constants
.SOCK_STREAM
, 0);
703 Raise_Socket_Error
(Err
);
706 -- Do a connect and accept the connection
708 Res
:= C_Connect
(S1
, Sin
'Address, Len
);
710 if Res
= Failure
then
714 Raise_Socket_Error
(Err
);
717 -- Since the call to connect(2) has suceeded and the backlog limit on
718 -- the listening socket is 1, we know that there is now exactly one
719 -- pending connection on S0, which is the one from S1.
721 S2
:= C_Accept
(S0
, Sin
'Address, Len
'Access);
727 Raise_Socket_Error
(Err
);
732 if Res
= Failure
then
733 Raise_Socket_Error
(Socket_Errno
);
736 Selector
.R_Sig_Socket
:= Socket_Type
(S1
);
737 Selector
.W_Sig_Socket
:= Socket_Type
(S2
);
744 procedure Create_Socket
745 (Socket
: out Socket_Type
;
746 Family
: Family_Type
:= Family_Inet
;
747 Mode
: Mode_Type
:= Socket_Stream
)
752 Res
:= C_Socket
(Families
(Family
), Modes
(Mode
), 0);
754 if Res
= Failure
then
755 Raise_Socket_Error
(Socket_Errno
);
758 Socket
:= Socket_Type
(Res
);
765 procedure Empty
(Item
: in out Socket_Set_Type
) is
767 if Item
.Set
/= No_Socket_Set
then
768 Free_Socket_Set
(Item
.Set
);
769 Item
.Set
:= No_Socket_Set
;
772 Item
.Last
:= No_Socket
;
779 procedure Finalize
is
794 (Item
: in out Socket_Set_Type
;
795 Socket
: out Socket_Type
)
798 L
: aliased C
.int
:= C
.int
(Item
.Last
);
801 if Item
.Last
/= No_Socket
then
803 (Item
.Set
, L
'Unchecked_Access, S
'Unchecked_Access);
804 Item
.Last
:= Socket_Type
(L
);
805 Socket
:= Socket_Type
(S
);
815 function Get_Address
(Stream
: Stream_Access
) return Sock_Addr_Type
is
817 if Stream
= null then
819 elsif Stream
.all in Datagram_Socket_Stream_Type
then
820 return Datagram_Socket_Stream_Type
(Stream
.all).From
;
822 return Get_Peer_Name
(Stream_Socket_Stream_Type
(Stream
.all).Socket
);
826 -------------------------
827 -- Get_Host_By_Address --
828 -------------------------
830 function Get_Host_By_Address
831 (Address
: Inet_Addr_Type
;
832 Family
: Family_Type
:= Family_Inet
) return Host_Entry_Type
834 pragma Unreferenced
(Family
);
836 HA
: aliased In_Addr
:= To_In_Addr
(Address
);
837 Res
: Hostent_Access
;
841 -- This C function is not always thread-safe. Protect against
842 -- concurrent access.
845 Res
:= C_Gethostbyaddr
(HA
'Address, HA
'Size / 8, Constants
.AF_INET
);
850 Raise_Host_Error
(Err
);
853 -- Translate from the C format to the API format
856 HE
: constant Host_Entry_Type
:= To_Host_Entry
(Res
.all);
862 end Get_Host_By_Address
;
864 ----------------------
865 -- Get_Host_By_Name --
866 ----------------------
868 function Get_Host_By_Name
(Name
: String) return Host_Entry_Type
is
869 HN
: constant C
.char_array
:= C
.To_C
(Name
);
870 Res
: Hostent_Access
;
874 -- Detect IP address name and redirect to Inet_Addr
876 if Is_IP_Address
(Name
) then
877 return Get_Host_By_Address
(Inet_Addr
(Name
));
880 -- This C function is not always thread-safe. Protect against
881 -- concurrent access.
884 Res
:= C_Gethostbyname
(HN
);
889 Raise_Host_Error
(Err
);
892 -- Translate from the C format to the API format
895 HE
: constant Host_Entry_Type
:= To_Host_Entry
(Res
.all);
900 end Get_Host_By_Name
;
906 function Get_Peer_Name
(Socket
: Socket_Type
) return Sock_Addr_Type
is
907 Sin
: aliased Sockaddr_In
;
908 Len
: aliased C
.int
:= Sin
'Size / 8;
909 Res
: Sock_Addr_Type
(Family_Inet
);
912 if C_Getpeername
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
913 Raise_Socket_Error
(Socket_Errno
);
916 To_Inet_Addr
(Sin
.Sin_Addr
, Res
.Addr
);
917 Res
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
922 -------------------------
923 -- Get_Service_By_Name --
924 -------------------------
926 function Get_Service_By_Name
928 Protocol
: String) return Service_Entry_Type
930 SN
: constant C
.char_array
:= C
.To_C
(Name
);
931 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
932 Res
: Servent_Access
;
935 -- This C function is not always thread-safe. Protect against
936 -- concurrent access.
939 Res
:= C_Getservbyname
(SN
, SP
);
943 Ada
.Exceptions
.Raise_Exception
944 (Service_Error
'Identity, "Service not found");
947 -- Translate from the C format to the API format
950 SE
: constant Service_Entry_Type
:= To_Service_Entry
(Res
.all);
956 end Get_Service_By_Name
;
958 -------------------------
959 -- Get_Service_By_Port --
960 -------------------------
962 function Get_Service_By_Port
964 Protocol
: String) return Service_Entry_Type
966 SP
: constant C
.char_array
:= C
.To_C
(Protocol
);
967 Res
: Servent_Access
;
970 -- This C function is not always thread-safe. Protect against
971 -- concurrent access.
974 Res
:= C_Getservbyport
975 (C
.int
(Short_To_Network
(C
.unsigned_short
(Port
))), SP
);
979 Ada
.Exceptions
.Raise_Exception
980 (Service_Error
'Identity, "Service not found");
983 -- Translate from the C format to the API format
986 SE
: constant Service_Entry_Type
:= To_Service_Entry
(Res
.all);
992 end Get_Service_By_Port
;
994 ---------------------
995 -- Get_Socket_Name --
996 ---------------------
998 function Get_Socket_Name
999 (Socket
: Socket_Type
) return Sock_Addr_Type
1001 Sin
: aliased Sockaddr_In
;
1002 Len
: aliased C
.int
:= Sin
'Size / 8;
1004 Addr
: Sock_Addr_Type
:= No_Sock_Addr
;
1007 Res
:= C_Getsockname
(C
.int
(Socket
), Sin
'Address, Len
'Access);
1008 if Res
/= Failure
then
1009 To_Inet_Addr
(Sin
.Sin_Addr
, Addr
.Addr
);
1010 Addr
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1014 end Get_Socket_Name
;
1016 -----------------------
1017 -- Get_Socket_Option --
1018 -----------------------
1020 function Get_Socket_Option
1021 (Socket
: Socket_Type
;
1022 Level
: Level_Type
:= Socket_Level
;
1023 Name
: Option_Name
) return Option_Type
1025 use type C
.unsigned_char
;
1027 V8
: aliased Two_Int
;
1029 V1
: aliased C
.unsigned_char
;
1030 Len
: aliased C
.int
;
1031 Add
: System
.Address
;
1033 Opt
: Option_Type
(Name
);
1037 when Multicast_Loop |
1065 Add
, Len
'Unchecked_Access);
1067 if Res
= Failure
then
1068 Raise_Socket_Error
(Socket_Errno
);
1076 Opt
.Enabled
:= (V4
/= 0);
1079 Opt
.Enabled
:= (V8
(V8
'First) /= 0);
1080 Opt
.Seconds
:= Natural (V8
(V8
'Last));
1084 Opt
.Size
:= Natural (V4
);
1087 Opt
.Error
:= Resolve_Error
(Integer (V4
));
1089 when Add_Membership |
1091 To_Inet_Addr
(To_In_Addr
(V8
(V8
'First)), Opt
.Multicast_Address
);
1092 To_Inet_Addr
(To_In_Addr
(V8
(V8
'Last)), Opt
.Local_Interface
);
1094 when Multicast_TTL
=>
1095 Opt
.Time_To_Live
:= Integer (V1
);
1097 when Multicast_Loop
=>
1098 Opt
.Enabled
:= (V1
/= 0);
1103 end Get_Socket_Option
;
1109 function Host_Name
return String is
1110 Name
: aliased C
.char_array
(1 .. 64);
1114 Res
:= C_Gethostname
(Name
'Address, Name
'Length);
1116 if Res
= Failure
then
1117 Raise_Socket_Error
(Socket_Errno
);
1120 return C
.To_Ada
(Name
);
1128 (Val
: Inet_Addr_VN_Type
;
1129 Hex
: Boolean := False) return String
1131 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1132 -- has at most a length of 3 plus one '.' character.
1134 Buffer
: String (1 .. 4 * Val
'Length);
1135 Length
: Natural := 1;
1136 Separator
: Character;
1138 procedure Img10
(V
: Inet_Addr_Comp_Type
);
1139 -- Append to Buffer image of V in decimal format
1141 procedure Img16
(V
: Inet_Addr_Comp_Type
);
1142 -- Append to Buffer image of V in hexadecimal format
1148 procedure Img10
(V
: Inet_Addr_Comp_Type
) is
1149 Img
: constant String := V
'Img;
1150 Len
: constant Natural := Img
'Length - 1;
1152 Buffer
(Length
.. Length
+ Len
- 1) := Img
(2 .. Img
'Last);
1153 Length
:= Length
+ Len
;
1160 procedure Img16
(V
: Inet_Addr_Comp_Type
) is
1162 Buffer
(Length
) := Hex_To_Char
(Natural (V
/ 16) + 1);
1163 Buffer
(Length
+ 1) := Hex_To_Char
(Natural (V
mod 16) + 1);
1164 Length
:= Length
+ 2;
1167 -- Start of processing for Image
1176 for J
in Val
'Range loop
1183 if J
/= Val
'Last then
1184 Buffer
(Length
) := Separator
;
1185 Length
:= Length
+ 1;
1189 return Buffer
(1 .. Length
- 1);
1196 function Image
(Value
: Inet_Addr_Type
) return String is
1198 if Value
.Family
= Family_Inet
then
1199 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V4
), Hex
=> False);
1201 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V6
), Hex
=> True);
1209 function Image
(Value
: Sock_Addr_Type
) return String is
1210 Port
: constant String := Value
.Port
'Img;
1212 return Image
(Value
.Addr
) & ':' & Port
(2 .. Port
'Last);
1219 function Image
(Socket
: Socket_Type
) return String is
1228 function Inet_Addr
(Image
: String) return Inet_Addr_Type
is
1229 use Interfaces
.C
.Strings
;
1233 Result
: Inet_Addr_Type
;
1236 -- Special case for the all-ones broadcast address: this address
1237 -- has the same in_addr_t value as Failure, and thus cannot be
1238 -- properly returned by inet_addr(3).
1240 if Image
= "255.255.255.255" then
1241 return Broadcast_Inet_Addr
;
1243 -- Special case for an empty Image as on some platforms (e.g. Windows)
1244 -- calling Inet_Addr("") will not return an error.
1246 elsif Image
= "" then
1247 Raise_Socket_Error
(Constants
.EINVAL
);
1250 Img
:= New_String
(Image
);
1251 Res
:= C_Inet_Addr
(Img
);
1254 if Res
= Failure
then
1255 Raise_Socket_Error
(Constants
.EINVAL
);
1258 To_Inet_Addr
(To_In_Addr
(Res
), Result
);
1266 procedure Initialize
(Process_Blocking_IO
: Boolean := False) is
1268 if not Initialized
then
1269 Initialized
:= True;
1270 Thin
.Initialize
(Process_Blocking_IO
);
1278 function Is_Empty
(Item
: Socket_Set_Type
) return Boolean is
1280 return Item
.Last
= No_Socket
;
1287 function Is_IP_Address
(Name
: String) return Boolean is
1289 for J
in Name
'Range loop
1291 and then Name
(J
) not in '0' .. '9'
1305 (Item
: Socket_Set_Type
;
1306 Socket
: Socket_Type
) return Boolean
1309 return Item
.Last
/= No_Socket
1310 and then Socket
<= Item
.Last
1311 and then Is_Socket_In_Set
(Item
.Set
, C
.int
(Socket
)) /= 0;
1318 procedure Listen_Socket
1319 (Socket
: Socket_Type
;
1320 Length
: Positive := 15)
1322 Res
: constant C
.int
:= C_Listen
(C
.int
(Socket
), C
.int
(Length
));
1324 if Res
= Failure
then
1325 Raise_Socket_Error
(Socket_Errno
);
1333 procedure Narrow
(Item
: in out Socket_Set_Type
) is
1334 Last
: aliased C
.int
:= C
.int
(Item
.Last
);
1336 if Item
.Set
/= No_Socket_Set
then
1337 Last_Socket_In_Set
(Item
.Set
, Last
'Unchecked_Access);
1338 Item
.Last
:= Socket_Type
(Last
);
1346 function Official_Name
(E
: Host_Entry_Type
) return String is
1348 return To_String
(E
.Official
);
1355 function Official_Name
(S
: Service_Entry_Type
) return String is
1357 return To_String
(S
.Official
);
1364 function Port_Number
(S
: Service_Entry_Type
) return Port_Type
is
1373 function Protocol_Name
(S
: Service_Entry_Type
) return String is
1375 return To_String
(S
.Protocol
);
1378 ----------------------
1379 -- Raise_Host_Error --
1380 ----------------------
1382 procedure Raise_Host_Error
(Error
: Integer) is
1384 function Host_Error_Message
return String;
1385 -- We do not use a C function like strerror because hstrerror
1386 -- that would correspond seems to be obsolete. Return
1387 -- appropriate string for error value.
1389 ------------------------
1390 -- Host_Error_Message --
1391 ------------------------
1393 function Host_Error_Message
return String is
1396 when Constants
.HOST_NOT_FOUND
=> return "Host not found";
1397 when Constants
.TRY_AGAIN
=> return "Try again";
1398 when Constants
.NO_RECOVERY
=> return "No recovery";
1399 when Constants
.NO_DATA
=> return "No address";
1400 when others => return "Unknown error";
1402 end Host_Error_Message
;
1404 -- Start of processing for Raise_Host_Error
1407 Ada
.Exceptions
.Raise_Exception
(Host_Error
'Identity, Host_Error_Message
);
1408 end Raise_Host_Error
;
1410 ------------------------
1411 -- Raise_Socket_Error --
1412 ------------------------
1414 procedure Raise_Socket_Error
(Error
: Integer) is
1415 use type C
.Strings
.chars_ptr
;
1417 function Image
(E
: Integer) return String;
1423 function Image
(E
: Integer) return String is
1424 Msg
: String := E
'Img & "] ";
1426 Msg
(Msg
'First) := '[';
1430 -- Start of processing for Raise_Socket_Error
1433 Ada
.Exceptions
.Raise_Exception
1434 (Socket_Error
'Identity,
1435 Image
(Error
) & C
.Strings
.Value
(Socket_Error_Message
(Error
)));
1436 end Raise_Socket_Error
;
1443 (Stream
: in out Datagram_Socket_Stream_Type
;
1444 Item
: out Ada
.Streams
.Stream_Element_Array
;
1445 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1447 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1448 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1449 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1455 Item
(First
.. Max
),
1461 -- Exit when all or zero data received. Zero means that the socket
1464 exit when Index
< First
or else Index
= Max
;
1475 (Stream
: in out Stream_Socket_Stream_Type
;
1476 Item
: out Ada
.Streams
.Stream_Element_Array
;
1477 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1479 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1480 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1481 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1485 Receive_Socket
(Stream
.Socket
, Item
(First
.. Max
), Index
);
1488 -- Exit when all or zero data received. Zero means that the socket
1491 exit when Index
< First
or else Index
= Max
;
1497 --------------------
1498 -- Receive_Socket --
1499 --------------------
1501 procedure Receive_Socket
1502 (Socket
: Socket_Type
;
1503 Item
: out Ada
.Streams
.Stream_Element_Array
;
1504 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1505 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1507 use type Ada
.Streams
.Stream_Element_Offset
;
1514 Item
(Item
'First)'Address,
1518 if Res
= Failure
then
1519 Raise_Socket_Error
(Socket_Errno
);
1522 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1525 --------------------
1526 -- Receive_Socket --
1527 --------------------
1529 procedure Receive_Socket
1530 (Socket
: Socket_Type
;
1531 Item
: out Ada
.Streams
.Stream_Element_Array
;
1532 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1533 From
: out Sock_Addr_Type
;
1534 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1536 use type Ada
.Streams
.Stream_Element_Offset
;
1539 Sin
: aliased Sockaddr_In
;
1540 Len
: aliased C
.int
:= Sin
'Size / 8;
1546 Item
(Item
'First)'Address,
1549 Sin
'Unchecked_Access,
1550 Len
'Unchecked_Access);
1552 if Res
= Failure
then
1553 Raise_Socket_Error
(Socket_Errno
);
1556 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1558 To_Inet_Addr
(Sin
.Sin_Addr
, From
.Addr
);
1559 From
.Port
:= Port_Type
(Network_To_Short
(Sin
.Sin_Port
));
1566 function Resolve_Error
1567 (Error_Value
: Integer;
1568 From_Errno
: Boolean := True) return Error_Type
1570 use GNAT
.Sockets
.Constants
;
1573 if not From_Errno
then
1575 when Constants
.HOST_NOT_FOUND
=> return Unknown_Host
;
1576 when Constants
.TRY_AGAIN
=> return Host_Name_Lookup_Failure
;
1577 when Constants
.NO_RECOVERY
=>
1578 return Non_Recoverable_Error
;
1579 when Constants
.NO_DATA
=> return Unknown_Server_Error
;
1580 when others => return Cannot_Resolve_Error
;
1585 when ENOERROR
=> return Success
;
1586 when EACCES
=> return Permission_Denied
;
1587 when EADDRINUSE
=> return Address_Already_In_Use
;
1588 when EADDRNOTAVAIL
=> return Cannot_Assign_Requested_Address
;
1589 when EAFNOSUPPORT
=>
1590 return Address_Family_Not_Supported_By_Protocol
;
1591 when EALREADY
=> return Operation_Already_In_Progress
;
1592 when EBADF
=> return Bad_File_Descriptor
;
1593 when ECONNABORTED
=> return Software_Caused_Connection_Abort
;
1594 when ECONNREFUSED
=> return Connection_Refused
;
1595 when ECONNRESET
=> return Connection_Reset_By_Peer
;
1596 when EDESTADDRREQ
=> return Destination_Address_Required
;
1597 when EFAULT
=> return Bad_Address
;
1598 when EHOSTDOWN
=> return Host_Is_Down
;
1599 when EHOSTUNREACH
=> return No_Route_To_Host
;
1600 when EINPROGRESS
=> return Operation_Now_In_Progress
;
1601 when EINTR
=> return Interrupted_System_Call
;
1602 when EINVAL
=> return Invalid_Argument
;
1603 when EIO
=> return Input_Output_Error
;
1604 when EISCONN
=> return Transport_Endpoint_Already_Connected
;
1605 when ELOOP
=> return Too_Many_Symbolic_Links
;
1606 when EMFILE
=> return Too_Many_Open_Files
;
1607 when EMSGSIZE
=> return Message_Too_Long
;
1608 when ENAMETOOLONG
=> return File_Name_Too_Long
;
1609 when ENETDOWN
=> return Network_Is_Down
;
1611 return Network_Dropped_Connection_Because_Of_Reset
;
1612 when ENETUNREACH
=> return Network_Is_Unreachable
;
1613 when ENOBUFS
=> return No_Buffer_Space_Available
;
1614 when ENOPROTOOPT
=> return Protocol_Not_Available
;
1615 when ENOTCONN
=> return Transport_Endpoint_Not_Connected
;
1616 when ENOTSOCK
=> return Socket_Operation_On_Non_Socket
;
1617 when EOPNOTSUPP
=> return Operation_Not_Supported
;
1618 when EPFNOSUPPORT
=> return Protocol_Family_Not_Supported
;
1619 when EPROTONOSUPPORT
=> return Protocol_Not_Supported
;
1620 when EPROTOTYPE
=> return Protocol_Wrong_Type_For_Socket
;
1622 return Cannot_Send_After_Transport_Endpoint_Shutdown
;
1623 when ESOCKTNOSUPPORT
=> return Socket_Type_Not_Supported
;
1624 when ETIMEDOUT
=> return Connection_Timed_Out
;
1625 when ETOOMANYREFS
=> return Too_Many_References
;
1626 when EWOULDBLOCK
=> return Resource_Temporarily_Unavailable
;
1627 when others => null;
1630 return Cannot_Resolve_Error
;
1633 -----------------------
1634 -- Resolve_Exception --
1635 -----------------------
1637 function Resolve_Exception
1638 (Occurrence
: Exception_Occurrence
) return Error_Type
1640 Id
: constant Exception_Id
:= Exception_Identity
(Occurrence
);
1641 Msg
: constant String := Exception_Message
(Occurrence
);
1642 First
: Natural := Msg
'First;
1647 while First
<= Msg
'Last
1648 and then Msg
(First
) not in '0' .. '9'
1653 if First
> Msg
'Last then
1654 return Cannot_Resolve_Error
;
1659 while Last
< Msg
'Last
1660 and then Msg
(Last
+ 1) in '0' .. '9'
1665 Val
:= Integer'Value (Msg
(First
.. Last
));
1667 if Id
= Socket_Error_Id
then
1668 return Resolve_Error
(Val
);
1669 elsif Id
= Host_Error_Id
then
1670 return Resolve_Error
(Val
, False);
1672 return Cannot_Resolve_Error
;
1674 end Resolve_Exception
;
1676 --------------------
1677 -- Receive_Vector --
1678 --------------------
1680 procedure Receive_Vector
1681 (Socket
: Socket_Type
;
1682 Vector
: Vector_Type
;
1683 Count
: out Ada
.Streams
.Stream_Element_Count
)
1691 Vector
(Vector
'First)'Address,
1694 if Res
= Failure
then
1695 Raise_Socket_Error
(Socket_Errno
);
1698 Count
:= Ada
.Streams
.Stream_Element_Count
(Res
);
1705 procedure Send_Socket
1706 (Socket
: Socket_Type
;
1707 Item
: Ada
.Streams
.Stream_Element_Array
;
1708 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1709 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1711 use type Ada
.Streams
.Stream_Element_Offset
;
1719 Item
(Item
'First)'Address,
1721 Set_Forced_Flags
(To_Int
(Flags
)));
1723 if Res
= Failure
then
1724 Raise_Socket_Error
(Socket_Errno
);
1727 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1734 procedure Send_Socket
1735 (Socket
: Socket_Type
;
1736 Item
: Ada
.Streams
.Stream_Element_Array
;
1737 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1738 To
: Sock_Addr_Type
;
1739 Flags
: Request_Flag_Type
:= No_Request_Flag
)
1741 use type Ada
.Streams
.Stream_Element_Offset
;
1744 Sin
: aliased Sockaddr_In
;
1745 Len
: constant C
.int
:= Sin
'Size / 8;
1748 Set_Length
(Sin
'Unchecked_Access, Len
);
1749 Set_Family
(Sin
'Unchecked_Access, Families
(To
.Family
));
1750 Set_Address
(Sin
'Unchecked_Access, To_In_Addr
(To
.Addr
));
1752 (Sin
'Unchecked_Access,
1753 Short_To_Network
(C
.unsigned_short
(To
.Port
)));
1757 Item
(Item
'First)'Address,
1759 Set_Forced_Flags
(To_Int
(Flags
)),
1760 Sin
'Unchecked_Access,
1763 if Res
= Failure
then
1764 Raise_Socket_Error
(Socket_Errno
);
1767 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1774 procedure Send_Vector
1775 (Socket
: Socket_Type
;
1776 Vector
: Vector_Type
;
1777 Count
: out Ada
.Streams
.Stream_Element_Count
)
1781 This_Iov_Count
: C
.int
;
1786 while Iov_Count
< Vector
'Length loop
1788 pragma Warnings
(Off
);
1789 -- Following test may be compile time known on some targets
1791 if Vector
'Length - Iov_Count
> Constants
.IOV_MAX
then
1792 This_Iov_Count
:= Constants
.IOV_MAX
;
1794 This_Iov_Count
:= Vector
'Length - Iov_Count
;
1797 pragma Warnings
(On
);
1802 Vector
(Vector
'First + Integer (Iov_Count
))'Address,
1805 if Res
= Failure
then
1806 Raise_Socket_Error
(Socket_Errno
);
1809 Count
:= Count
+ Ada
.Streams
.Stream_Element_Count
(Res
);
1810 Iov_Count
:= Iov_Count
+ This_Iov_Count
;
1818 procedure Set
(Item
: in out Socket_Set_Type
; Socket
: Socket_Type
) is
1820 if Item
.Set
= No_Socket_Set
then
1821 Item
.Set
:= New_Socket_Set
(No_Socket_Set
);
1822 Item
.Last
:= Socket
;
1824 elsif Item
.Last
< Socket
then
1825 Item
.Last
:= Socket
;
1828 Insert_Socket_In_Set
(Item
.Set
, C
.int
(Socket
));
1831 ----------------------
1832 -- Set_Forced_Flags --
1833 ----------------------
1835 function Set_Forced_Flags
(F
: C
.int
) return C
.int
is
1836 use type C
.unsigned
;
1837 function To_unsigned
is
1838 new Ada
.Unchecked_Conversion
(C
.int
, C
.unsigned
);
1840 new Ada
.Unchecked_Conversion
(C
.unsigned
, C
.int
);
1842 return To_int
(To_unsigned
(F
) or Constants
.MSG_Forced_Flags
);
1843 end Set_Forced_Flags
;
1845 -----------------------
1846 -- Set_Socket_Option --
1847 -----------------------
1849 procedure Set_Socket_Option
1850 (Socket
: Socket_Type
;
1851 Level
: Level_Type
:= Socket_Level
;
1852 Option
: Option_Type
)
1854 V8
: aliased Two_Int
;
1856 V1
: aliased C
.unsigned_char
;
1857 Len
: aliased C
.int
;
1858 Add
: System
.Address
:= Null_Address
;
1867 V4
:= C
.int
(Boolean'Pos (Option
.Enabled
));
1872 V8
(V8
'First) := C
.int
(Boolean'Pos (Option
.Enabled
));
1873 V8
(V8
'Last) := C
.int
(Option
.Seconds
);
1879 V4
:= C
.int
(Option
.Size
);
1884 V4
:= C
.int
(Boolean'Pos (True));
1888 when Add_Membership |
1890 V8
(V8
'First) := To_Int
(To_In_Addr
(Option
.Multicast_Address
));
1891 V8
(V8
'Last) := To_Int
(To_In_Addr
(Option
.Local_Interface
));
1895 when Multicast_TTL
=>
1896 V1
:= C
.unsigned_char
(Option
.Time_To_Live
);
1900 when Multicast_Loop
=>
1901 V1
:= C
.unsigned_char
(Boolean'Pos (Option
.Enabled
));
1910 Options
(Option
.Name
),
1913 if Res
= Failure
then
1914 Raise_Socket_Error
(Socket_Errno
);
1916 end Set_Socket_Option
;
1918 ----------------------
1919 -- Short_To_Network --
1920 ----------------------
1922 function Short_To_Network
(S
: C
.unsigned_short
) return C
.unsigned_short
is
1923 use type C
.unsigned_short
;
1926 -- Big-endian case. No conversion needed. On these platforms,
1927 -- htons() defaults to a null procedure.
1929 pragma Warnings
(Off
);
1930 -- Since the test can generate "always True/False" warning
1932 if Default_Bit_Order
= High_Order_First
then
1935 pragma Warnings
(On
);
1937 -- Little-endian case. We must swap the high and low bytes of this
1938 -- short to make the port number network compliant.
1941 return (S
/ 256) + (S
mod 256) * 256;
1943 end Short_To_Network
;
1945 ---------------------
1946 -- Shutdown_Socket --
1947 ---------------------
1949 procedure Shutdown_Socket
1950 (Socket
: Socket_Type
;
1951 How
: Shutmode_Type
:= Shut_Read_Write
)
1956 Res
:= C_Shutdown
(C
.int
(Socket
), Shutmodes
(How
));
1958 if Res
= Failure
then
1959 Raise_Socket_Error
(Socket_Errno
);
1961 end Shutdown_Socket
;
1968 (Socket
: Socket_Type
;
1969 Send_To
: Sock_Addr_Type
) return Stream_Access
1971 S
: Datagram_Socket_Stream_Access
;
1974 S
:= new Datagram_Socket_Stream_Type
;
1977 S
.From
:= Get_Socket_Name
(Socket
);
1978 return Stream_Access
(S
);
1985 function Stream
(Socket
: Socket_Type
) return Stream_Access
is
1986 S
: Stream_Socket_Stream_Access
;
1988 S
:= new Stream_Socket_Stream_Type
;
1990 return Stream_Access
(S
);
1997 function To_C
(Socket
: Socket_Type
) return Integer is
1999 return Integer (Socket
);
2006 function To_Host_Entry
(E
: Hostent
) return Host_Entry_Type
is
2009 Official
: constant String :=
2010 C
.Strings
.Value
(E
.H_Name
);
2012 Aliases
: constant Chars_Ptr_Array
:=
2013 Chars_Ptr_Pointers
.Value
(E
.H_Aliases
);
2014 -- H_Aliases points to a list of name aliases. The list is terminated by
2017 Addresses
: constant In_Addr_Access_Array
:=
2018 In_Addr_Access_Pointers
.Value
(E
.H_Addr_List
);
2019 -- H_Addr_List points to a list of binary addresses (in network byte
2020 -- order). The list is terminated by a NULL pointer.
2022 -- H_Length is not used because it is currently only set to 4.
2023 -- H_Addrtype is always AF_INET
2025 Result
: Host_Entry_Type
2026 (Aliases_Length
=> Aliases
'Length - 1,
2027 Addresses_Length
=> Addresses
'Length - 1);
2028 -- The last element is a null pointer
2034 Result
.Official
:= To_Name
(Official
);
2036 Source
:= Aliases
'First;
2037 Target
:= Result
.Aliases
'First;
2038 while Target
<= Result
.Aliases_Length
loop
2039 Result
.Aliases
(Target
) :=
2040 To_Name
(C
.Strings
.Value
(Aliases
(Source
)));
2041 Source
:= Source
+ 1;
2042 Target
:= Target
+ 1;
2045 Source
:= Addresses
'First;
2046 Target
:= Result
.Addresses
'First;
2047 while Target
<= Result
.Addresses_Length
loop
2048 To_Inet_Addr
(Addresses
(Source
).all, Result
.Addresses
(Target
));
2049 Source
:= Source
+ 1;
2050 Target
:= Target
+ 1;
2060 function To_In_Addr
(Addr
: Inet_Addr_Type
) return Thin
.In_Addr
is
2062 if Addr
.Family
= Family_Inet
then
2063 return (S_B1
=> C
.unsigned_char
(Addr
.Sin_V4
(1)),
2064 S_B2
=> C
.unsigned_char
(Addr
.Sin_V4
(2)),
2065 S_B3
=> C
.unsigned_char
(Addr
.Sin_V4
(3)),
2066 S_B4
=> C
.unsigned_char
(Addr
.Sin_V4
(4)));
2076 procedure To_Inet_Addr
2078 Result
: out Inet_Addr_Type
) is
2080 Result
.Sin_V4
(1) := Inet_Addr_Comp_Type
(Addr
.S_B1
);
2081 Result
.Sin_V4
(2) := Inet_Addr_Comp_Type
(Addr
.S_B2
);
2082 Result
.Sin_V4
(3) := Inet_Addr_Comp_Type
(Addr
.S_B3
);
2083 Result
.Sin_V4
(4) := Inet_Addr_Comp_Type
(Addr
.S_B4
);
2090 function To_Int
(F
: Request_Flag_Type
) return C
.int
2092 Current
: Request_Flag_Type
:= F
;
2093 Result
: C
.int
:= 0;
2096 for J
in Flags
'Range loop
2097 exit when Current
= 0;
2099 if Current
mod 2 /= 0 then
2100 if Flags
(J
) = -1 then
2101 Raise_Socket_Error
(Constants
.EOPNOTSUPP
);
2103 Result
:= Result
+ Flags
(J
);
2106 Current
:= Current
/ 2;
2116 function To_Name
(N
: String) return Name_Type
is
2118 return Name_Type
'(N'Length, N);
2121 ----------------------
2122 -- To_Service_Entry --
2123 ----------------------
2125 function To_Service_Entry (E : Servent) return Service_Entry_Type is
2128 Official : constant String :=
2129 C.Strings.Value (E.S_Name);
2131 Aliases : constant Chars_Ptr_Array :=
2132 Chars_Ptr_Pointers.Value (E.S_Aliases);
2133 -- S_Aliases points to a list of name aliases. The list is
2134 -- terminated by a NULL pointer.
2136 Protocol : constant String :=
2137 C.Strings.Value (E.S_Proto);
2139 Result : Service_Entry_Type
2140 (Aliases_Length => Aliases'Length - 1);
2141 -- The last element is a null pointer
2147 Result.Official := To_Name (Official);
2149 Source := Aliases'First;
2150 Target := Result.Aliases'First;
2151 while Target <= Result.Aliases_Length loop
2152 Result.Aliases (Target) :=
2153 To_Name (C.Strings.Value (Aliases (Source)));
2154 Source := Source + 1;
2155 Target := Target + 1;
2159 Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2161 Result.Protocol := To_Name (Protocol);
2164 end To_Service_Entry;
2170 function To_String (HN : Name_Type) return String is
2172 return HN.Name (1 .. HN.Length);
2179 function To_Timeval (Val : Selector_Duration) return Timeval is
2184 -- If zero, set result as zero (otherwise it gets rounded down to -1)
2190 -- Normal case where we do round down
2193 S := Timeval_Unit (Val - 0.5);
2194 MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
2205 (Stream : in out Datagram_Socket_Stream_Type;
2206 Item : Ada.Streams.Stream_Element_Array)
2208 First : Ada.Streams.Stream_Element_Offset := Item'First;
2209 Index : Ada.Streams.Stream_Element_Offset := First - 1;
2210 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2216 Item (First .. Max),
2220 -- Exit when all or zero data sent. Zero means that the socket has
2221 -- been closed by peer.
2223 exit when Index < First or else Index = Max;
2228 if Index /= Max then
2238 (Stream : in out Stream_Socket_Stream_Type;
2239 Item : Ada.Streams.Stream_Element_Array)
2241 First : Ada.Streams.Stream_Element_Offset := Item'First;
2242 Index : Ada.Streams.Stream_Element_Offset := First - 1;
2243 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2247 Send_Socket (Stream.Socket, Item (First .. Max), Index);
2249 -- Exit when all or zero data sent. Zero means that the socket has
2250 -- been closed by peer.
2252 exit when Index < First or else Index = Max;
2257 if Index /= Max then