1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S --
9 -- Copyright (C) 2001-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with Ada
.Streams
; use Ada
.Streams
;
34 with Ada
.Exceptions
; use Ada
.Exceptions
;
35 with Ada
.Unchecked_Deallocation
;
36 with Ada
.Unchecked_Conversion
;
38 with Interfaces
.C
.Strings
;
40 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
41 with GNAT
.Sockets
.Constants
;
42 with GNAT
.Sockets
.Thin
; use GNAT
.Sockets
.Thin
;
45 with GNAT
.Sockets
.Linker_Options
;
46 pragma Warnings
(Off
, GNAT
.Sockets
.Linker_Options
);
47 -- Need to include pragma Linker_Options which is platform dependent.
49 with System
; use System
;
51 package body GNAT
.Sockets
is
53 use type C
.int
, System
.Address
;
55 Finalized
: Boolean := False;
56 Initialized
: Boolean := False;
58 -- Correspondance tables
60 Families
: constant array (Family_Type
) of C
.int
:=
61 (Family_Inet
=> Constants
.AF_INET
,
62 Family_Inet6
=> Constants
.AF_INET6
);
64 Levels
: constant array (Level_Type
) of C
.int
:=
65 (Socket_Level
=> Constants
.SOL_SOCKET
,
66 IP_Protocol_For_IP_Level
=> Constants
.IPPROTO_IP
,
67 IP_Protocol_For_UDP_Level
=> Constants
.IPPROTO_UDP
,
68 IP_Protocol_For_TCP_Level
=> Constants
.IPPROTO_TCP
);
70 Modes
: constant array (Mode_Type
) of C
.int
:=
71 (Socket_Stream
=> Constants
.SOCK_STREAM
,
72 Socket_Datagram
=> Constants
.SOCK_DGRAM
);
74 Shutmodes
: constant array (Shutmode_Type
) of C
.int
:=
75 (Shut_Read
=> Constants
.SHUT_RD
,
76 Shut_Write
=> Constants
.SHUT_WR
,
77 Shut_Read_Write
=> Constants
.SHUT_RDWR
);
79 Requests
: constant array (Request_Name
) of C
.int
:=
80 (Non_Blocking_IO
=> Constants
.FIONBIO
,
81 N_Bytes_To_Read
=> Constants
.FIONREAD
);
83 Options
: constant array (Option_Name
) of C
.int
:=
84 (Keep_Alive
=> Constants
.SO_KEEPALIVE
,
85 Reuse_Address
=> Constants
.SO_REUSEADDR
,
86 Broadcast
=> Constants
.SO_BROADCAST
,
87 Send_Buffer
=> Constants
.SO_SNDBUF
,
88 Receive_Buffer
=> Constants
.SO_RCVBUF
,
89 Linger
=> Constants
.SO_LINGER
,
90 Error
=> Constants
.SO_ERROR
,
91 No_Delay
=> Constants
.TCP_NODELAY
,
92 Add_Membership
=> Constants
.IP_ADD_MEMBERSHIP
,
93 Drop_Membership
=> Constants
.IP_DROP_MEMBERSHIP
,
94 Multicast_TTL
=> Constants
.IP_MULTICAST_TTL
,
95 Multicast_Loop
=> Constants
.IP_MULTICAST_LOOP
);
97 Socket_Error_Id
: constant Exception_Id
:= Socket_Error
'Identity;
98 Host_Error_Id
: constant Exception_Id
:= Host_Error
'Identity;
100 Hex_To_Char
: constant String (1 .. 16) := "0123456789ABCDEF";
101 -- Use to print in hexadecimal format
103 function To_In_Addr
is new Ada
.Unchecked_Conversion
(C
.int
, In_Addr
);
104 function To_Int
is new Ada
.Unchecked_Conversion
(In_Addr
, C
.int
);
106 -----------------------
107 -- Local subprograms --
108 -----------------------
110 function Resolve_Error
111 (Error_Value
: Integer;
112 From_Errno
: Boolean := True)
114 -- Associate an enumeration value (error_type) to en error value
115 -- (errno). From_Errno prevents from mixing h_errno with errno.
117 function To_Host_Name
(N
: String) return Host_Name_Type
;
118 function To_String
(HN
: Host_Name_Type
) return String;
119 -- Conversion functions
121 function Port_To_Network
122 (Port
: C
.unsigned_short
)
123 return C
.unsigned_short
;
124 pragma Inline
(Port_To_Network
);
125 -- Convert a port number into a network port number
127 function Network_To_Port
128 (Net_Port
: C
.unsigned_short
)
129 return C
.unsigned_short
130 renames Port_To_Network
;
131 -- Symetric operation
134 (Val
: Inet_Addr_VN_Type
;
135 Hex
: Boolean := False)
137 -- Output an array of inet address components either in
138 -- hexadecimal or in decimal mode.
140 function To_In_Addr
(Addr
: Inet_Addr_Type
) return Thin
.In_Addr
;
141 function To_Inet_Addr
(Addr
: In_Addr
) return Inet_Addr_Type
;
142 -- Conversion functions
144 function To_Host_Entry
(Host
: Hostent
) return Host_Entry_Type
;
145 -- Conversion function
147 function To_Timeval
(Val
: Duration) return Timeval
;
148 -- Separate Val in seconds and microseconds
150 procedure Raise_Socket_Error
(Error
: Integer);
151 -- Raise Socket_Error with an exception message describing
154 procedure Raise_Host_Error
(Error
: Integer);
155 -- Raise Host_Error exception with message describing error code
156 -- (note hstrerror seems to be obsolete).
158 -- Types needed for Socket_Set_Type
160 type Socket_Set_Record
is new Fd_Set
;
163 new Ada
.Unchecked_Deallocation
(Socket_Set_Record
, Socket_Set_Type
);
165 -- Types needed for Datagram_Socket_Stream_Type
167 type Datagram_Socket_Stream_Type
is new Root_Stream_Type
with record
168 Socket
: Socket_Type
;
170 From
: Sock_Addr_Type
;
173 type Datagram_Socket_Stream_Access
is
174 access all Datagram_Socket_Stream_Type
;
177 (Stream
: in out Datagram_Socket_Stream_Type
;
178 Item
: out Ada
.Streams
.Stream_Element_Array
;
179 Last
: out Ada
.Streams
.Stream_Element_Offset
);
182 (Stream
: in out Datagram_Socket_Stream_Type
;
183 Item
: Ada
.Streams
.Stream_Element_Array
);
185 -- Types needed for Stream_Socket_Stream_Type
187 type Stream_Socket_Stream_Type
is new Root_Stream_Type
with record
188 Socket
: Socket_Type
;
191 type Stream_Socket_Stream_Access
is
192 access all Stream_Socket_Stream_Type
;
195 (Stream
: in out Stream_Socket_Stream_Type
;
196 Item
: out Ada
.Streams
.Stream_Element_Array
;
197 Last
: out Ada
.Streams
.Stream_Element_Offset
);
200 (Stream
: in out Stream_Socket_Stream_Type
;
201 Item
: Ada
.Streams
.Stream_Element_Array
);
207 procedure Abort_Selector
(Selector
: Selector_Type
) is
212 -- Send an empty array to unblock C select system call
214 if Selector
.In_Progress
then
215 Res
:= C_Write
(C
.int
(Selector
.W_Sig_Socket
), Buf
'Address, 1);
223 procedure Accept_Socket
224 (Server
: Socket_Type
;
225 Socket
: out Socket_Type
;
226 Address
: out Sock_Addr_Type
)
229 Sin
: aliased Sockaddr_In
;
230 Len
: aliased C
.int
:= Sin
'Size / 8;
233 Res
:= C_Accept
(C
.int
(Server
), Sin
'Address, Len
'Access);
235 if Res
= Failure
then
236 Raise_Socket_Error
(Socket_Errno
);
239 Socket
:= Socket_Type
(Res
);
241 Address
.Addr
:= To_Inet_Addr
(Sin
.Sin_Addr
);
242 Address
.Port
:= Port_Type
(Network_To_Port
(Sin
.Sin_Port
));
250 (E
: Host_Entry_Type
;
252 return Inet_Addr_Type
255 return E
.Addresses
(N
);
258 ----------------------
259 -- Addresses_Length --
260 ----------------------
262 function Addresses_Length
(E
: Host_Entry_Type
) return Natural is
264 return E
.Addresses_Length
;
265 end Addresses_Length
;
272 (E
: Host_Entry_Type
;
277 return To_String
(E
.Aliases
(N
));
284 function Aliases_Length
(E
: Host_Entry_Type
) return Natural is
286 return E
.Aliases_Length
;
293 procedure Bind_Socket
294 (Socket
: Socket_Type
;
295 Address
: Sock_Addr_Type
)
298 Sin
: aliased Sockaddr_In
;
299 Len
: aliased C
.int
:= Sin
'Size / 8;
302 if Address
.Family
= Family_Inet6
then
306 Sin
.Sin_Family
:= C
.unsigned_short
(Families
(Address
.Family
));
307 Sin
.Sin_Port
:= Port_To_Network
(C
.unsigned_short
(Address
.Port
));
309 Res
:= C_Bind
(C
.int
(Socket
), Sin
'Address, Len
);
311 if Res
= Failure
then
312 Raise_Socket_Error
(Socket_Errno
);
320 procedure Check_Selector
321 (Selector
: in out Selector_Type
;
322 R_Socket_Set
: in out Socket_Set_Type
;
323 W_Socket_Set
: in out Socket_Set_Type
;
324 Status
: out Selector_Status
;
325 Timeout
: Duration := Forever
)
329 RSet
: aliased Fd_Set
;
330 WSet
: aliased Fd_Set
;
331 TVal
: aliased Timeval
;
332 TPtr
: Timeval_Access
;
337 -- No timeout or Forever is indicated by a null timeval pointer.
339 if Timeout
= Forever
then
342 TVal
:= To_Timeval
(Timeout
);
343 TPtr
:= TVal
'Unchecked_Access;
346 -- Copy R_Socket_Set in RSet and add read signalling socket.
348 if R_Socket_Set
= null then
351 RSet
:= Fd_Set
(R_Socket_Set
.all);
354 Set
(RSet
, C
.int
(Selector
.R_Sig_Socket
));
355 Len
:= Max
(RSet
) + 1;
357 -- Copy W_Socket_Set in WSet.
359 if W_Socket_Set
= null then
362 WSet
:= Fd_Set
(W_Socket_Set
.all);
365 Len
:= C
.int
'Max (Max
(RSet
) + 1, Len
);
367 Selector
.In_Progress
:= True;
371 RSet
'Unchecked_Access,
372 WSet
'Unchecked_Access,
374 Selector
.In_Progress
:= False;
376 -- If Select was resumed because of read signalling socket,
377 -- read this data and remove socket from set.
379 if Is_Set
(RSet
, C
.int
(Selector
.R_Sig_Socket
)) then
380 Clear
(RSet
, C
.int
(Selector
.R_Sig_Socket
));
385 Res
:= C_Read
(C
.int
(Selector
.R_Sig_Socket
), Buf
'Address, 1);
388 -- Select was resumed because of read signalling socket, but
389 -- the call is said aborted only when there is no other read
393 and then Is_Empty
(WSet
)
402 if R_Socket_Set
/= null then
403 R_Socket_Set
.all := Socket_Set_Record
(RSet
);
406 if W_Socket_Set
/= null then
407 W_Socket_Set
.all := Socket_Set_Record
(WSet
);
416 (Item
: in out Socket_Set_Type
;
417 Socket
: Socket_Type
)
421 Item
:= new Socket_Set_Record
;
422 Empty
(Fd_Set
(Item
.all));
425 Clear
(Fd_Set
(Item
.all), C
.int
(Socket
));
432 procedure Close_Selector
(Selector
: in out Selector_Type
) is
435 Close_Socket
(Selector
.R_Sig_Socket
);
436 exception when Socket_Error
=>
441 Close_Socket
(Selector
.W_Sig_Socket
);
442 exception when Socket_Error
=>
451 procedure Close_Socket
(Socket
: Socket_Type
) is
455 Res
:= C_Close
(C
.int
(Socket
));
457 if Res
= Failure
then
458 Raise_Socket_Error
(Socket_Errno
);
466 procedure Connect_Socket
467 (Socket
: Socket_Type
;
468 Server
: in out Sock_Addr_Type
)
471 Sin
: aliased Sockaddr_In
;
472 Len
: aliased C
.int
:= Sin
'Size / 8;
475 if Server
.Family
= Family_Inet6
then
479 Sin
.Sin_Family
:= C
.unsigned_short
(Families
(Server
.Family
));
480 Sin
.Sin_Addr
:= To_In_Addr
(Server
.Addr
);
481 Sin
.Sin_Port
:= Port_To_Network
(C
.unsigned_short
(Server
.Port
));
483 Res
:= C_Connect
(C
.int
(Socket
), Sin
'Address, Len
);
485 if Res
= Failure
then
486 Raise_Socket_Error
(Socket_Errno
);
494 procedure Control_Socket
495 (Socket
: Socket_Type
;
496 Request
: in out Request_Type
)
503 when Non_Blocking_IO
=>
504 Arg
:= C
.int
(Boolean'Pos (Request
.Enabled
));
506 when N_Bytes_To_Read
=>
513 Requests
(Request
.Name
),
514 Arg
'Unchecked_Access);
516 if Res
= Failure
then
517 Raise_Socket_Error
(Socket_Errno
);
521 when Non_Blocking_IO
=>
524 when N_Bytes_To_Read
=>
525 Request
.Size
:= Natural (Arg
);
530 ---------------------
531 -- Create_Selector --
532 ---------------------
534 procedure Create_Selector
(Selector
: out Selector_Type
) is
539 Sin
: aliased Sockaddr_In
;
540 Len
: aliased C
.int
:= Sin
'Size / 8;
544 -- We open two signalling sockets. One socket to send a signal
545 -- to a another socket that always included in a C_Select
546 -- socket set. When received, it resumes the task suspended in
549 -- Create a listening socket
551 S0
:= C_Socket
(Constants
.AF_INET
, Constants
.SOCK_STREAM
, 0);
553 Raise_Socket_Error
(Socket_Errno
);
556 -- Sin is already correctly initialized. Bind the socket to any
559 Res
:= C_Bind
(S0
, Sin
'Address, Len
);
560 if Res
= Failure
then
563 Raise_Socket_Error
(Err
);
566 -- Get the port used by the socket
568 Res
:= C_Getsockname
(S0
, Sin
'Address, Len
'Access);
570 if Res
= Failure
then
573 Raise_Socket_Error
(Err
);
576 Res
:= C_Listen
(S0
, 2);
578 if Res
= Failure
then
581 Raise_Socket_Error
(Err
);
584 S1
:= C_Socket
(Constants
.AF_INET
, Constants
.SOCK_STREAM
, 0);
589 Raise_Socket_Error
(Err
);
592 -- Use INADDR_LOOPBACK
594 Sin
.Sin_Addr
.S_B1
:= 127;
595 Sin
.Sin_Addr
.S_B2
:= 0;
596 Sin
.Sin_Addr
.S_B3
:= 0;
597 Sin
.Sin_Addr
.S_B4
:= 1;
599 -- Do a connect and accept the connection
601 Res
:= C_Connect
(S1
, Sin
'Address, Len
);
603 if Res
= Failure
then
607 Raise_Socket_Error
(Err
);
610 S2
:= C_Accept
(S0
, Sin
'Address, Len
'Access);
616 Raise_Socket_Error
(Err
);
621 if Res
= Failure
then
622 Raise_Socket_Error
(Socket_Errno
);
625 Selector
.R_Sig_Socket
:= Socket_Type
(S1
);
626 Selector
.W_Sig_Socket
:= Socket_Type
(S2
);
633 procedure Create_Socket
634 (Socket
: out Socket_Type
;
635 Family
: Family_Type
:= Family_Inet
;
636 Mode
: Mode_Type
:= Socket_Stream
)
641 Res
:= C_Socket
(Families
(Family
), Modes
(Mode
), 0);
643 if Res
= Failure
then
644 Raise_Socket_Error
(Socket_Errno
);
647 Socket
:= Socket_Type
(Res
);
654 procedure Empty
(Item
: in out Socket_Set_Type
) is
665 procedure Finalize
is
679 function Get_Address
(Stream
: Stream_Access
) return Sock_Addr_Type
is
681 if Stream
= null then
684 elsif Stream
.all in Datagram_Socket_Stream_Type
then
685 return Datagram_Socket_Stream_Type
(Stream
.all).From
;
688 return Get_Peer_Name
(Stream_Socket_Stream_Type
(Stream
.all).Socket
);
692 -------------------------
693 -- Get_Host_By_Address --
694 -------------------------
696 function Get_Host_By_Address
697 (Address
: Inet_Addr_Type
;
698 Family
: Family_Type
:= Family_Inet
)
699 return Host_Entry_Type
701 pragma Unreferenced
(Family
);
703 HA
: aliased In_Addr
:= To_In_Addr
(Address
);
704 Res
: Hostent_Access
;
708 -- This C function is not always thread-safe. Protect against
709 -- concurrent access.
712 Res
:= C_Gethostbyaddr
(HA
'Address, HA
'Size / 8, Constants
.AF_INET
);
717 Raise_Host_Error
(Err
);
720 -- Translate from the C format to the API format
723 HE
: Host_Entry_Type
:= To_Host_Entry
(Res
.all);
729 end Get_Host_By_Address
;
731 ----------------------
732 -- Get_Host_By_Name --
733 ----------------------
735 function Get_Host_By_Name
737 return Host_Entry_Type
739 HN
: C
.char_array
:= C
.To_C
(Name
);
740 Res
: Hostent_Access
;
744 -- This C function is not always thread-safe. Protect against
745 -- concurrent access.
748 Res
:= C_Gethostbyname
(HN
);
753 Raise_Host_Error
(Err
);
756 -- Translate from the C format to the API format
759 HE
: Host_Entry_Type
:= To_Host_Entry
(Res
.all);
765 end Get_Host_By_Name
;
771 function Get_Peer_Name
772 (Socket
: Socket_Type
)
773 return Sock_Addr_Type
775 Sin
: aliased Sockaddr_In
;
776 Len
: aliased C
.int
:= Sin
'Size / 8;
777 Res
: Sock_Addr_Type
(Family_Inet
);
780 if C_Getpeername
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
781 Raise_Socket_Error
(Socket_Errno
);
784 Res
.Addr
:= To_Inet_Addr
(Sin
.Sin_Addr
);
785 Res
.Port
:= Port_Type
(Network_To_Port
(Sin
.Sin_Port
));
790 ---------------------
791 -- Get_Socket_Name --
792 ---------------------
794 function Get_Socket_Name
795 (Socket
: Socket_Type
)
796 return Sock_Addr_Type
798 Sin
: aliased Sockaddr_In
;
799 Len
: aliased C
.int
:= Sin
'Size / 8;
800 Res
: Sock_Addr_Type
(Family_Inet
);
803 if C_Getsockname
(C
.int
(Socket
), Sin
'Address, Len
'Access) = Failure
then
804 Raise_Socket_Error
(Socket_Errno
);
807 Res
.Addr
:= To_Inet_Addr
(Sin
.Sin_Addr
);
808 Res
.Port
:= Port_Type
(Network_To_Port
(Sin
.Sin_Port
));
813 -----------------------
814 -- Get_Socket_Option --
815 -----------------------
817 function Get_Socket_Option
818 (Socket
: Socket_Type
;
819 Level
: Level_Type
:= Socket_Level
;
823 use type C
.unsigned_char
;
825 V8
: aliased Two_Int
;
827 V1
: aliased C
.unsigned_char
;
829 Add
: System
.Address
;
831 Opt
: Option_Type
(Name
);
835 when Multicast_Loop |
863 Add
, Len
'Unchecked_Access);
865 if Res
= Failure
then
866 Raise_Socket_Error
(Socket_Errno
);
874 Opt
.Enabled
:= (V4
/= 0);
877 Opt
.Enabled
:= (V8
(V8
'First) /= 0);
878 Opt
.Seconds
:= Natural (V8
(V8
'Last));
882 Opt
.Size
:= Natural (V4
);
885 Opt
.Error
:= Resolve_Error
(Integer (V4
));
887 when Add_Membership |
889 Opt
.Multiaddr
:= To_Inet_Addr
(To_In_Addr
(V8
(V8
'First)));
890 Opt
.Interface
:= To_Inet_Addr
(To_In_Addr
(V8
(V8
'Last)));
892 when Multicast_TTL
=>
893 Opt
.Time_To_Live
:= Integer (V1
);
895 when Multicast_Loop
=>
896 Opt
.Enabled
:= (V1
/= 0);
901 end Get_Socket_Option
;
907 function Host_Name
return String is
908 Name
: aliased C
.char_array
(1 .. 64);
912 Res
:= C_Gethostname
(Name
'Address, Name
'Length);
914 if Res
= Failure
then
915 Raise_Socket_Error
(Socket_Errno
);
918 return C
.To_Ada
(Name
);
926 (Val
: Inet_Addr_VN_Type
;
927 Hex
: Boolean := False)
930 -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
931 -- has at most a length of 3 plus one '.' character.
933 Buffer
: String (1 .. 4 * Val
'Length);
934 Length
: Natural := 1;
935 Separator
: Character;
937 procedure Img10
(V
: Inet_Addr_Comp_Type
);
938 -- Append to Buffer image of V in decimal format
940 procedure Img16
(V
: Inet_Addr_Comp_Type
);
941 -- Append to Buffer image of V in hexadecimal format
943 procedure Img10
(V
: Inet_Addr_Comp_Type
) is
944 Img
: constant String := V
'Img;
945 Len
: Natural := Img
'Length - 1;
948 Buffer
(Length
.. Length
+ Len
- 1) := Img
(2 .. Img
'Last);
949 Length
:= Length
+ Len
;
952 procedure Img16
(V
: Inet_Addr_Comp_Type
) is
954 Buffer
(Length
) := Hex_To_Char
(Natural (V
/ 16) + 1);
955 Buffer
(Length
+ 1) := Hex_To_Char
(Natural (V
mod 16) + 1);
956 Length
:= Length
+ 2;
959 -- Start of processing for Image
968 for J
in Val
'Range loop
975 if J
/= Val
'Last then
976 Buffer
(Length
) := Separator
;
977 Length
:= Length
+ 1;
981 return Buffer
(1 .. Length
- 1);
988 function Image
(Value
: Inet_Addr_Type
) return String is
990 if Value
.Family
= Family_Inet
then
991 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V4
), Hex
=> False);
993 return Image
(Inet_Addr_VN_Type
(Value
.Sin_V6
), Hex
=> True);
1001 function Image
(Value
: Sock_Addr_Type
) return String is
1002 Port
: constant String := Value
.Port
'Img;
1005 return Image
(Value
.Addr
) & ':' & Port
(2 .. Port
'Last);
1012 function Image
(Socket
: Socket_Type
) return String is
1021 function Inet_Addr
(Image
: String) return Inet_Addr_Type
is
1022 use Interfaces
.C
.Strings
;
1024 Img
: chars_ptr
:= New_String
(Image
);
1029 Res
:= C_Inet_Addr
(Img
);
1033 if Res
= Failure
then
1034 Raise_Socket_Error
(Err
);
1037 return To_Inet_Addr
(To_In_Addr
(Res
));
1044 procedure Initialize
(Process_Blocking_IO
: Boolean := False) is
1046 if not Initialized
then
1047 Initialized
:= True;
1048 Thin
.Initialize
(Process_Blocking_IO
);
1056 function Is_Empty
(Item
: Socket_Set_Type
) return Boolean is
1058 return Item
= null or else Is_Empty
(Fd_Set
(Item
.all));
1066 (Item
: Socket_Set_Type
;
1067 Socket
: Socket_Type
) return Boolean
1071 and then Is_Set
(Fd_Set
(Item
.all), C
.int
(Socket
));
1078 procedure Listen_Socket
1079 (Socket
: Socket_Type
;
1080 Length
: Positive := 15)
1085 Res
:= C_Listen
(C
.int
(Socket
), C
.int
(Length
));
1086 if Res
= Failure
then
1087 Raise_Socket_Error
(Socket_Errno
);
1095 function Official_Name
(E
: Host_Entry_Type
) return String is
1097 return To_String
(E
.Official
);
1100 ---------------------
1101 -- Port_To_Network --
1102 ---------------------
1104 function Port_To_Network
1105 (Port
: C
.unsigned_short
)
1106 return C
.unsigned_short
1108 use type C
.unsigned_short
;
1110 if Default_Bit_Order
= High_Order_First
then
1112 -- No conversion needed. On these platforms, htons() defaults
1113 -- to a null procedure.
1118 -- We need to swap the high and low byte on this short to make
1119 -- the port number network compliant.
1121 return (Port
/ 256) + (Port
mod 256) * 256;
1123 end Port_To_Network
;
1125 ----------------------
1126 -- Raise_Host_Error --
1127 ----------------------
1129 procedure Raise_Host_Error
(Error
: Integer) is
1131 function Error_Message
return String;
1132 -- We do not use a C function like strerror because hstrerror
1133 -- that would correspond seems to be obsolete. Return
1134 -- appropriate string for error value.
1136 function Error_Message
return String is
1139 when Constants
.HOST_NOT_FOUND
=> return "Host not found";
1140 when Constants
.TRY_AGAIN
=> return "Try again";
1141 when Constants
.NO_RECOVERY
=> return "No recovery";
1142 when Constants
.NO_ADDRESS
=> return "No address";
1143 when others => return "Unknown error";
1147 -- Start of processing for Raise_Host_Error
1150 Ada
.Exceptions
.Raise_Exception
(Host_Error
'Identity, Error_Message
);
1151 end Raise_Host_Error
;
1153 ------------------------
1154 -- Raise_Socket_Error --
1155 ------------------------
1157 procedure Raise_Socket_Error
(Error
: Integer) is
1158 use type C
.Strings
.chars_ptr
;
1160 function Image
(E
: Integer) return String;
1161 function Image
(E
: Integer) return String is
1162 Msg
: String := E
'Img & "] ";
1164 Msg
(Msg
'First) := '[';
1169 Ada
.Exceptions
.Raise_Exception
1170 (Socket_Error
'Identity, Image
(Error
) & Socket_Error_Message
(Error
));
1171 end Raise_Socket_Error
;
1178 (Stream
: in out Datagram_Socket_Stream_Type
;
1179 Item
: out Ada
.Streams
.Stream_Element_Array
;
1180 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1182 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1183 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1184 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1190 Item
(First
.. Max
),
1196 -- Exit when all or zero data received. Zero means that
1197 -- the socket peer is closed.
1199 exit when Index
< First
or else Index
= Max
;
1210 (Stream
: in out Stream_Socket_Stream_Type
;
1211 Item
: out Ada
.Streams
.Stream_Element_Array
;
1212 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1214 First
: Ada
.Streams
.Stream_Element_Offset
:= Item
'First;
1215 Index
: Ada
.Streams
.Stream_Element_Offset
:= First
- 1;
1216 Max
: constant Ada
.Streams
.Stream_Element_Offset
:= Item
'Last;
1220 Receive_Socket
(Stream
.Socket
, Item
(First
.. Max
), Index
);
1223 -- Exit when all or zero data received. Zero means that
1224 -- the socket peer is closed.
1226 exit when Index
< First
or else Index
= Max
;
1236 function Resolve_Error
1237 (Error_Value
: Integer;
1238 From_Errno
: Boolean := True)
1241 use GNAT
.Sockets
.Constants
;
1244 if not From_Errno
then
1246 when HOST_NOT_FOUND
=> return Unknown_Host
;
1247 when TRY_AGAIN
=> return Host_Name_Lookup_Failure
;
1248 when NO_RECOVERY
=> return No_Address_Associated_With_Name
;
1249 when NO_ADDRESS
=> return Unknown_Server_Error
;
1250 when others => return Cannot_Resolve_Error
;
1255 when EACCES
=> return Permission_Denied
;
1256 when EADDRINUSE
=> return Address_Already_In_Use
;
1257 when EADDRNOTAVAIL
=> return Cannot_Assign_Requested_Address
;
1258 when EAFNOSUPPORT
=>
1259 return Address_Family_Not_Supported_By_Protocol
;
1260 when EALREADY
=> return Operation_Already_In_Progress
;
1261 when EBADF
=> return Bad_File_Descriptor
;
1262 when ECONNREFUSED
=> return Connection_Refused
;
1263 when EFAULT
=> return Bad_Address
;
1264 when EINPROGRESS
=> return Operation_Now_In_Progress
;
1265 when EINTR
=> return Interrupted_System_Call
;
1266 when EINVAL
=> return Invalid_Argument
;
1267 when EIO
=> return Input_Output_Error
;
1268 when EISCONN
=> return Transport_Endpoint_Already_Connected
;
1269 when EMSGSIZE
=> return Message_Too_Long
;
1270 when ENETUNREACH
=> return Network_Is_Unreachable
;
1271 when ENOBUFS
=> return No_Buffer_Space_Available
;
1272 when ENOPROTOOPT
=> return Protocol_Not_Available
;
1273 when ENOTCONN
=> return Transport_Endpoint_Not_Connected
;
1274 when EOPNOTSUPP
=> return Operation_Not_Supported
;
1275 when EPROTONOSUPPORT
=> return Protocol_Not_Supported
;
1276 when ESOCKTNOSUPPORT
=> return Socket_Type_Not_Supported
;
1277 when ETIMEDOUT
=> return Connection_Timed_Out
;
1278 when EWOULDBLOCK
=> return Resource_Temporarily_Unavailable
;
1279 when others => return Cannot_Resolve_Error
;
1283 -----------------------
1284 -- Resolve_Exception --
1285 -----------------------
1287 function Resolve_Exception
1288 (Occurrence
: Exception_Occurrence
)
1291 Id
: Exception_Id
:= Exception_Identity
(Occurrence
);
1292 Msg
: constant String := Exception_Message
(Occurrence
);
1293 First
: Natural := Msg
'First;
1298 while First
<= Msg
'Last
1299 and then Msg
(First
) not in '0' .. '9'
1304 if First
> Msg
'Last then
1305 return Cannot_Resolve_Error
;
1310 while Last
< Msg
'Last
1311 and then Msg
(Last
+ 1) in '0' .. '9'
1316 Val
:= Integer'Value (Msg
(First
.. Last
));
1318 if Id
= Socket_Error_Id
then
1319 return Resolve_Error
(Val
);
1321 elsif Id
= Host_Error_Id
then
1322 return Resolve_Error
(Val
, False);
1325 return Cannot_Resolve_Error
;
1327 end Resolve_Exception
;
1329 --------------------
1330 -- Receive_Socket --
1331 --------------------
1333 procedure Receive_Socket
1334 (Socket
: Socket_Type
;
1335 Item
: out Ada
.Streams
.Stream_Element_Array
;
1336 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1338 use type Ada
.Streams
.Stream_Element_Offset
;
1345 Item
(Item
'First)'Address,
1348 if Res
= Failure
then
1349 Raise_Socket_Error
(Socket_Errno
);
1352 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1355 --------------------
1356 -- Receive_Socket --
1357 --------------------
1359 procedure Receive_Socket
1360 (Socket
: Socket_Type
;
1361 Item
: out Ada
.Streams
.Stream_Element_Array
;
1362 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1363 From
: out Sock_Addr_Type
)
1365 use type Ada
.Streams
.Stream_Element_Offset
;
1368 Sin
: aliased Sockaddr_In
;
1369 Len
: aliased C
.int
:= Sin
'Size / 8;
1374 Item
(Item
'First)'Address,
1376 Sin
'Unchecked_Access,
1377 Len
'Unchecked_Access);
1379 if Res
= Failure
then
1380 Raise_Socket_Error
(Socket_Errno
);
1383 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1385 From
.Addr
:= To_Inet_Addr
(Sin
.Sin_Addr
);
1386 From
.Port
:= Port_Type
(Network_To_Port
(Sin
.Sin_Port
));
1393 procedure Send_Socket
1394 (Socket
: Socket_Type
;
1395 Item
: Ada
.Streams
.Stream_Element_Array
;
1396 Last
: out Ada
.Streams
.Stream_Element_Offset
)
1398 use type Ada
.Streams
.Stream_Element_Offset
;
1405 Item
(Item
'First)'Address,
1408 if Res
= Failure
then
1409 Raise_Socket_Error
(Socket_Errno
);
1412 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1419 procedure Send_Socket
1420 (Socket
: Socket_Type
;
1421 Item
: Ada
.Streams
.Stream_Element_Array
;
1422 Last
: out Ada
.Streams
.Stream_Element_Offset
;
1423 To
: Sock_Addr_Type
)
1425 use type Ada
.Streams
.Stream_Element_Offset
;
1428 Sin
: aliased Sockaddr_In
;
1429 Len
: aliased C
.int
:= Sin
'Size / 8;
1432 Sin
.Sin_Family
:= C
.unsigned_short
(Families
(To
.Family
));
1433 Sin
.Sin_Addr
:= To_In_Addr
(To
.Addr
);
1434 Sin
.Sin_Port
:= Port_To_Network
(C
.unsigned_short
(To
.Port
));
1438 Item
(Item
'First)'Address,
1440 Sin
'Unchecked_Access,
1443 if Res
= Failure
then
1444 Raise_Socket_Error
(Socket_Errno
);
1447 Last
:= Item
'First + Ada
.Streams
.Stream_Element_Offset
(Res
- 1);
1454 procedure Set
(Item
: in out Socket_Set_Type
; Socket
: Socket_Type
) is
1457 Item
:= new Socket_Set_Record
'(Socket_Set_Record (Null_Fd_Set));
1460 Set (Fd_Set (Item.all), C.int (Socket));
1463 -----------------------
1464 -- Set_Socket_Option --
1465 -----------------------
1467 procedure Set_Socket_Option
1468 (Socket : Socket_Type;
1469 Level : Level_Type := Socket_Level;
1470 Option : Option_Type)
1472 V8 : aliased Two_Int;
1474 V1 : aliased C.unsigned_char;
1475 Len : aliased C.int;
1476 Add : System.Address := Null_Address;
1485 V4 := C.int (Boolean'Pos (Option.Enabled));
1490 V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1491 V8 (V8'Last) := C.int (Option.Seconds);
1497 V4 := C.int (Option.Size);
1502 V4 := C.int (Boolean'Pos (True));
1506 when Add_Membership |
1508 V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr));
1509 V8 (V8'Last) := To_Int (To_In_Addr (Option.Interface));
1513 when Multicast_TTL =>
1514 V1 := C.unsigned_char (Option.Time_To_Live);
1518 when Multicast_Loop =>
1519 V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
1528 Options (Option.Name),
1531 if Res = Failure then
1532 Raise_Socket_Error (Socket_Errno);
1534 end Set_Socket_Option;
1536 ---------------------
1537 -- Shutdown_Socket --
1538 ---------------------
1540 procedure Shutdown_Socket
1541 (Socket : Socket_Type;
1542 How : Shutmode_Type := Shut_Read_Write)
1547 Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1549 if Res = Failure then
1550 Raise_Socket_Error (Socket_Errno);
1552 end Shutdown_Socket;
1559 (Socket : Socket_Type;
1560 Send_To : Sock_Addr_Type)
1561 return Stream_Access
1563 S : Datagram_Socket_Stream_Access;
1566 S := new Datagram_Socket_Stream_Type;
1569 S.From := Get_Socket_Name (Socket);
1570 return Stream_Access (S);
1578 (Socket : Socket_Type)
1579 return Stream_Access
1581 S : Stream_Socket_Stream_Access;
1584 S := new Stream_Socket_Stream_Type;
1586 return Stream_Access (S);
1593 function To_C (Socket : Socket_Type) return Integer is
1595 return Integer (Socket);
1602 function To_Host_Entry
1604 return Host_Entry_Type
1608 Official : constant String :=
1609 C.Strings.Value (Host.H_Name);
1611 Aliases : constant Chars_Ptr_Array :=
1612 Chars_Ptr_Pointers.Value (Host.H_Aliases);
1613 -- H_Aliases points to a list of name aliases. The list is
1614 -- terminated by a NULL pointer.
1616 Addresses : constant In_Addr_Access_Array :=
1617 In_Addr_Access_Pointers.Value (Host.H_Addr_List);
1618 -- H_Addr_List points to a list of binary addresses (in network
1619 -- byte order). The list is terminated by a NULL pointer.
1621 -- H_Length is not used because it is currently only set to 4.
1622 -- H_Addrtype is always AF_INET
1624 Result : Host_Entry_Type
1625 (Aliases_Length => Aliases'Length - 1,
1626 Addresses_Length => Addresses'Length - 1);
1627 -- The last element is a null pointer.
1633 Result.Official := To_Host_Name (Official);
1635 Source := Aliases'First;
1636 Target := Result.Aliases'First;
1637 while Target <= Result.Aliases_Length loop
1638 Result.Aliases (Target) :=
1639 To_Host_Name (C.Strings.Value (Aliases (Source)));
1640 Source := Source + 1;
1641 Target := Target + 1;
1644 Source := Addresses'First;
1645 Target := Result.Addresses'First;
1646 while Target <= Result.Addresses_Length loop
1647 Result.Addresses (Target) :=
1648 To_Inet_Addr (Addresses (Source).all);
1649 Source := Source + 1;
1650 Target := Target + 1;
1660 function To_Host_Name (N : String) return Host_Name_Type is
1662 return (N'Length, N);
1669 function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1671 if Addr.Family = Family_Inet then
1672 return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1673 S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1674 S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1675 S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1685 function To_Inet_Addr
1687 return Inet_Addr_Type
1689 Result : Inet_Addr_Type;
1692 Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1693 Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1694 Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
1695 Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
1704 function To_String (HN : Host_Name_Type) return String is
1706 return HN.Name (1 .. HN.Length);
1713 function To_Timeval (Val : Duration) return Timeval is
1714 S : Timeval_Unit := Timeval_Unit (Val);
1715 MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S)));
1726 (Stream : in out Datagram_Socket_Stream_Type;
1727 Item : Ada.Streams.Stream_Element_Array)
1729 First : Ada.Streams.Stream_Element_Offset := Item'First;
1730 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1731 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1737 Item (First .. Max),
1741 -- Exit when all or zero data sent. Zero means that the
1742 -- socket has been closed by peer.
1744 exit when Index < First or else Index = Max;
1749 if Index /= Max then
1759 (Stream : in out Stream_Socket_Stream_Type;
1760 Item : Ada.Streams.Stream_Element_Array)
1762 First : Ada.Streams.Stream_Element_Offset := Item'First;
1763 Index : Ada.Streams.Stream_Element_Offset := First - 1;
1764 Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1768 Send_Socket (Stream.Socket, Item (First .. Max), Index);
1770 -- Exit when all or zero data sent. Zero means that the
1771 -- socket has been closed by peer.
1773 exit when Index < First or else Index = Max;
1778 if Index /= Max then