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-2012, 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;
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;
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
226end Ada.Environment_Variables;
227