with Ada.Strings.Fixed; with Interfaces.C, Interfaces.C.Strings, Interfaces.C.Pointers; use Ada.Strings.Fixed; use Interfaces.C, Interfaces.C.Strings; package body Environment is -- Copyright (C) 2003 David A. Wheeler -- This version dated 2003-12-18. -- Released under the so-called "MIT/X license": -- Permission is hereby granted, free of charge, to any person -- obtaining a copy of this software and associated documentation files -- (the "Software"), to deal in the Software without restriction, -- including without limitation the rights to use, copy, modify, merge, -- publish, distribute, sublicense, and/or sell copies of the Software, -- and to permit persons to whom the Software is furnished to do so, -- subject to the following conditions: -- -- The above copyright notice and this permission notice shall be -- included in all copies or substantial portions of the Software. -- -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE -- FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- This implementation uses the C functions where possible, since -- the C functions handle any platform oddities and are -- usually well debugged on a given platform. Also, the C routines -- may have security self-defense mechanisms (such as -- removing any duplicates on setting or removing environment variables) -- that we don't want to disable. type aliased_chars_ptr_array is array (size_t range <>) of aliased chars_ptr; -- aliased_chars_ptr_array is the same as chars_ptr_array but allows -- aliasing, which is need to instantiate Interfaces.C.Pointers. package Char_Char_Ptrs is new Interfaces.C.Pointers (Index => size_t, Element => chars_ptr, -- C's "char *" Element_Array => aliased_chars_ptr_array, Default_Terminator => Null_Ptr); use Char_Char_Ptrs; subtype Char_Star_Star is Char_Char_Ptrs.Pointer; -- environ has the C type "char **environ" as is used -- as "char *(environ[])". environ : Char_Star_Star; pragma Import(C, environ); function getenv(Name : chars_ptr) return chars_ptr; pragma Import(C, getenv); -- getenv is a standard C library function; see K&R 2, 1988, page 253. -- It returns a pointer to the first character; do NOT free its results. function setenv(Name : chars_ptr; Value : chars_ptr; Overwrite : int) return int; pragma Import(C, setenv); function putenv(Pair: chars_ptr) return int; pragma Import(C, putenv); procedure unsetenv(Key: chars_ptr); pragma Import(C, unsetenv); function clearenv return int; pragma Import(C, clearenv); function Environment_Count return Natural is begin if environ = null then return 0; else return Natural(Virtual_Length(environ)); end if; end Environment_Count; function Get_Environment(Key : String; Default : String := "") return String is Key_In_C_Format : chars_ptr := New_String(Key); Result_Ptr : chars_ptr := getenv(Key_In_C_Format); begin Free(Key_In_C_Format); if Result_Ptr = Null_Ptr then return Default; else return Value(Result_Ptr); end if; end Get_Environment; function Exists_In_Environment(Key : String) return Boolean is Key_In_C_Format : chars_ptr := New_String(Key); Result_Ptr : chars_ptr := getenv(Key_In_C_Format); begin Free(Key_In_C_Format); if Result_Ptr = Null_Ptr then return False; else return True; end if; end Exists_In_Environment; function Get_Environment_Position(Position : in Positive) return String is Requested_Pair : String := Get_Pair_Position(Position); Delimited_Position : Natural := Index(Requested_Pair, "="); begin if Delimited_Position = 0 then return ""; -- If no "=", presume Pair is the key. else return Requested_Pair(Requested_Pair'First + Delimited_Position .. Requested_Pair'Last); end if; end Get_Environment_Position; function Get_Key_Position(Position : in Positive) return String is Requested_Pair : String := Get_Pair_Position(Position); Delimited_Position : Natural := Index(Requested_Pair, "="); begin if Delimited_Position = 0 then return Requested_Pair; -- If no "=", presume it's the key. elsif Delimited_Position = 1 then return ""; -- If "=x", say key name is the empty string. else return Requested_Pair(Requested_Pair'First .. Delimited_Position - 1); end if; end Get_Key_Position; function Get_Pair_Position(Position : in Positive) return String is begin -- This check takes a little time, but it protects against Position -- being out-of-range, and environments are usually fairly short so -- this shouldn't take much time: if Position > Environment_Count then raise Constraint_Error; end if; -- Compute pointer to requested value, then convert it to an Ada String. declare Place_Ptr : Char_Star_Star := environ + ptrdiff_t(Position - 1); begin return Value(Place_Ptr.all); end; end Get_Pair_Position; procedure Set_Environment(Key : String; Value : String; Overwrite : Boolean := True) is Key_In_C_Format : chars_ptr := New_String(Key); Value_In_C_Format : chars_ptr := New_String(Value); Overwrite_As_Int : int := 0; Result : int; begin if Overwrite then Overwrite_As_Int := 1; end if; Result := setenv(Key_In_C_Format, Value_In_C_Format, Overwrite_As_Int); Free(Key_In_C_Format); Free(Value_In_C_Format); if Result /= 0 then raise Cannot_Set; end if; end Set_Environment; procedure Set_Environment_Pair(Pair : String) is Pair_In_C_Format : chars_ptr := New_String(Pair); Result : int; begin Result := putenv(Pair_In_C_Format); -- DO NOT FREE Pair_In_C_Format; putenv() places the string -- directly into the environment. if Result /= 0 then raise Cannot_Set; end if; end Set_Environment_Pair; procedure Unset_Environment(Key : String) is Key_In_C_Format : chars_ptr := New_String(Key); begin unsetenv(Key_In_C_Format); Free(Key_In_C_Format); end Unset_Environment; procedure Clear_Environment is Result : int; begin -- Note: Some platforms may not have clearenv(); in that case, -- set environ to null instead. We'll call clearenv() if we can, -- because the platform may do other things when clearing the -- environment (such as doing memory management). Result := clearenv; if Result /= 0 then raise Cannot_Set; end if; end Clear_Environment; end Environment;