|
111
|
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 -- --
|
|
145
|
9 -- Copyright (C) 2009-2019, Free Software Foundation, Inc. --
|
|
111
|
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;
|
