gcc/ada/libgnat/a-envvar.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . E N V I R O N M E N T _ V A R I A B L E S           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 2009-2017, Free Software Foundation, Inc.          --
  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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.CRTL;
  33 with Interfaces.C.Strings;
  34 with Ada.Unchecked_Deallocation;
  35
  36 package body Ada.Environment_Variables is
  37
  38    -----------
  39    -- Clear --
  40    -----------
  41
  42    procedure Clear (Name : String) is
  43       procedure Clear_Env_Var (Name : System.Address);
  44       pragma Import (C, Clear_Env_Var, "__gnat_unsetenv");
  45
  46       F_Name  : String (1 .. Name'Length + 1);
  47
  48    begin
  49       F_Name (1 .. Name'Length) := Name;
  50       F_Name (F_Name'Last)      := ASCII.NUL;
  51
  52       Clear_Env_Var (F_Name'Address);
  53    end Clear;
  54
  55    -----------
  56    -- Clear --
  57    -----------
  58
  59    procedure Clear is
  60       procedure Clear_Env;
  61       pragma Import (C, Clear_Env, "__gnat_clearenv");
  62    begin
  63       Clear_Env;
  64    end Clear;
  65
  66    ------------
  67    -- Exists --
  68    ------------
  69
  70    function Exists (Name : String) return Boolean is
  71       use System;
  72
  73       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
  74       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
  75
  76       Env_Value_Ptr    : aliased Address;
  77       Env_Value_Length : aliased Integer;
  78       F_Name           : aliased String (1 .. Name'Length + 1);
  79
  80    begin
  81       F_Name (1 .. Name'Length) := Name;
  82       F_Name (F_Name'Last)      := ASCII.NUL;
  83
  84       Get_Env_Value_Ptr
  85         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
  86
  87       if Env_Value_Ptr = System.Null_Address then
  88          return False;
  89       end if;
  90
  91       return True;
  92    end Exists;
  93
  94    -------------
  95    -- Iterate --
  96    -------------
  97
  98    procedure Iterate
  99      (Process : not null access procedure (Name, Value : String))
 100    is
 101       use Interfaces.C.Strings;
 102       type C_String_Array is array (Natural) of aliased chars_ptr;
 103       type C_String_Array_Access is access C_String_Array;
 104
 105       function Get_Env return C_String_Array_Access;
 106       pragma Import (C, Get_Env, "__gnat_environ");
 107
 108       type String_Access is access all String;
 109       procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
 110
 111       Env_Length : Natural := 0;
 112       Env        : constant C_String_Array_Access := Get_Env;
 113
 114    begin
 115       --  If the environment is null return directly
 116
 117       if Env = null then
 118          return;
 119       end if;
 120
 121       --  First get the number of environment variables
 122
 123       loop
 124          exit when Env (Env_Length) = Null_Ptr;
 125          Env_Length := Env_Length + 1;
 126       end loop;
 127
 128       declare
 129          Env_Copy : array (1 .. Env_Length) of String_Access;
 130
 131       begin
 132          --  Copy the environment
 133
 134          for Iterator in 1 ..  Env_Length loop
 135             Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1)));
 136          end loop;
 137
 138          --  Iterate on the environment copy
 139
 140          for Iterator in 1 .. Env_Length loop
 141             declare
 142                Current_Var : constant String := Env_Copy (Iterator).all;
 143                Value_Index : Natural := Env_Copy (Iterator)'First;
 144
 145             begin
 146                loop
 147                   exit when Current_Var (Value_Index) = '=';
 148                   Value_Index := Value_Index + 1;
 149                end loop;
 150
 151                Process
 152                  (Current_Var (Current_Var'First .. Value_Index - 1),
 153                   Current_Var (Value_Index + 1 .. Current_Var'Last));
 154             end;
 155          end loop;
 156
 157          --  Free the copy of the environment
 158
 159          for Iterator in 1 .. Env_Length loop
 160             Free (Env_Copy (Iterator));
 161          end loop;
 162       end;
 163    end Iterate;
 164
 165    ---------
 166    -- Set --
 167    ---------
 168
 169    procedure Set (Name : String; Value : String) is
 170       F_Name  : String (1 .. Name'Length + 1);
 171       F_Value : String (1 .. Value'Length + 1);
 172
 173       procedure Set_Env_Value (Name, Value : System.Address);
 174       pragma Import (C, Set_Env_Value, "__gnat_setenv");
 175
 176    begin
 177       F_Name (1 .. Name'Length) := Name;
 178       F_Name (F_Name'Last)      := ASCII.NUL;
 179
 180       F_Value (1 .. Value'Length) := Value;
 181       F_Value (F_Value'Last)      := ASCII.NUL;
 182
 183       Set_Env_Value (F_Name'Address, F_Value'Address);
 184    end Set;
 185
 186    -----------
 187    -- Value --
 188    -----------
 189
 190    function Value (Name : String) return String is
 191       use System, System.CRTL;
 192
 193       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
 194       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 195
 196       Env_Value_Ptr    : aliased Address;
 197       Env_Value_Length : aliased Integer;
 198       F_Name           : aliased String (1 .. Name'Length + 1);
 199
 200    begin
 201       F_Name (1 .. Name'Length) := Name;
 202       F_Name (F_Name'Last)      := ASCII.NUL;
 203
 204       Get_Env_Value_Ptr
 205         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 206
 207       if Env_Value_Ptr = System.Null_Address then
 208          raise Constraint_Error;
 209       end if;
 210
 211       if Env_Value_Length > 0 then
 212          declare
 213             Result : aliased String (1 .. Env_Value_Length);
 214          begin
 215             strncpy (Result'Address, Env_Value_Ptr, size_t (Env_Value_Length));
 216             return Result;
 217          end;
 218       else
 219          return "";
 220       end if;
 221    end Value;
 222
 223    function Value (Name : String; Default : String) return String is
 224    begin
 225       return (if Exists (Name) then Value (Name) else Default);
 226    end Value;
 227
 228 end Ada.Environment_Variables;