Dead
[official-gcc.git] / gomp-20050608-branch / gcc / ada / a-envvar.adb
blob586451b974ec9aed0a46a08ae658961ef0624c1d
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) 2005, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with System;
35 with Interfaces.C.Strings;
36 with Ada.Unchecked_Deallocation;
38 package body Ada.Environment_Variables is
40 -----------
41 -- Clear --
42 -----------
44 procedure Clear (Name : String) is
45 procedure Clear_Env_Var (Name : System.Address);
46 pragma Import (C, Clear_Env_Var, "__gnat_unsetenv");
48 F_Name : String (1 .. Name'Length + 1);
50 begin
51 F_Name (1 .. Name'Length) := Name;
52 F_Name (F_Name'Last) := ASCII.NUL;
54 Clear_Env_Var (F_Name'Address);
55 end Clear;
57 -----------
58 -- Clear --
59 -----------
61 procedure Clear is
62 procedure Clear_Env;
63 pragma Import (C, Clear_Env, "__gnat_clearenv");
64 begin
65 Clear_Env;
66 end Clear;
68 ------------
69 -- Exists --
70 ------------
72 function Exists (Name : String) return Boolean is
73 use System;
75 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
76 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
78 Env_Value_Ptr : aliased Address;
79 Env_Value_Length : aliased Integer;
80 F_Name : aliased String (1 .. Name'Length + 1);
82 begin
83 F_Name (1 .. Name'Length) := Name;
84 F_Name (F_Name'Last) := ASCII.NUL;
86 Get_Env_Value_Ptr
87 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
89 if Env_Value_Ptr = System.Null_Address then
90 return False;
91 end if;
93 return True;
94 end Exists;
96 -------------
97 -- Iterate --
98 -------------
100 procedure Iterate
101 (Process : not null access procedure (Name, Value : String))
103 use Interfaces.C.Strings;
104 type C_String_Array is array (Natural) of aliased chars_ptr;
105 type C_String_Array_Access is access C_String_Array;
107 function Get_Env return C_String_Array_Access;
108 pragma Import (C, Get_Env, "__gnat_environ");
110 type String_Access is access all String;
111 procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
113 Env_Length : Natural := 0;
114 Env : constant C_String_Array_Access := Get_Env;
116 begin
117 -- If the environment is null return directly
119 if Env = null then
120 return;
121 end if;
123 -- First get the number of environment variables
125 loop
126 exit when Env (Env_Length) = Null_Ptr;
127 Env_Length := Env_Length + 1;
128 end loop;
130 declare
131 Env_Copy : array (1 .. Env_Length) of String_Access;
133 begin
134 -- Copy the environment
136 for Iterator in 1 .. Env_Length loop
137 Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1)));
138 end loop;
140 -- Iterate on the environment copy
142 for Iterator in 1 .. Env_Length loop
143 declare
144 Current_Var : constant String := Env_Copy (Iterator).all;
145 Value_Index : Natural := Env_Copy (Iterator)'First;
147 begin
148 loop
149 exit when Current_Var (Value_Index) = '=';
150 Value_Index := Value_Index + 1;
151 end loop;
153 Process
154 (Current_Var (Current_Var'First .. Value_Index - 1),
155 Current_Var (Value_Index + 1 .. Current_Var'Last));
156 end;
157 end loop;
159 -- Free the copy of the environment
161 for Iterator in 1 .. Env_Length loop
162 Free (Env_Copy (Iterator));
163 end loop;
164 end;
165 end Iterate;
167 ---------
168 -- Set --
169 ---------
171 procedure Set (Name : String; Value : String) is
172 F_Name : String (1 .. Name'Length + 1);
173 F_Value : String (1 .. Value'Length + 1);
175 procedure Set_Env_Value (Name, Value : System.Address);
176 pragma Import (C, Set_Env_Value, "__gnat_setenv");
178 begin
179 F_Name (1 .. Name'Length) := Name;
180 F_Name (F_Name'Last) := ASCII.NUL;
182 F_Value (1 .. Value'Length) := Value;
183 F_Value (F_Value'Last) := ASCII.NUL;
185 Set_Env_Value (F_Name'Address, F_Value'Address);
186 end Set;
188 -----------
189 -- Value --
190 -----------
192 function Value (Name : String) return String is
193 use System;
195 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
196 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
198 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
199 pragma Import (C, Strncpy, "strncpy");
201 Env_Value_Ptr : aliased Address;
202 Env_Value_Length : aliased Integer;
203 F_Name : aliased String (1 .. Name'Length + 1);
205 begin
206 F_Name (1 .. Name'Length) := Name;
207 F_Name (F_Name'Last) := ASCII.NUL;
209 Get_Env_Value_Ptr
210 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
212 if Env_Value_Ptr = System.Null_Address then
213 raise Constraint_Error;
214 end if;
216 if Env_Value_Length > 0 then
217 declare
218 Result : aliased String (1 .. Env_Value_Length);
219 begin
220 Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length);
221 return Result;
222 end;
223 else
224 return "";
225 end if;
226 end Value;
228 end Ada.Environment_Variables;