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