diff options
Diffstat (limited to '')
| -rw-r--r-- | c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets-naming.adb | 411 |
1 files changed, 411 insertions, 0 deletions
diff --git a/c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets-naming.adb b/c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets-naming.adb new file mode 100644 index 0000000000..4faa989138 --- /dev/null +++ b/c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets-naming.adb @@ -0,0 +1,411 @@ +----------------------------------------------------------------------------- +-- -- +-- ADASOCKETS COMPONENTS -- +-- -- +-- S O C K E T S . N A M I N G -- +-- -- +-- B o d y -- +-- -- +-- $ReleaseVersion: 0.1.3 $ -- +-- -- +-- Copyright (C) 1996-1998 Free Software Foundation -- +-- -- +-- AdaSockets is free software; you can redistribute it and/or modify -- +-- it under terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 2, or (at your option) -- +-- any later version. AdaSockets is distributed in the hope that it -- +-- will be useful, but WITHOUT 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 AdaSockets; 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. -- +-- -- +-- The main repository for this software is located at: -- +-- http://www-inf.enst.fr/ANC/ -- +-- -- +----------------------------------------------------------------------------- + +with Ada.Exceptions; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Sockets.Constants; use Sockets.Constants; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body Sockets.Naming is + + use Sockets.Constants, Sockets.Thin; + + Default_Buffer_Size : constant := 16384; + + procedure Free is + new Ada.Unchecked_Deallocation (String, String_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (char_array, char_array_access); + + function Allocate (Size : Positive := Default_Buffer_Size) + return char_array_access; + -- Allocate a buffer + + function Parse_Entry (Host : Hostent) + return Host_Entry; + -- Parse an entry + + procedure Raise_Naming_Error + (Errno : in C.int; + Message : in String); + -- Raise the exception Naming_Error with an appropriate error message + + C_Errno : C.int; + pragma Import (C, C_Errno, "h_errno"); + + ---------------- + -- Address_Of -- + ---------------- + + function Address_Of (Something : String) + return Address + is + begin + if Is_IP_Address (Something) then + return Value (Something); + else + return Info_Of (Something) .Addresses (1); + end if; + end Address_Of; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Host_Entry) + is + Aliases : String_Array renames Object.Aliases; + begin + Object.Name := new String'(Object.Name.all); + for I in Aliases'Range loop + Aliases (I) := new String'(Aliases (I) .all); + end loop; + end Adjust; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Size : Positive := Default_Buffer_Size) + return char_array_access + is + begin + return new char_array (1 .. size_t (Size)); + end Allocate; + + ----------------- + -- Any_Address -- + ----------------- + + function Any_Address return Address + is + begin + return To_Address (Inaddr_Any); + end Any_Address; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Host_Entry) + is + Aliases : String_Array renames Object.Aliases; + begin + Free (Object.Name); + for I in Aliases'Range loop + Free (Aliases (I)); + end loop; + end Finalize; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String + is + Buff : char_array_access := Allocate; + Buffer : constant chars_ptr := To_Chars_Ptr (Buff); + Res : constant int := C_Gethostname (Buffer, Buff'Length); + begin + if Res = Failure then + Free (Buff); + Raise_Naming_Error (C_Errno, ""); + end if; + declare + Result : constant String := Value (Buffer); + begin + Free (Buff); + return Result; + end; + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image (Add : Address) return String + is + + function Image (A : Address_Component) return String; + -- Return the string corresponding to its argument without + -- the leading space. + + ----------- + -- Image -- + ----------- + + function Image (A : Address_Component) + return String + is + Im : constant String := Address_Component'Image (A); + begin + return Im (Im'First + 1 .. Im'Last); + end Image; + + begin + return Image (Add.H1) & "." & Image (Add.H2) & "." & + Image (Add.H3) & "." & Image (Add.H4); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Add : Thin.In_Addr) return String is + begin + return Image (To_Address (Add)); + end Image; + + ------------- + -- Info_Of -- + ------------- + + function Info_Of (Name : String) + return Host_Entry + is + Res : Hostent_Access; + C_Name : chars_ptr := New_String (Name); + begin + Res := C_Gethostbyname (C_Name); + Free (C_Name); + if Res = null then + Raise_Naming_Error (C_Errno, Name); + end if; + declare + Result : constant Host_Entry := Parse_Entry (Res.all); + begin + return Result; + end; + end Info_Of; + + ------------- + -- Info_Of -- + ------------- + + function Info_Of (Addr : Address) + return Host_Entry + is + function Convert is + new Ada.Unchecked_Conversion (Source => In_Addr_Access, + Target => chars_ptr); + Temp : aliased In_Addr := To_In_Addr (Addr); + C_Addr : constant chars_ptr := Convert (Temp'Unchecked_Access); + Res : Hostent_Access; + begin + Res := C_Gethostbyaddr (C_Addr, + C.int (Temp'Size / CHAR_BIT), + Constants.Af_Inet); + if Res = null then + Raise_Naming_Error (C_Errno, Image (Addr)); + end if; + declare + Result : constant Host_Entry := Parse_Entry (Res.all); + begin + return Result; + end; + end Info_Of; + + ------------------------ + -- Info_Of_Name_Or_IP -- + ------------------------ + + function Info_Of_Name_Or_IP (Something : String) + return Host_Entry + is + begin + if Is_IP_Address (Something) then + return Info_Of (Value (Something)); + else + return Info_Of (Something); + end if; + end Info_Of_Name_Or_IP; + + ------------------- + -- Is_Ip_Address -- + ------------------- + + function Is_IP_Address (Something : String) + return Boolean + is + begin + for Index in Something'Range loop + declare + Current : Character renames Something (Index); + begin + if (Current < '0' + or else Current > '9') + and then Current /= '.' then + return False; + end if; + end; + end loop; + return True; + end Is_IP_Address; + + ------------- + -- Name_Of -- + ------------- + + function Name_Of (Something : String) + return String + is + Hostent : constant Host_Entry := Info_Of_Name_Or_IP (Something); + begin + if Hostent.Name = null then + Ada.Exceptions.Raise_Exception (Naming_Error'Identity, + "No name for " & Something); + end if; + return Hostent.Name.all; + end Name_Of; + + ----------------- + -- Parse_Entry -- + ----------------- + + function Parse_Entry (Host : Hostent) + return Host_Entry + is + C_Aliases : constant Thin.Chars_Ptr_Array := + Chars_Ptr_Pointers.Value (Host.H_Aliases); + C_Addr : constant In_Addr_Access_Array := + In_Addr_Access_Pointers.Value + (Host.H_Addr_List); + Result : Host_Entry (N_Aliases => C_Aliases'Length - 1, + N_Addresses => C_Addr'Length - 1); + begin + Result.Name := new String'(Value (Host.H_Name)); + for I in 1 .. Result.Aliases'Last loop + declare + Index : Natural := I - 1 + Natural (C_Aliases'First); + Current : chars_ptr renames C_Aliases (size_t (Index)); + begin + Result.Aliases (I) := new String'(Value (Current)); + end; + end loop; + for I in Result.Addresses'Range loop + declare + Index : Natural := I - 1 + Natural (C_Addr'First); + Current : In_Addr_Access renames C_Addr (Index); + begin + Result.Addresses (I) := To_Address (Current.all); + end; + end loop; + return Result; + end Parse_Entry; + + ------------------------ + -- Raise_Naming_Error -- + ------------------------ + + procedure Raise_Naming_Error + (Errno : in C.int; + Message : in String) + is + + function Error_Message return String; + -- Return the message according to Errno. + + ------------------- + -- Error_Message -- + ------------------- + + function Error_Message return String is + begin + case Errno is + when Host_Not_Found => return "Host not found"; + when Try_Again => return "Try again"; + when No_Recovery => return "No recovery"; + when No_Address => return "No address"; + when others => return "Unknown error" & + C.int'Image (Errno); + end case; + end Error_Message; + + begin + Ada.Exceptions.Raise_Exception (Naming_Error'Identity, + Error_Message & ": " & Message); + end Raise_Naming_Error; + + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Addr : In_Addr) return Address + is + begin + return (H1 => Address_Component (Addr.S_B1), + H2 => Address_Component (Addr.S_B2), + H3 => Address_Component (Addr.S_B3), + H4 => Address_Component (Addr.S_B4)); + end To_Address; + + ---------------- + -- To_In_Addr -- + ---------------- + + function To_In_Addr (Addr : Address) return In_Addr + is + begin + return (S_B1 => unsigned_char (Addr.H1), + S_B2 => unsigned_char (Addr.H2), + S_B3 => unsigned_char (Addr.H3), + S_B4 => unsigned_char (Addr.H4)); + end To_In_Addr; + + ----------- + -- Value -- + ----------- + + function Value (Add : String) return Address + is + function Convert is + new Ada.Unchecked_Conversion (Source => Interfaces.Unsigned_32, + Target => In_Addr); + C_Add : chars_ptr := New_String (Add); + Converted : constant In_Addr := Convert (C_Inet_Addr (C_Add)); + begin + Free (C_Add); + return (H1 => Address_Component (Converted.S_B1), + H2 => Address_Component (Converted.S_B2), + H3 => Address_Component (Converted.S_B3), + H4 => Address_Component (Converted.S_B4)); + end Value; + +end Sockets.Naming; |