]>
Commit | Line | Data |
---|---|---|
ffabcde5 MH |
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 | -- -- | |
748086b7 | 9 | -- Copyright (C) 2009, Free Software Foundation, Inc. -- |
ffabcde5 MH |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
ffabcde5 MH |
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 -- | |
748086b7 JJ |
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/>. -- | |
ffabcde5 MH |
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; | |
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; | |
192 | ||
193 | procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); | |
194 | pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); | |
195 | ||
196 | procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); | |
197 | pragma Import (C, Strncpy, "strncpy"); | |
198 | ||
199 | Env_Value_Ptr : aliased Address; | |
200 | Env_Value_Length : aliased Integer; | |
201 | F_Name : aliased String (1 .. Name'Length + 1); | |
202 | ||
203 | begin | |
204 | F_Name (1 .. Name'Length) := Name; | |
205 | F_Name (F_Name'Last) := ASCII.NUL; | |
206 | ||
207 | Get_Env_Value_Ptr | |
208 | (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); | |
209 | ||
210 | if Env_Value_Ptr = System.Null_Address then | |
211 | raise Constraint_Error; | |
212 | end if; | |
213 | ||
214 | if Env_Value_Length > 0 then | |
215 | declare | |
216 | Result : aliased String (1 .. Env_Value_Length); | |
217 | begin | |
218 | Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length); | |
219 | return Result; | |
220 | end; | |
221 | else | |
222 | return ""; | |
223 | end if; | |
224 | end Value; | |
225 | ||
226 | end Ada.Environment_Variables; |