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-2009, 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_Access;
  61       Target_Servent       : Servent_Access;
  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_Access;
 198       Target_Servent       : Servent_Access;
 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           (Servent_S_Aliases (Source_Servent),
 210            Terminator => C.Strings.Null_Ptr);
 211       --  Null-terminated list of aliases (last element of this array is
 212       --  Null_Ptr).
 213
 214    begin
 215       Result := -1;
 216       Names_Length := C.Strings.Strlen (Servent_S_Name (Source_Servent)) + 1 +
 217                       C.Strings.Strlen (Servent_S_Proto (Source_Servent)) + 1;
 218
 219       for J in Source_Aliases'Range loop
 220          if Source_Aliases (J) /= C.Strings.Null_Ptr then
 221             Names_Length :=
 222               Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1;
 223          end if;
 224       end loop;
 225
 226       declare
 227          type Netdb_Service_Data is record
 228             Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range);
 229             Names        : aliased char_array (1 .. Names_Length);
 230          end record;
 231
 232          Netdb_Data : Netdb_Service_Data;
 233          pragma Import (Ada, Netdb_Data);
 234          for Netdb_Data'Address use Target_Buffer;
 235
 236          Names_Index : size_t := Netdb_Data.Names'First;
 237          --  Index of first available location in Netdb_Data.Names
 238
 239          Stored_Name : C.Strings.chars_ptr;
 240
 241       begin
 242          if Netdb_Data'Size / 8 > Target_Buffer_Length then
 243             return;
 244          end if;
 245
 246          --  Copy service name
 247
 248          Store_Name
 249            (C.Strings.Value (Servent_S_Name (Source_Servent)),
 250             Netdb_Data.Names, Names_Index,
 251             Stored_Name);
 252          Servent_Set_S_Name (Target_Servent, Stored_Name);
 253
 254          --  Copy aliases (null-terminated string pointer array)
 255
 256          Servent_Set_S_Aliases
 257            (Target_Servent,
 258             Netdb_Data.Aliases_List
 259               (Netdb_Data.Aliases_List'First)'Unchecked_Access);
 260
 261          --  Copy port number
 262
 263          Servent_Set_S_Port (Target_Servent, Servent_S_Port (Source_Servent));
 264
 265          --  Copy protocol name
 266
 267          Store_Name
 268            (C.Strings.Value (Servent_S_Proto (Source_Servent)),
 269             Netdb_Data.Names, Names_Index,
 270             Stored_Name);
 271          Servent_Set_S_Proto (Target_Servent, Stored_Name);
 272
 273          for J in Netdb_Data.Aliases_List'Range loop
 274             if J = Netdb_Data.Aliases_List'Last then
 275                Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr;
 276             else
 277                Store_Name
 278                  (C.Strings.Value (Source_Aliases (J)),
 279                   Netdb_Data.Names, Names_Index,
 280                   Netdb_Data.Aliases_List (J));
 281             end if;
 282          end loop;
 283       end;
 284
 285       Result := 0;
 286    end Copy_Service_Entry;
 287
 288    ------------------------
 289    -- Safe_Gethostbyaddr --
 290    ------------------------
 291
 292    function Safe_Gethostbyaddr
 293      (Addr      : System.Address;
 294       Addr_Len  : C.int;
 295       Addr_Type : C.int;
 296       Ret      : not null access Hostent;
 297       Buf      : System.Address;
 298       Buflen   : C.int;
 299       H_Errnop : not null access C.int) return C.int
 300    is
 301       HE     : Hostent_Access;
 302       Result : C.int;
 303    begin
 304       Result := -1;
 305       GNAT.Task_Lock.Lock;
 306       HE := Nonreentrant_Gethostbyaddr (Addr, Addr_Len, Addr_Type);
 307
 308       if HE = null then
 309          H_Errnop.all := C.int (Host_Errno);
 310          goto Unlock_Return;
 311       end if;
 312
 313       --  Now copy the data to the user-provided buffer
 314
 315       Copy_Host_Entry
 316         (Source_Hostent       => HE.all,
 317          Target_Hostent       => Ret.all,
 318          Target_Buffer        => Buf,
 319          Target_Buffer_Length => Buflen,
 320          Result               => Result);
 321
 322       <<Unlock_Return>>
 323       GNAT.Task_Lock.Unlock;
 324       return Result;
 325    end Safe_Gethostbyaddr;
 326
 327    ------------------------
 328    -- Safe_Gethostbyname --
 329    ------------------------
 330
 331    function Safe_Gethostbyname
 332      (Name     : C.char_array;
 333       Ret      : not null access Hostent;
 334       Buf      : System.Address;
 335       Buflen   : C.int;
 336       H_Errnop : not null access C.int) return C.int
 337    is
 338       HE     : Hostent_Access;
 339       Result : C.int;
 340    begin
 341       Result := -1;
 342       GNAT.Task_Lock.Lock;
 343       HE := Nonreentrant_Gethostbyname (Name);
 344
 345       if HE = null then
 346          H_Errnop.all := C.int (Host_Errno);
 347          goto Unlock_Return;
 348       end if;
 349
 350       --  Now copy the data to the user-provided buffer
 351
 352       Copy_Host_Entry
 353         (Source_Hostent       => HE.all,
 354          Target_Hostent       => Ret.all,
 355          Target_Buffer        => Buf,
 356          Target_Buffer_Length => Buflen,
 357          Result               => Result);
 358
 359       <<Unlock_Return>>
 360       GNAT.Task_Lock.Unlock;
 361       return Result;
 362    end Safe_Gethostbyname;
 363
 364    ------------------------
 365    -- Safe_Getservbyname --
 366    ------------------------
 367
 368    function Safe_Getservbyname
 369      (Name     : C.char_array;
 370       Proto    : C.char_array;
 371       Ret      : not null access Servent;
 372       Buf      : System.Address;
 373       Buflen   : C.int) return C.int
 374    is
 375       SE     : Servent_Access;
 376       Result : C.int;
 377    begin
 378       Result := -1;
 379       GNAT.Task_Lock.Lock;
 380       SE := Nonreentrant_Getservbyname (Name, Proto);
 381
 382       if SE = null then
 383          goto Unlock_Return;
 384       end if;
 385
 386       --  Now copy the data to the user-provided buffer. We convert Ret to
 387       --  type Servent_Access using the .all'Unchecked_Access trick to avoid
 388       --  an accessibility check. Ret could be pointing to a nested variable,
 389       --  and we don't want to raise an exception in that case.
 390
 391       Copy_Service_Entry
 392         (Source_Servent       => SE,
 393          Target_Servent       => Ret.all'Unchecked_Access,
 394          Target_Buffer        => Buf,
 395          Target_Buffer_Length => Buflen,
 396          Result               => Result);
 397
 398       <<Unlock_Return>>
 399       GNAT.Task_Lock.Unlock;
 400       return Result;
 401    end Safe_Getservbyname;
 402
 403    ------------------------
 404    -- Safe_Getservbyport --
 405    ------------------------
 406
 407    function Safe_Getservbyport
 408      (Port     : C.int;
 409       Proto    : C.char_array;
 410       Ret      : not null access Servent;
 411       Buf      : System.Address;
 412       Buflen   : C.int) return C.int
 413    is
 414       SE     : Servent_Access;
 415       Result : C.int;
 416
 417    begin
 418       Result := -1;
 419       GNAT.Task_Lock.Lock;
 420       SE := Nonreentrant_Getservbyport (Port, Proto);
 421
 422       if SE = null then
 423          goto Unlock_Return;
 424       end if;
 425
 426       --  Now copy the data to the user-provided buffer. See Safe_Getservbyname
 427       --  for comment regarding .all'Unchecked_Access.
 428
 429       Copy_Service_Entry
 430         (Source_Servent       => SE,
 431          Target_Servent       => Ret.all'Unchecked_Access,
 432          Target_Buffer        => Buf,
 433          Target_Buffer_Length => Buflen,
 434          Result               => Result);
 435
 436       <<Unlock_Return>>
 437       GNAT.Task_Lock.Unlock;
 438       return Result;
 439    end Safe_Getservbyport;
 440
 441    ----------------
 442    -- Store_Name --
 443    ----------------
 444
 445    procedure Store_Name
 446      (Name          : char_array;
 447       Storage       : in out char_array;
 448       Storage_Index : in out size_t;
 449       Stored_Name   : out C.Strings.chars_ptr)
 450    is
 451       First : constant C.size_t := Storage_Index;
 452       Last  : constant C.size_t := Storage_Index + Name'Length - 1;
 453    begin
 454       Storage (First .. Last) := Name;
 455       Stored_Name := C.Strings.To_Chars_Ptr
 456                        (Storage (First .. Last)'Unrestricted_Access);
 457       Storage_Index := Last + 1;
 458    end Store_Name;
 459
 460 end GNAT.Sockets.Thin.Task_Safe_NetDB;