File : 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-2013, 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 -- --
19 -- --
20 -- --
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;