← Back to branch summary

~ubuntu-branches/ubuntu/precise/a2ps/precise-security

« back to all changes in this revision

Viewing changes to tests/tstfiles/s-garnam.adb

  • Committer: Bazaar Package Importer
  • Author(s): Martin Schulze
  • Date: 2004-12-10 08:26:05 UTC
  • Revision ID: james.westby@ubuntu.com-20041210082605-rha33nklyielibe4
Tags: upstream-4.13b
Import upstream version 4.13b

Show diffs side-by-side

added added

removed removed

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