diff options
Diffstat (limited to 'gcc/ada/g-socket.adb')
| -rw-r--r-- | gcc/ada/g-socket.adb | 1776 |
1 files changed, 1776 insertions, 0 deletions
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb new file mode 100644 index 00000000000..b58a0dc20c0 --- /dev/null +++ b/gcc/ada/g-socket.adb @@ -0,0 +1,1776 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +with Interfaces.C.Strings; + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; +with GNAT.Task_Lock; + +with GNAT.Sockets.Linker_Options; +pragma Warnings (Off, GNAT.Sockets.Linker_Options); +-- Need to include pragma Linker_Options which is platform dependent. + +with System; use System; + +package body GNAT.Sockets is + + use type C.int, System.Address; + + Finalized : Boolean := False; + Initialized : Boolean := False; + + -- Correspondance tables + + Families : constant array (Family_Type) of C.int := + (Family_Inet => Constants.AF_INET, + Family_Inet6 => Constants.AF_INET6); + + Levels : constant array (Level_Type) of C.int := + (Socket_Level => Constants.SOL_SOCKET, + IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, + IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP, + IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP); + + Modes : constant array (Mode_Type) of C.int := + (Socket_Stream => Constants.SOCK_STREAM, + Socket_Datagram => Constants.SOCK_DGRAM); + + Shutmodes : constant array (Shutmode_Type) of C.int := + (Shut_Read => Constants.SHUT_RD, + Shut_Write => Constants.SHUT_WR, + Shut_Read_Write => Constants.SHUT_RDWR); + + Requests : constant array (Request_Name) of C.int := + (Non_Blocking_IO => Constants.FIONBIO, + N_Bytes_To_Read => Constants.FIONREAD); + + Options : constant array (Option_Name) of C.int := + (Keep_Alive => Constants.SO_KEEPALIVE, + Reuse_Address => Constants.SO_REUSEADDR, + Broadcast => Constants.SO_BROADCAST, + Send_Buffer => Constants.SO_SNDBUF, + Receive_Buffer => Constants.SO_RCVBUF, + Linger => Constants.SO_LINGER, + Error => Constants.SO_ERROR, + No_Delay => Constants.TCP_NODELAY, + Add_Membership => Constants.IP_ADD_MEMBERSHIP, + Drop_Membership => Constants.IP_DROP_MEMBERSHIP, + Multicast_TTL => Constants.IP_MULTICAST_TTL, + Multicast_Loop => Constants.IP_MULTICAST_LOOP); + + Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; + Host_Error_Id : constant Exception_Id := Host_Error'Identity; + + Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; + -- Use to print in hexadecimal format + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) + return Error_Type; + -- Associate an enumeration value (error_type) to en error value + -- (errno). From_Errno prevents from mixing h_errno with errno. + + function To_Host_Name (N : String) return Host_Name_Type; + function To_String (HN : Host_Name_Type) return String; + -- Conversion functions + + function Port_To_Network + (Port : C.unsigned_short) + return C.unsigned_short; + pragma Inline (Port_To_Network); + -- Convert a port number into a network port number + + function Network_To_Port + (Net_Port : C.unsigned_short) + return C.unsigned_short + renames Port_To_Network; + -- Symetric operation + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) + return String; + -- Output an array of inet address components either in + -- hexadecimal or in decimal mode. + + function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr; + function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type; + -- Conversion functions + + function To_Host_Entry (Host : Hostent) return Host_Entry_Type; + -- Conversion function + + function To_Timeval (Val : Duration) return Timeval; + -- Separate Val in seconds and microseconds + + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing + -- the error code. + + procedure Raise_Host_Error (Error : Integer); + -- Raise Host_Error exception with message describing error code + -- (note hstrerror seems to be obsolete). + + -- Types needed for Socket_Set_Type + + type Socket_Set_Record is new Fd_Set; + + procedure Free is + new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type); + + -- Types needed for Datagram_Socket_Stream_Type + + type Datagram_Socket_Stream_Type is new Root_Stream_Type with + record + Socket : Socket_Type; + To : Sock_Addr_Type; + From : Sock_Addr_Type; + end record; + + type Datagram_Socket_Stream_Access is + access all Datagram_Socket_Stream_Type; + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- Types needed for Stream_Socket_Stream_Type + + type Stream_Socket_Stream_Type is new Root_Stream_Type with + record + Socket : Socket_Type; + end record; + + type Stream_Socket_Stream_Access is + access all Stream_Socket_Stream_Type; + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -------------------- + -- Abort_Selector -- + -------------------- + + procedure Abort_Selector (Selector : Selector_Type) is + begin + -- Send an empty array to unblock C select system call + + if Selector.In_Progress then + declare + Buf : Character; + Res : C.int; + begin + Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0); + end; + end if; + end Abort_Selector; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Accept (C.int (Server), Sin'Address, Len'Access); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + + Address.Addr := To_Inet_Addr (Sin.Sin_Addr); + Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + end Accept_Socket; + + --------------- + -- Addresses -- + --------------- + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) + return Inet_Addr_Type + is + begin + return E.Addresses (N); + end Addresses; + + ---------------------- + -- Addresses_Length -- + ---------------------- + + function Addresses_Length (E : Host_Entry_Type) return Natural is + begin + return E.Addresses_Length; + end Addresses_Length; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) + return String + is + begin + return To_String (E.Aliases (N)); + end Aliases; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (E : Host_Entry_Type) return Natural is + begin + return E.Aliases_Length; + end Aliases_Length; + + ----------------- + -- Bind_Socket -- + ----------------- + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + if Address.Family = Family_Inet6 then + raise Socket_Error; + end if; + + Sin.Sin_Family := C.unsigned_short (Families (Address.Family)); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (Address.Port)); + + Res := C_Bind (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Bind_Socket; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : in out Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Duration := Forever) + is + Res : C.int; + Len : C.int; + RSet : aliased Fd_Set; + WSet : aliased Fd_Set; + TVal : aliased Timeval; + TPtr : Timeval_Access; + + begin + Status := Completed; + + -- No timeout or Forever is indicated by a null timeval pointer. + + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; + + -- Copy R_Socket_Set in RSet and add read signalling socket. + + if R_Socket_Set = null then + RSet := Null_Fd_Set; + else + RSet := Fd_Set (R_Socket_Set.all); + end if; + + Set (RSet, C.int (Selector.R_Sig_Socket)); + Len := Max (RSet) + 1; + + -- Copy W_Socket_Set in WSet. + + if W_Socket_Set = null then + WSet := Null_Fd_Set; + else + WSet := Fd_Set (W_Socket_Set.all); + end if; + Len := C.int'Max (Max (RSet) + 1, Len); + + Selector.In_Progress := True; + Res := + C_Select + (Len, + RSet'Unchecked_Access, + WSet'Unchecked_Access, + null, TPtr); + Selector.In_Progress := False; + + -- If Select was resumed because of read signalling socket, + -- read this data and remove socket from set. + + if Is_Set (RSet, C.int (Selector.R_Sig_Socket)) then + Clear (RSet, C.int (Selector.R_Sig_Socket)); + + declare + Buf : Character; + begin + Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0); + end; + + -- Select was resumed because of read signalling socket, but + -- the call is said aborted only when there is no other read + -- or write event. + + if Is_Empty (RSet) + and then Is_Empty (WSet) + then + Status := Aborted; + end if; + + elsif Res = 0 then + Status := Expired; + end if; + + if R_Socket_Set /= null then + R_Socket_Set.all := Socket_Set_Record (RSet); + end if; + + if W_Socket_Set /= null then + W_Socket_Set.all := Socket_Set_Record (WSet); + end if; + end Check_Selector; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Socket_Set_Type; + Socket : Socket_Type) + is + begin + if Item = null then + Item := new Socket_Set_Record; + Empty (Fd_Set (Item.all)); + end if; + + Clear (Fd_Set (Item.all), C.int (Socket)); + end Clear; + + -------------------- + -- Close_Selector -- + -------------------- + + procedure Close_Selector (Selector : in out Selector_Type) is + begin + begin + Close_Socket (Selector.R_Sig_Socket); + exception when Socket_Error => + null; + end; + + begin + Close_Socket (Selector.W_Sig_Socket); + exception when Socket_Error => + null; + end; + end Close_Selector; + + ------------------ + -- Close_Socket -- + ------------------ + + procedure Close_Socket (Socket : Socket_Type) is + Res : C.int; + + begin + Res := C_Close (C.int (Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Close_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : in out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + if Server.Family = Family_Inet6 then + raise Socket_Error; + end if; + + Sin.Sin_Family := C.unsigned_short (Families (Server.Family)); + Sin.Sin_Addr := To_In_Addr (Server.Addr); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (Server.Port)); + + Res := C_Connect (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Connect_Socket; + + -------------------- + -- Control_Socket -- + -------------------- + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type) + is + Arg : aliased C.int; + Res : C.int; + + begin + case Request.Name is + when Non_Blocking_IO => + Arg := C.int (Boolean'Pos (Request.Enabled)); + + when N_Bytes_To_Read => + null; + + end case; + + Res := C_Ioctl + (C.int (Socket), + Requests (Request.Name), + Arg'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Request.Name is + when Non_Blocking_IO => + null; + + when N_Bytes_To_Read => + Request.Size := Natural (Arg); + + end case; + end Control_Socket; + + --------------------- + -- Create_Selector -- + --------------------- + + procedure Create_Selector (Selector : out Selector_Type) is + S0 : C.int; + S1 : C.int; + S2 : C.int; + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Err : Integer; + + begin + -- We open two signalling sockets. One socket to send a signal + -- to a another socket that always included in a C_Select + -- socket set. When received, it resumes the task suspended in + -- C_Select. + + -- Create a listening socket + + S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); + if S0 = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + -- Sin is already correctly initialized. Bind the socket to any + -- unused port. + + Res := C_Bind (S0, Sin'Address, Len); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + -- Get the port used by the socket + + Res := C_Getsockname (S0, Sin'Address, Len'Access); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + Res := C_Listen (S0, 2); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); + if S1 = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + -- Use INADDR_LOOPBACK + + Sin.Sin_Addr.S_B1 := 127; + Sin.Sin_Addr.S_B2 := 0; + Sin.Sin_Addr.S_B3 := 0; + Sin.Sin_Addr.S_B4 := 1; + + -- Do a connect and accept the connection + + Res := C_Connect (S1, Sin'Address, Len); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Res := C_Close (S1); + Raise_Socket_Error (Err); + end if; + + S2 := C_Accept (S0, Sin'Address, Len'Access); + if S2 = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Res := C_Close (S1); + Raise_Socket_Error (Err); + end if; + + Res := C_Close (S0); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Selector.R_Sig_Socket := Socket_Type (S1); + Selector.W_Sig_Socket := Socket_Type (S2); + end Create_Selector; + + ------------------- + -- Create_Socket -- + ------------------- + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream) + is + Res : C.int; + + begin + Res := C_Socket (Families (Family), Modes (Mode), 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + end Create_Socket; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : in out Socket_Set_Type) is + begin + if Item /= null then + Free (Item); + end if; + end Empty; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if not Finalized + and then Initialized + then + Finalized := True; + Thin.Finalize; + end if; + end Finalize; + + ----------------- + -- Get_Address -- + ----------------- + + function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is + begin + if Stream = null then + raise Socket_Error; + + elsif Stream.all in Datagram_Socket_Stream_Type then + return Datagram_Socket_Stream_Type (Stream.all).From; + + else + return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); + end if; + end Get_Address; + + ------------------------- + -- Get_Host_By_Address -- + ------------------------- + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) + return Host_Entry_Type + is + HA : aliased In_Addr := To_In_Addr (Address); + Res : Hostent_Access; + Err : Integer; + + begin + -- This C function is not always thread-safe. Protect against + -- concurrent access. + + Task_Lock.Lock; + Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET); + + if Res = null then + Err := Socket_Errno; + Task_Lock.Unlock; + Raise_Host_Error (Err); + end if; + + -- Translate from the C format to the API format + + declare + HE : Host_Entry_Type := To_Host_Entry (Res.all); + + begin + Task_Lock.Unlock; + return HE; + end; + end Get_Host_By_Address; + + ---------------------- + -- Get_Host_By_Name -- + ---------------------- + + function Get_Host_By_Name + (Name : String) + return Host_Entry_Type + is + HN : C.char_array := C.To_C (Name); + Res : Hostent_Access; + Err : Integer; + + begin + -- This C function is not always thread-safe. Protect against + -- concurrent access. + + Task_Lock.Lock; + Res := C_Gethostbyname (HN); + + if Res = null then + Err := Socket_Errno; + Task_Lock.Unlock; + Raise_Host_Error (Err); + end if; + + -- Translate from the C format to the API format + + declare + HE : Host_Entry_Type := To_Host_Entry (Res.all); + + begin + Task_Lock.Unlock; + return HE; + end; + end Get_Host_By_Name; + + ------------------- + -- Get_Peer_Name -- + ------------------- + + function Get_Peer_Name + (Socket : Socket_Type) + return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Res.Addr := To_Inet_Addr (Sin.Sin_Addr); + Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + + return Res; + end Get_Peer_Name; + + --------------------- + -- Get_Socket_Name -- + --------------------- + + function Get_Socket_Name + (Socket : Socket_Type) + return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Res.Addr := To_Inet_Addr (Sin.Sin_Addr); + Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + + return Res; + end Get_Socket_Name; + + ----------------------- + -- Get_Socket_Option -- + ----------------------- + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name) + return Option_Type + is + use type C.unsigned_char; + + V8 : aliased Two_Int; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + Len : aliased C.int; + Add : System.Address; + Res : C.int; + Opt : Option_Type (Name); + + begin + case Name is + when Multicast_Loop | + Multicast_TTL => + Len := V1'Size / 8; + Add := V1'Address; + + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay | + Send_Buffer | + Receive_Buffer | + Error => + Len := V4'Size / 8; + Add := V4'Address; + + when Linger | + Add_Membership | + Drop_Membership => + Len := V8'Size / 8; + Add := V8'Address; + + end case; + + Res := C_Getsockopt + (C.int (Socket), + Levels (Level), + Options (Name), + Add, Len'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + Opt.Enabled := (V4 /= 0); + + when Linger => + Opt.Enabled := (V8 (V8'First) /= 0); + Opt.Seconds := Natural (V8 (V8'Last)); + + when Send_Buffer | + Receive_Buffer => + Opt.Size := Natural (V4); + + when Error => + Opt.Error := Resolve_Error (Integer (V4)); + + when Add_Membership | + Drop_Membership => + Opt.Multiaddr := To_Inet_Addr (To_In_Addr (V8 (V8'First))); + Opt.Interface := To_Inet_Addr (To_In_Addr (V8 (V8'Last))); + + when Multicast_TTL => + Opt.Time_To_Live := Integer (V1); + + when Multicast_Loop => + Opt.Enabled := (V1 /= 0); + + end case; + + return Opt; + end Get_Socket_Option; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String is + Name : aliased C.char_array (1 .. 64); + Res : C.int; + + begin + Res := C_Gethostname (Name'Address, Name'Length); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + return C.To_Ada (Name); + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) + return String + is + -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It + -- has at most a length of 3 plus one '.' character. + + Buffer : String (1 .. 4 * Val'Length); + Length : Natural := 1; + Separator : Character; + + procedure Img10 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in decimal format + + procedure Img16 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in hexadecimal format + + procedure Img10 (V : Inet_Addr_Comp_Type) is + Img : constant String := V'Img; + Len : Natural := Img'Length - 1; + + begin + Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); + Length := Length + Len; + end Img10; + + procedure Img16 (V : Inet_Addr_Comp_Type) is + begin + Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); + Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); + Length := Length + 2; + end Img16; + + -- Start of processing for Image + + begin + if Hex then + Separator := ':'; + else + Separator := '.'; + end if; + + for J in Val'Range loop + if Hex then + Img16 (Val (J)); + else + Img10 (Val (J)); + end if; + + if J /= Val'Last then + Buffer (Length) := Separator; + Length := Length + 1; + end if; + end loop; + + return Buffer (1 .. Length - 1); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Inet_Addr_Type) return String is + begin + if Value.Family = Family_Inet then + return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + else + return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Sock_Addr_Type) return String is + Port : constant String := Value.Port'Img; + + begin + return Image (Value.Addr) & ':' & Port (2 .. Port'Last); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Socket : Socket_Type) return String is + begin + return Socket'Img; + end Image; + + --------------- + -- Inet_Addr -- + --------------- + + function Inet_Addr (Image : String) return Inet_Addr_Type is + use Interfaces.C.Strings; + + Img : chars_ptr := New_String (Image); + Res : C.int; + Err : Integer; + + begin + Res := C_Inet_Addr (Img); + Err := Errno; + Free (Img); + + if Res = Failure then + Raise_Socket_Error (Err); + end if; + + return To_Inet_Addr (To_In_Addr (Res)); + end Inet_Addr; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean := False) is + begin + if not Initialized then + Initialized := True; + Thin.Initialize (Process_Blocking_IO); + end if; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Socket_Set_Type) return Boolean is + begin + return Item = null or else Is_Empty (Fd_Set (Item.all)); + end Is_Empty; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean + is + begin + return Item /= null + and then Is_Set (Fd_Set (Item.all), C.int (Socket)); + end Is_Set; + + ------------------- + -- Listen_Socket -- + ------------------- + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Positive := 15) + is + Res : C.int; + + begin + Res := C_Listen (C.int (Socket), C.int (Length)); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Listen_Socket; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (E : Host_Entry_Type) return String is + begin + return To_String (E.Official); + end Official_Name; + + --------------------- + -- Port_To_Network -- + --------------------- + + function Port_To_Network + (Port : C.unsigned_short) + return C.unsigned_short + is + use type C.unsigned_short; + begin + if Default_Bit_Order = High_Order_First then + + -- No conversion needed. On these platforms, htons() defaults + -- to a null procedure. + + return Port; + + else + -- We need to swap the high and low byte on this short to make + -- the port number network compliant. + + return (Port / 256) + (Port mod 256) * 256; + end if; + end Port_To_Network; + + ---------------------- + -- Raise_Host_Error -- + ---------------------- + + procedure Raise_Host_Error (Error : Integer) is + + function Error_Message return String; + -- We do not use a C function like strerror because hstrerror + -- that would correspond seems to be obsolete. Return + -- appropriate string for error value. + + function Error_Message return String is + begin + case Error is + when Constants.HOST_NOT_FOUND => return "Host not found"; + when Constants.TRY_AGAIN => return "Try again"; + when Constants.NO_RECOVERY => return "No recovery"; + when Constants.NO_ADDRESS => return "No address"; + when others => return "Unknown error"; + end case; + end Error_Message; + + -- Start of processing for Raise_Host_Error + + begin + Ada.Exceptions.Raise_Exception (Host_Error'Identity, Error_Message); + end Raise_Host_Error; + + ------------------------ + -- Raise_Socket_Error -- + ------------------------ + + procedure Raise_Socket_Error (Error : Integer) is + use type C.Strings.chars_ptr; + + function Image (E : Integer) return String; + function Image (E : Integer) return String is + Msg : String := E'Img & "] "; + begin + Msg (Msg'First) := '['; + return Msg; + end Image; + + begin + Ada.Exceptions.Raise_Exception + (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error)); + end Raise_Socket_Error; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket + (Stream.Socket, + Item (First .. Max), + Index, + Stream.From); + + Last := Index; + + -- Exit when all or zero data received. Zero means that + -- the socket peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket (Stream.Socket, Item (First .. Max), Index); + Last := Index; + + -- Exit when all or zero data received. Zero means that + -- the socket peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + ------------------- + -- Resolve_Error -- + ------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) + return Error_Type + is + use GNAT.Sockets.Constants; + + begin + if not From_Errno then + case Error_Value is + when HOST_NOT_FOUND => return Unknown_Host; + when TRY_AGAIN => return Host_Name_Lookup_Failure; + when NO_RECOVERY => return No_Address_Associated_With_Name; + when NO_ADDRESS => return Unknown_Server_Error; + when others => return Cannot_Resolve_Error; + end case; + end if; + case Error_Value is + when EACCES => return Permission_Denied; + when EADDRINUSE => return Address_Already_In_Use; + when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address; + when EAFNOSUPPORT => + return Address_Family_Not_Supported_By_Protocol; + when EALREADY => return Operation_Already_In_Progress; + when EBADF => return Bad_File_Descriptor; + when ECONNREFUSED => return Connection_Refused; + when EFAULT => return Bad_Address; + when EINPROGRESS => return Operation_Now_In_Progress; + when EINTR => return Interrupted_System_Call; + when EINVAL => return Invalid_Argument; + when EIO => return Input_Output_Error; + when EISCONN => return Transport_Endpoint_Already_Connected; + when EMSGSIZE => return Message_Too_Long; + when ENETUNREACH => return Network_Is_Unreachable; + when ENOBUFS => return No_Buffer_Space_Available; + when ENOPROTOOPT => return Protocol_Not_Available; + when ENOTCONN => return Transport_Endpoint_Not_Connected; + when EOPNOTSUPP => return Operation_Not_Supported; + when EPROTONOSUPPORT => return Protocol_Not_Supported; + when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported; + when ETIMEDOUT => return Connection_Timed_Out; + when EWOULDBLOCK => return Resource_Temporarily_Unavailable; + when others => return Cannot_Resolve_Error; + end case; + end Resolve_Error; + + ----------------------- + -- Resolve_Exception -- + ----------------------- + + function Resolve_Exception + (Occurrence : Exception_Occurrence) + return Error_Type + is + Id : Exception_Id := Exception_Identity (Occurrence); + Msg : constant String := Exception_Message (Occurrence); + First : Natural := Msg'First; + Last : Natural; + Val : Integer; + + begin + while First <= Msg'Last + and then Msg (First) not in '0' .. '9' + loop + First := First + 1; + end loop; + + if First > Msg'Last then + return Cannot_Resolve_Error; + end if; + + Last := First; + + while Last < Msg'Last + and then Msg (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + + Val := Integer'Value (Msg (First .. Last)); + + if Id = Socket_Error_Id then + return Resolve_Error (Val); + + elsif Id = Host_Error_Id then + return Resolve_Error (Val, False); + + else + return Cannot_Resolve_Error; + end if; + end Resolve_Exception; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + + begin + Res := C_Recv + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Receive_Socket; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Recvfrom + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0, + Sin'Unchecked_Access, + Len'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + + From.Addr := To_Inet_Addr (Sin.Sin_Addr); + From.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + end Receive_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + + begin + Res := C_Send + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Sin.Sin_Family := C.unsigned_short (Families (To.Family)); + Sin.Sin_Addr := To_In_Addr (To.Addr); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (To.Port)); + + Res := C_Sendto + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0, + Sin'Unchecked_Access, + Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Send_Socket; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is + begin + if Item = null then + Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set)); + end if; + + Set (Fd_Set (Item.all), C.int (Socket)); + end Set; + + ----------------------- + -- Set_Socket_Option -- + ----------------------- + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type) + is + V8 : aliased Two_Int; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + Len : aliased C.int; + Add : System.Address := Null_Address; + Res : C.int; + + begin + case Option.Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + V4 := C.int (Boolean'Pos (Option.Enabled)); + Len := V4'Size / 8; + Add := V4'Address; + + when Linger => + V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); + V8 (V8'Last) := C.int (Option.Seconds); + Len := V8'Size / 8; + Add := V8'Address; + + when Send_Buffer | + Receive_Buffer => + V4 := C.int (Option.Size); + Len := V4'Size / 8; + Add := V4'Address; + + when Error => + V4 := C.int (Boolean'Pos (True)); + Len := V4'Size / 8; + Add := V4'Address; + + when Add_Membership | + Drop_Membership => + V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr)); + V8 (V8'Last) := To_Int (To_In_Addr (Option.Interface)); + Len := V8'Size / 8; + Add := V8'Address; + + when Multicast_TTL => + V1 := C.unsigned_char (Option.Time_To_Live); + Len := V1'Size / 8; + Add := V1'Address; + + when Multicast_Loop => + V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); + Len := V1'Size / 8; + Add := V1'Address; + + end case; + + Res := C_Setsockopt + (C.int (Socket), + Levels (Level), + Options (Option.Name), + Add, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Set_Socket_Option; + + --------------------- + -- Shutdown_Socket -- + --------------------- + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write) + is + Res : C.int; + + begin + Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Shutdown_Socket; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) + return Stream_Access + is + S : Datagram_Socket_Stream_Access; + + begin + S := new Datagram_Socket_Stream_Type; + S.Socket := Socket; + S.To := Send_To; + S.From := Get_Socket_Name (Socket); + return Stream_Access (S); + end Stream; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type) + return Stream_Access + is + S : Stream_Socket_Stream_Access; + + begin + S := new Stream_Socket_Stream_Type; + S.Socket := Socket; + return Stream_Access (S); + end Stream; + + ---------- + -- To_C -- + ---------- + + function To_C (Socket : Socket_Type) return Integer is + begin + return Integer (Socket); + end To_C; + + ------------------- + -- To_Host_Entry -- + ------------------- + + function To_Host_Entry + (Host : Hostent) + return Host_Entry_Type + is + use type C.size_t; + + Official : constant String := + C.Strings.Value (Host.H_Name); + + Aliases : constant Chars_Ptr_Array := + Chars_Ptr_Pointers.Value (Host.H_Aliases); + -- H_Aliases points to a list of name aliases. The list is + -- terminated by a NULL pointer. + + Addresses : constant In_Addr_Access_Array := + In_Addr_Access_Pointers.Value (Host.H_Addr_List); + -- H_Addr_List points to a list of binary addresses (in network + -- byte order). The list is terminated by a NULL pointer. + + -- H_Length is not used because it is currently only set to 4. + -- H_Addrtype is always AF_INET + + Result : Host_Entry_Type + (Aliases_Length => Aliases'Length - 1, + Addresses_Length => Addresses'Length - 1); + -- The last element is a null pointer. + + Source : C.size_t; + Target : Natural; + + begin + Result.Official := To_Host_Name (Official); + + Source := Aliases'First; + Target := Result.Aliases'First; + while Target <= Result.Aliases_Length loop + Result.Aliases (Target) := + To_Host_Name (C.Strings.Value (Aliases (Source))); + Source := Source + 1; + Target := Target + 1; + end loop; + + Source := Addresses'First; + Target := Result.Addresses'First; + while Target <= Result.Addresses_Length loop + Result.Addresses (Target) := + To_Inet_Addr (Addresses (Source).all); + Source := Source + 1; + Target := Target + 1; + end loop; + + return Result; + end To_Host_Entry; + + ------------------ + -- To_Host_Name -- + ------------------ + + function To_Host_Name (N : String) return Host_Name_Type is + begin + return (N'Length, N); + end To_Host_Name; + + ---------------- + -- To_In_Addr -- + ---------------- + + function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is + begin + if Addr.Family = Family_Inet then + return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), + S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), + S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), + S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); + end if; + + raise Socket_Error; + end To_In_Addr; + + ------------------ + -- To_Inet_Addr -- + ------------------ + + function To_Inet_Addr + (Addr : In_Addr) + return Inet_Addr_Type + is + Result : Inet_Addr_Type; + + begin + Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); + Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); + Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); + Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); + + return Result; + end To_Inet_Addr; + + --------------- + -- To_String -- + --------------- + + function To_String (HN : Host_Name_Type) return String is + begin + return HN.Name (1 .. HN.Length); + end To_String; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (Val : Duration) return Timeval is + S : Timeval_Unit := Timeval_Unit (Val); + MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S))); + + begin + return (S, MS); + end To_Timeval; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Send_Socket + (Stream.Socket, + Item (First .. Max), + Index, + Stream.To); + + -- Exit when all or zero data sent. Zero means that the + -- socket has been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + if Index /= Max then + raise Socket_Error; + end if; + end Write; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Send_Socket (Stream.Socket, Item (First .. Max), Index); + + -- Exit when all or zero data sent. Zero means that the + -- socket has been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + if Index /= Max then + raise Socket_Error; + end if; + end Write; + +end GNAT.Sockets; |