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-2018, 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 32with System.CRTL; 33with Interfaces.C.Strings; 34with Ada.Unchecked_Deallocation; 35 36package 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 228end Ada.Environment_Variables; 229