gcc/ada/g-sttsne-locking.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --    G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2007, AdaCore                          --
  10 --                                                                          --
  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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  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.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with GNAT.Task_Lock;
  35
  36 with Interfaces.C; use Interfaces.C;
  37
  38 package body GNAT.Sockets.Thin.Task_Safe_NetDB is
  39
  40    procedure Copy_Host_Entry
  41      (Source_Hostent       : Hostent;
  42       Target_Hostent       : out Hostent;
  43       Target_Buffer        : System.Address;
  44       Target_Buffer_Length : C.int;
  45       Result               : out C.int);
  46    --  Copy all the information from Source_Hostent into Target_Hostent,
  47    --  using Target_Buffer to store associated data.
  48    --  0 is returned on success, -1 on failure (in case the provided buffer
  49    --  is too small for the associated data).
  50
  51    procedure Copy_Service_Entry
  52      (Source_Servent       : Servent;
  53       Target_Servent       : out Servent;
  54       Target_Buffer        : System.Address;
  55       Target_Buffer_Length : C.int;
  56       Result               : out C.int);
  57    --  Copy all the information from Source_Servent into Target_Servent,
  58    --  using Target_Buffer to store associated data.
  59    --  0 is returned on success, -1 on failure (in case the provided buffer
  60    --  is too small for the associated data).
  61
  62    procedure Store_Name
  63      (Name          : char_array;
  64       Storage       : in out char_array;
  65       Storage_Index : in out size_t;
  66       Stored_Name   : out C.Strings.chars_ptr);
  67    --  Store the given Name at the first available location in Storage
  68    --  (indicated by Storage_Index, which is updated afterwards), and return
  69    --  the address of that location in Stored_Name.
  70    --  (Supporting routine for the two below).
  71
  72    ---------------------
  73    -- Copy_Host_Entry --
  74    ---------------------
  75
  76    procedure Copy_Host_Entry
  77      (Source_Hostent       : Hostent;
  78       Target_Hostent       : out Hostent;
  79       Target_Buffer        : System.Address;
  80       Target_Buffer_Length : C.int;
  81       Result               : out C.int)
  82    is
  83       use type C.Strings.chars_ptr;
  84
  85       Names_Length : size_t;
  86
  87       Source_Aliases : Chars_Ptr_Array
  88         renames Chars_Ptr_Pointers.Value
  89           (Source_Hostent.H_Aliases, Terminator => C.Strings.Null_Ptr);
  90       --  Null-terminated list of aliases (last element of this array is
  91       --  Null_Ptr).
  92
  93       Source_Addresses : In_Addr_Access_Array
  94         renames In_Addr_Access_Pointers.Value
  95           (Source_Hostent.H_Addr_List, Terminator => null);
  96
  97    begin
  98       Result := -1;
  99       Names_Length := C.Strings.Strlen (Source_Hostent.H_Name) + 1;
 100
 101       for J in Source_Aliases'Range loop
 102          if Source_Aliases (J) /= C.Strings.Null_Ptr then
 103             Names_Length :=
 104               Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1;
 105          end if;
 106       end loop;
 107
 108       declare
 109          type In_Addr_Array is array (Source_Addresses'Range)
 110                                  of aliased In_Addr;
 111
 112          type Netdb_Host_Data is record
 113             Aliases_List   : aliased Chars_Ptr_Array (Source_Aliases'Range);
 114             Names          : aliased char_array (1 .. Names_Length);
 115
 116             Addresses_List : aliased In_Addr_Access_Array
 117                                        (In_Addr_Array'Range);
 118             Addresses : In_Addr_Array;
 119             --  ??? This assumes support only for Inet family
 120
 121          end record;
 122
 123          Netdb_Data : Netdb_Host_Data;
 124          pragma Import (Ada, Netdb_Data);
 125          for Netdb_Data'Address use Target_Buffer;
 126
 127          Names_Index : size_t := Netdb_Data.Names'First;
 128          --  Index of first available location in Netdb_Data.Names
 129
 130       begin
 131          if Netdb_Data'Size / 8 > Target_Buffer_Length then
 132             return;
 133          end if;
 134
 135          --  Copy host name
 136
 137          Store_Name
 138            (C.Strings.Value (Source_Hostent.H_Name),
 139             Netdb_Data.Names, Names_Index,
 140             Target_Hostent.H_Name);
 141
 142          --  Copy aliases (null-terminated string pointer array)
 143
 144          Target_Hostent.H_Aliases :=
 145            Netdb_Data.Aliases_List
 146              (Netdb_Data.Aliases_List'First)'Unchecked_Access;
 147          for J in Netdb_Data.Aliases_List'Range loop
 148             if J = Netdb_Data.Aliases_List'Last then
 149                Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr;
 150             else
 151                Store_Name
 152                  (C.Strings.Value (Source_Aliases (J)),
 153                   Netdb_Data.Names, Names_Index,
 154                   Netdb_Data.Aliases_List (J));
 155             end if;
 156          end loop;
 157
 158          --  Copy address type and length
 159
 160          Target_Hostent.H_Addrtype := Source_Hostent.H_Addrtype;
 161          Target_Hostent.H_Length   := Source_Hostent.H_Length;
 162
 163          --  Copy addresses
 164
 165          Target_Hostent.H_Addr_List :=
 166            Netdb_Data.Addresses_List
 167              (Netdb_Data.Addresses_List'First)'Unchecked_Access;
 168
 169          for J in Netdb_Data.Addresses'Range loop
 170             if J = Netdb_Data.Addresses'Last then
 171                Netdb_Data.Addresses_List (J) := null;
 172             else
 173                Netdb_Data.Addresses_List (J) :=
 174                  Netdb_Data.Addresses (J)'Unchecked_Access;
 175
 176                Netdb_Data.Addresses (J) := Source_Addresses (J).all;
 177             end if;
 178          end loop;
 179       end;
 180
 181       Result := 0;
 182    end Copy_Host_Entry;
 183
 184    ------------------------
 185    -- Copy_Service_Entry --
 186    ------------------------
 187
 188    procedure Copy_Service_Entry
 189      (Source_Servent       : Servent;
 190       Target_Servent       : out Servent;
 191       Target_Buffer        : System.Address;
 192       Target_Buffer_Length : C.int;
 193       Result               : out C.int)
 194    is
 195       use type C.Strings.chars_ptr;
 196
 197       Names_Length : size_t;
 198
 199       Source_Aliases : Chars_Ptr_Array
 200         renames Chars_Ptr_Pointers.Value
 201           (Source_Servent.S_Aliases, Terminator => C.Strings.Null_Ptr);
 202       --  Null-terminated list of aliases (last element of this array is
 203       --  Null_Ptr).
 204
 205    begin
 206       Result := -1;
 207       Names_Length := C.Strings.Strlen (Source_Servent.S_Name) + 1
 208                     + C.Strings.Strlen (Source_Servent.S_Proto) + 1;
 209
 210       for J in Source_Aliases'Range loop
 211          if Source_Aliases (J) /= C.Strings.Null_Ptr then
 212             Names_Length :=
 213               Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1;
 214          end if;
 215       end loop;
 216
 217       declare
 218          type Netdb_Service_Data is record
 219             Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range);
 220             Names        : aliased char_array (1 .. Names_Length);
 221          end record;
 222
 223          Netdb_Data : Netdb_Service_Data;
 224          pragma Import (Ada, Netdb_Data);
 225          for Netdb_Data'Address use Target_Buffer;
 226
 227          Names_Index : size_t := Netdb_Data.Names'First;
 228          --  Index of first available location in Netdb_Data.Names
 229
 230       begin
 231          if Netdb_Data'Size / 8 > Target_Buffer_Length then
 232             return;
 233          end if;
 234
 235          --  Copy service name
 236
 237          Store_Name
 238            (C.Strings.Value (Source_Servent.S_Name),
 239             Netdb_Data.Names, Names_Index,
 240             Target_Servent.S_Name);
 241
 242          --  Copy aliases (null-terminated string pointer array)
 243
 244          Target_Servent.S_Aliases :=
 245            Netdb_Data.Aliases_List
 246              (Netdb_Data.Aliases_List'First)'Unchecked_Access;
 247
 248          --  Copy port number
 249
 250          Target_Servent.S_Port := Source_Servent.S_Port;
 251
 252          --  Copy protocol name
 253
 254          Store_Name
 255            (C.Strings.Value (Source_Servent.S_Proto),
 256             Netdb_Data.Names, Names_Index,
 257             Target_Servent.S_Proto);
 258
 259          for J in Netdb_Data.Aliases_List'Range loop
 260             if J = Netdb_Data.Aliases_List'Last then
 261                Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr;
 262             else
 263                Store_Name
 264                  (C.Strings.Value (Source_Aliases (J)),
 265                   Netdb_Data.Names, Names_Index,
 266                   Netdb_Data.Aliases_List (J));
 267             end if;
 268          end loop;
 269       end;
 270
 271       Result := 0;
 272    end Copy_Service_Entry;
 273
 274    ------------------------
 275    -- Safe_Gethostbyaddr --
 276    ------------------------
 277
 278    function Safe_Gethostbyaddr
 279      (Addr      : System.Address;
 280       Addr_Len  : C.int;
 281       Addr_Type : C.int;
 282       Ret      : not null access Hostent;
 283       Buf      : System.Address;
 284       Buflen   : C.int;
 285       H_Errnop : not null access C.int) return C.int
 286    is
 287       HE     : Hostent_Access;
 288       Result : C.int;
 289    begin
 290       Result := -1;
 291       GNAT.Task_Lock.Lock;
 292       HE := Nonreentrant_Gethostbyaddr (Addr, Addr_Len, Addr_Type);
 293
 294       if HE = null then
 295          H_Errnop.all := C.int (Host_Errno);
 296          goto Unlock_Return;
 297       end if;
 298
 299       --  Now copy the data to the user-provided buffer
 300
 301       Copy_Host_Entry
 302         (Source_Hostent       => HE.all,
 303          Target_Hostent       => Ret.all,
 304          Target_Buffer        => Buf,
 305          Target_Buffer_Length => Buflen,
 306          Result               => Result);
 307
 308       <<Unlock_Return>>
 309       GNAT.Task_Lock.Unlock;
 310       return Result;
 311    end Safe_Gethostbyaddr;
 312
 313    ------------------------
 314    -- Safe_Gethostbyname --
 315    ------------------------
 316
 317    function Safe_Gethostbyname
 318      (Name     : C.char_array;
 319       Ret      : not null access Hostent;
 320       Buf      : System.Address;
 321       Buflen   : C.int;
 322       H_Errnop : not null access C.int) return C.int
 323    is
 324       HE     : Hostent_Access;
 325       Result : C.int;
 326    begin
 327       Result := -1;
 328       GNAT.Task_Lock.Lock;
 329       HE := Nonreentrant_Gethostbyname (Name);
 330
 331       if HE = null then
 332          H_Errnop.all := C.int (Host_Errno);
 333          goto Unlock_Return;
 334       end if;
 335
 336       --  Now copy the data to the user-provided buffer
 337
 338       Copy_Host_Entry
 339         (Source_Hostent       => HE.all,
 340          Target_Hostent       => Ret.all,
 341          Target_Buffer        => Buf,
 342          Target_Buffer_Length => Buflen,
 343          Result               => Result);
 344
 345       <<Unlock_Return>>
 346       GNAT.Task_Lock.Unlock;
 347       return Result;
 348    end Safe_Gethostbyname;
 349
 350    ------------------------
 351    -- Safe_Getservbyname --
 352    ------------------------
 353
 354    function Safe_Getservbyname
 355      (Name     : C.char_array;
 356       Proto    : C.char_array;
 357       Ret      : not null access Servent;
 358       Buf      : System.Address;
 359       Buflen   : C.int) return C.int
 360    is
 361       SE     : Servent_Access;
 362       Result : C.int;
 363    begin
 364       Result := -1;
 365       GNAT.Task_Lock.Lock;
 366       SE := Nonreentrant_Getservbyname (Name, Proto);
 367
 368       if SE = null then
 369          goto Unlock_Return;
 370       end if;
 371
 372       --  Now copy the data to the user-provided buffer
 373
 374       Copy_Service_Entry
 375         (Source_Servent       => SE.all,
 376          Target_Servent       => Ret.all,
 377          Target_Buffer        => Buf,
 378          Target_Buffer_Length => Buflen,
 379          Result               => Result);
 380
 381       <<Unlock_Return>>
 382       GNAT.Task_Lock.Unlock;
 383       return Result;
 384    end Safe_Getservbyname;
 385
 386    ------------------------
 387    -- Safe_Getservbyport --
 388    ------------------------
 389
 390    function Safe_Getservbyport
 391      (Port     : C.int;
 392       Proto    : C.char_array;
 393       Ret      : not null access Servent;
 394       Buf      : System.Address;
 395       Buflen   : C.int) return C.int
 396    is
 397       SE     : Servent_Access;
 398       Result : C.int;
 399
 400    begin
 401       Result := -1;
 402       GNAT.Task_Lock.Lock;
 403       SE := Nonreentrant_Getservbyport (Port, Proto);
 404
 405       if SE = null then
 406          goto Unlock_Return;
 407       end if;
 408
 409       --  Now copy the data to the user-provided buffer
 410
 411       Copy_Service_Entry
 412         (Source_Servent       => SE.all,
 413          Target_Servent       => Ret.all,
 414          Target_Buffer        => Buf,
 415          Target_Buffer_Length => Buflen,
 416          Result               => Result);
 417
 418       <<Unlock_Return>>
 419       GNAT.Task_Lock.Unlock;
 420       return Result;
 421    end Safe_Getservbyport;
 422
 423    ----------------
 424    -- Store_Name --
 425    ----------------
 426
 427    procedure Store_Name
 428      (Name          : char_array;
 429       Storage       : in out char_array;
 430       Storage_Index : in out size_t;
 431       Stored_Name   : out C.Strings.chars_ptr)
 432    is
 433       First : constant C.size_t := Storage_Index;
 434       Last  : constant C.size_t := Storage_Index + Name'Length - 1;
 435    begin
 436       Storage (First .. Last) := Name;
 437       Stored_Name := C.Strings.To_Chars_Ptr
 438                        (Storage (First .. Last)'Unrestricted_Access);
 439       Storage_Index := Last + 1;
 440    end Store_Name;
 441
 442 end GNAT.Sockets.Thin.Task_Safe_NetDB;