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-- 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.CRTL;
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, 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
228end Ada.Environment_Variables;
229