Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--              A D A . E N V I R O N M E N T _ V A R I A B L E S           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2009, Free Software Foundation, Inc.            --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with System;
with Interfaces.C.Strings;
with Ada.Unchecked_Deallocation;
 
package body Ada.Environment_Variables is
 
   -----------
   -- Clear --
   -----------
 
   procedure Clear (Name : String) is
      procedure Clear_Env_Var (Name : System.Address);
      pragma Import (C, Clear_Env_Var, "__gnat_unsetenv");
 
      F_Name  : String (1 .. Name'Length + 1);
 
   begin
      F_Name (1 .. Name'Length) := Name;
      F_Name (F_Name'Last)      := ASCII.NUL;
 
      Clear_Env_Var (F_Name'Address);
   end Clear;
 
   -----------
   -- Clear --
   -----------
 
   procedure Clear is
      procedure Clear_Env;
      pragma Import (C, Clear_Env, "__gnat_clearenv");
   begin
      Clear_Env;
   end Clear;
 
   ------------
   -- Exists --
   ------------
 
   function Exists (Name : String) return Boolean is
      use System;
 
      procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
      pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 
      Env_Value_Ptr    : aliased Address;
      Env_Value_Length : aliased Integer;
      F_Name           : aliased String (1 .. Name'Length + 1);
 
   begin
      F_Name (1 .. Name'Length) := Name;
      F_Name (F_Name'Last)      := ASCII.NUL;
 
      Get_Env_Value_Ptr
        (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 
      if Env_Value_Ptr = System.Null_Address then
         return False;
      end if;
 
      return True;
   end Exists;
 
   -------------
   -- Iterate --
   -------------
 
   procedure Iterate
     (Process : not null access procedure (Name, Value : String))
   is
      use Interfaces.C.Strings;
      type C_String_Array is array (Natural) of aliased chars_ptr;
      type C_String_Array_Access is access C_String_Array;
 
      function Get_Env return C_String_Array_Access;
      pragma Import (C, Get_Env, "__gnat_environ");
 
      type String_Access is access all String;
      procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
 
      Env_Length : Natural := 0;
      Env        : constant C_String_Array_Access := Get_Env;
 
   begin
      --  If the environment is null return directly
 
      if Env = null then
         return;
      end if;
 
      --  First get the number of environment variables
 
      loop
         exit when Env (Env_Length) = Null_Ptr;
         Env_Length := Env_Length + 1;
      end loop;
 
      declare
         Env_Copy : array (1 .. Env_Length) of String_Access;
 
      begin
         --  Copy the environment
 
         for Iterator in 1 ..  Env_Length loop
            Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1)));
         end loop;
 
         --  Iterate on the environment copy
 
         for Iterator in 1 .. Env_Length loop
            declare
               Current_Var : constant String := Env_Copy (Iterator).all;
               Value_Index : Natural := Env_Copy (Iterator)'First;
 
            begin
               loop
                  exit when Current_Var (Value_Index) = '=';
                  Value_Index := Value_Index + 1;
               end loop;
 
               Process
                 (Current_Var (Current_Var'First .. Value_Index - 1),
                  Current_Var (Value_Index + 1 .. Current_Var'Last));
            end;
         end loop;
 
         --  Free the copy of the environment
 
         for Iterator in 1 .. Env_Length loop
            Free (Env_Copy (Iterator));
         end loop;
      end;
   end Iterate;
 
   ---------
   -- Set --
   ---------
 
   procedure Set (Name : String; Value : String) is
      F_Name  : String (1 .. Name'Length + 1);
      F_Value : String (1 .. Value'Length + 1);
 
      procedure Set_Env_Value (Name, Value : System.Address);
      pragma Import (C, Set_Env_Value, "__gnat_setenv");
 
   begin
      F_Name (1 .. Name'Length) := Name;
      F_Name (F_Name'Last)      := ASCII.NUL;
 
      F_Value (1 .. Value'Length) := Value;
      F_Value (F_Value'Last)      := ASCII.NUL;
 
      Set_Env_Value (F_Name'Address, F_Value'Address);
   end Set;
 
   -----------
   -- Value --
   -----------
 
   function Value (Name : String) return String is
      use System;
 
      procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
      pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 
      procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
      pragma Import (C, Strncpy, "strncpy");
 
      Env_Value_Ptr    : aliased Address;
      Env_Value_Length : aliased Integer;
      F_Name           : aliased String (1 .. Name'Length + 1);
 
   begin
      F_Name (1 .. Name'Length) := Name;
      F_Name (F_Name'Last)      := ASCII.NUL;
 
      Get_Env_Value_Ptr
        (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 
      if Env_Value_Ptr = System.Null_Address then
         raise Constraint_Error;
      end if;
 
      if Env_Value_Length > 0 then
         declare
            Result : aliased String (1 .. Env_Value_Length);
         begin
            Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length);
            return Result;
         end;
      else
         return "";
      end if;
   end Value;
 
end Ada.Environment_Variables;