Context Navigation

source: rtems/c/src/lib/libbsp/i386/ts_386ex/tools/network_ada/adasockets/sockets-naming.adb @ 2490f92

Last change on this file since 2490f92 was 1d4048b2, checked in by Joel Sherrill <joel.sherrill@…>, on 08/11/99 at 23:45:57

Patch from Tony R. Ambardar <tonya@…>:

I'm attaching a big patch for the ts_386ex BSP which adds and includes
the following:

1) Conversion to ELF format + minor code cleanups + documentation.

2) An Ada95 binding to FreeBSD sockets, based on Samuel Tardieu's

adasockets-0.1.3 package. This includes some sample applications.

3) Some Ada and C interfaces to add serial-port debugging to

programs. Comes with examples, too; the Ada one shows how
transparent adding the support can be. Note that Rosimildo sent me
the original C code.

The network stuff is not BSP specific, and could be added to your Ada
code collection. The debugging stuff is specific to the i386. Right
now, everything sits in my "tools" directory.

Property mode set to 100644

File size: 12.4 KB

Line
1	-----------------------------------------------------------------------------
2	-- --
3	-- ADASOCKETS COMPONENTS --
4	-- --
5	-- S O C K E T S . N A M I N G --
6	-- --
7	-- B o d y --
8	-- --
9	-- $ReleaseVersion: 0.1.3 $ --
10	-- --
11	-- Copyright (C) 1996-1998 Free Software Foundation --
12	-- --
13	-- AdaSockets is free software; you can redistribute it and/or modify --
14	-- it under terms of the GNU General Public License as published by --
15	-- the Free Software Foundation; either version 2, or (at your option) --
16	-- any later version. AdaSockets is distributed in the hope that it --
17	-- will be useful, but WITHOUT ANY WARRANTY; without even the implied --
18	-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
19	-- See the GNU General Public License for more details. You should --
20	-- have received a copy of the GNU General Public License distributed --
21	-- with AdaSockets; see file COPYING. If not, write to the Free --
22	-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --
23	-- 02111-1307, USA. --
24	-- --
25	-- As a special exception, if other files instantiate generics from --
26	-- this unit, or you link this unit with other files to produce an --
27	-- executable, this unit does not by itself cause the resulting --
28	-- executable to be covered by the GNU General Public License. This --
29	-- exception does not however invalidate any other reasons why the --
30	-- executable file might be covered by the GNU Public License. --
31	-- --
32	-- The main repository for this software is located at: --
33	-- http://www-inf.enst.fr/ANC/ --
34	-- --
35	-----------------------------------------------------------------------------
36
37	with Ada.Exceptions;
38	with Interfaces.C; use Interfaces.C;
39	with Interfaces.C.Strings; use Interfaces.C.Strings;
40	with Sockets.Constants; use Sockets.Constants;
41	with Ada.Unchecked_Conversion;
42	with Ada.Unchecked_Deallocation;
43
44	package body Sockets.Naming is
45
46	use Sockets.Constants, Sockets.Thin;
47
48	Default_Buffer_Size : constant := 16384;
49
50	procedure Free is
51	new Ada.Unchecked_Deallocation (String, String_Access);
52
53	procedure Free is
54	new Ada.Unchecked_Deallocation (char_array, char_array_access);
55
56	function Allocate (Size : Positive := Default_Buffer_Size)
57	return char_array_access;
58	-- Allocate a buffer
59
60	function Parse_Entry (Host : Hostent)
61	return Host_Entry;
62	-- Parse an entry
63
64	procedure Raise_Naming_Error
65	(Errno : in C.int;
66	Message : in String);
67	-- Raise the exception Naming_Error with an appropriate error message
68
69	C_Errno : C.int;
70	pragma Import (C, C_Errno, "h_errno");
71
72	----------------
73	-- Address_Of --
74	----------------
75
76	function Address_Of (Something : String)
77	return Address
78	is
79	begin
80	if Is_IP_Address (Something) then
81	return Value (Something);
82	else
83	return Info_Of (Something) .Addresses (1);
84	end if;
85	end Address_Of;
86
87	------------
88	-- Adjust --
89	------------
90
91	procedure Adjust (Object : in out Host_Entry)
92	is
93	Aliases : String_Array renames Object.Aliases;
94	begin
95	Object.Name := new String'(Object.Name.all);
96	for I in Aliases'Range loop
97	Aliases (I) := new String'(Aliases (I) .all);
98	end loop;
99	end Adjust;
100
101	--------------
102	-- Allocate --
103	--------------
104
105	function Allocate
106	(Size : Positive := Default_Buffer_Size)
107	return char_array_access
108	is
109	begin
110	return new char_array (1 .. size_t (Size));
111	end Allocate;
112
113	-----------------
114	-- Any_Address --
115	-----------------
116
117	function Any_Address return Address
118	is
119	begin
120	return To_Address (Inaddr_Any);
121	end Any_Address;
122
123	--------------
124	-- Finalize --
125	--------------
126
127	procedure Finalize (Object : in out Host_Entry)
128	is
129	Aliases : String_Array renames Object.Aliases;
130	begin
131	Free (Object.Name);
132	for I in Aliases'Range loop
133	Free (Aliases (I));
134	end loop;
135	end Finalize;
136
137	---------------
138	-- Host_Name --
139	---------------
140
141	function Host_Name return String
142	is
143	Buff : char_array_access := Allocate;
144	Buffer : constant chars_ptr := To_Chars_Ptr (Buff);
145	Res : constant int := C_Gethostname (Buffer, Buff'Length);
146	begin
147	if Res = Failure then
148	Free (Buff);
149	Raise_Naming_Error (C_Errno, "");
150	end if;
151	declare
152	Result : constant String := Value (Buffer);
153	begin
154	Free (Buff);
155	return Result;
156	end;
157	end Host_Name;
158
159	-----------
160	-- Image --
161	-----------
162
163	function Image (Add : Address) return String
164	is
165
166	function Image (A : Address_Component) return String;
167	-- Return the string corresponding to its argument without
168	-- the leading space.
169
170	-----------
171	-- Image --
172	-----------
173
174	function Image (A : Address_Component)
175	return String
176	is
177	Im : constant String := Address_Component'Image (A);
178	begin
179	return Im (Im'First + 1 .. Im'Last);
180	end Image;
181
182	begin
183	return Image (Add.H1) & "." & Image (Add.H2) & "." &
184	Image (Add.H3) & "." & Image (Add.H4);
185	end Image;
186
187	-----------
188	-- Image --
189	-----------
190
191	function Image (Add : Thin.In_Addr) return String is
192	begin
193	return Image (To_Address (Add));
194	end Image;
195
196	-------------
197	-- Info_Of --
198	-------------
199
200	function Info_Of (Name : String)
201	return Host_Entry
202	is
203	Res : Hostent_Access;
204	C_Name : chars_ptr := New_String (Name);
205	begin
206	Res := C_Gethostbyname (C_Name);
207	Free (C_Name);
208	if Res = null then
209	Raise_Naming_Error (C_Errno, Name);
210	end if;
211	declare
212	Result : constant Host_Entry := Parse_Entry (Res.all);
213	begin
214	return Result;
215	end;
216	end Info_Of;
217
218	-------------
219	-- Info_Of --
220	-------------
221
222	function Info_Of (Addr : Address)
223	return Host_Entry
224	is
225	function Convert is
226	new Ada.Unchecked_Conversion (Source => In_Addr_Access,
227	Target => chars_ptr);
228	Temp : aliased In_Addr := To_In_Addr (Addr);
229	C_Addr : constant chars_ptr := Convert (Temp'Unchecked_Access);
230	Res : Hostent_Access;
231	begin
232	Res := C_Gethostbyaddr (C_Addr,
233	C.int (Temp'Size / CHAR_BIT),
234	Constants.Af_Inet);
235	if Res = null then
236	Raise_Naming_Error (C_Errno, Image (Addr));
237	end if;
238	declare
239	Result : constant Host_Entry := Parse_Entry (Res.all);
240	begin
241	return Result;
242	end;
243	end Info_Of;
244
245	------------------------
246	-- Info_Of_Name_Or_IP --
247	------------------------
248
249	function Info_Of_Name_Or_IP (Something : String)
250	return Host_Entry
251	is
252	begin
253	if Is_IP_Address (Something) then
254	return Info_Of (Value (Something));
255	else
256	return Info_Of (Something);
257	end if;
258	end Info_Of_Name_Or_IP;
259
260	-------------------
261	-- Is_Ip_Address --
262	-------------------
263
264	function Is_IP_Address (Something : String)
265	return Boolean
266	is
267	begin
268	for Index in Something'Range loop
269	declare
270	Current : Character renames Something (Index);
271	begin
272	if (Current < '0'
273	or else Current > '9')
274	and then Current /= '.' then
275	return False;
276	end if;
277	end;
278	end loop;
279	return True;
280	end Is_IP_Address;
281
282	-------------
283	-- Name_Of --
284	-------------
285
286	function Name_Of (Something : String)
287	return String
288	is
289	Hostent : constant Host_Entry := Info_Of_Name_Or_IP (Something);
290	begin
291	if Hostent.Name = null then
292	Ada.Exceptions.Raise_Exception (Naming_Error'Identity,
293	"No name for " & Something);
294	end if;
295	return Hostent.Name.all;
296	end Name_Of;
297
298	-----------------
299	-- Parse_Entry --
300	-----------------
301
302	function Parse_Entry (Host : Hostent)
303	return Host_Entry
304	is
305	C_Aliases : constant Thin.Chars_Ptr_Array :=
306	Chars_Ptr_Pointers.Value (Host.H_Aliases);
307	C_Addr : constant In_Addr_Access_Array :=
308	In_Addr_Access_Pointers.Value
309	(Host.H_Addr_List);
310	Result : Host_Entry (N_Aliases => C_Aliases'Length - 1,
311	N_Addresses => C_Addr'Length - 1);
312	begin
313	Result.Name := new String'(Value (Host.H_Name));
314	for I in 1 .. Result.Aliases'Last loop
315	declare
316	Index : Natural := I - 1 + Natural (C_Aliases'First);
317	Current : chars_ptr renames C_Aliases (size_t (Index));
318	begin
319	Result.Aliases (I) := new String'(Value (Current));
320	end;
321	end loop;
322	for I in Result.Addresses'Range loop
323	declare
324	Index : Natural := I - 1 + Natural (C_Addr'First);
325	Current : In_Addr_Access renames C_Addr (Index);
326	begin
327	Result.Addresses (I) := To_Address (Current.all);
328	end;
329	end loop;
330	return Result;
331	end Parse_Entry;
332
333	------------------------
334	-- Raise_Naming_Error --
335	------------------------
336
337	procedure Raise_Naming_Error
338	(Errno : in C.int;
339	Message : in String)
340	is
341
342	function Error_Message return String;
343	-- Return the message according to Errno.
344
345	-------------------
346	-- Error_Message --
347	-------------------
348
349	function Error_Message return String is
350	begin
351	case Errno is
352	when Host_Not_Found => return "Host not found";
353	when Try_Again => return "Try again";
354	when No_Recovery => return "No recovery";
355	when No_Address => return "No address";
356	when others => return "Unknown error" &
357	C.int'Image (Errno);
358	end case;
359	end Error_Message;
360
361	begin
362	Ada.Exceptions.Raise_Exception (Naming_Error'Identity,
363	Error_Message & ": " & Message);
364	end Raise_Naming_Error;
365
366	----------------
367	-- To_Address --
368	----------------
369
370	function To_Address (Addr : In_Addr) return Address
371	is
372	begin
373	return (H1 => Address_Component (Addr.S_B1),
374	H2 => Address_Component (Addr.S_B2),
375	H3 => Address_Component (Addr.S_B3),
376	H4 => Address_Component (Addr.S_B4));
377	end To_Address;
378
379	----------------
380	-- To_In_Addr --
381	----------------
382
383	function To_In_Addr (Addr : Address) return In_Addr
384	is
385	begin
386	return (S_B1 => unsigned_char (Addr.H1),
387	S_B2 => unsigned_char (Addr.H2),
388	S_B3 => unsigned_char (Addr.H3),
389	S_B4 => unsigned_char (Addr.H4));
390	end To_In_Addr;
391
392	-----------
393	-- Value --
394	-----------
395
396	function Value (Add : String) return Address
397	is
398	function Convert is
399	new Ada.Unchecked_Conversion (Source => Interfaces.Unsigned_32,
400	Target => In_Addr);
401	C_Add : chars_ptr := New_String (Add);
402	Converted : constant In_Addr := Convert (C_Inet_Addr (C_Add));
403	begin
404	Free (C_Add);
405	return (H1 => Address_Component (Converted.S_B1),
406	H2 => Address_Component (Converted.S_B2),
407	H3 => Address_Component (Converted.S_B3),
408	H4 => Address_Component (Converted.S_B4));
409	end Value;
410
411	end Sockets.Naming;

Note: See TracBrowser for help on using the repository browser.

Download in other formats: