------------------------------------------------------------------------------ -- -- -- FLORIST (FSU Implementation of POSIX.5) COMPONENTS -- -- -- -- P O S I X . P R O C E S S _ E N V I R O N M E N T -- -- -- -- B o d y -- -- -- -- -- -- Copyright (c) 1996-1998 Florida State University (FSU), -- -- All Rights Reserved. -- -- -- -- This file is a component of FLORIST, an implementation of an Ada API -- -- for the POSIX OS services, for use with the GNAT Ada compiler and -- -- the FSU Gnu Ada Runtime Library (GNARL). The interface is intended -- -- to be close to that specified in IEEE STD 1003.5 : 1990 and IEEE STD -- -- 1003.5b : 1996. -- -- -- -- FLORIST is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. FLORIST is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have received a -- -- copy of the GNU General Public License distributed with GNARL; see -- -- file COPYING. If not, write to the Free Software Foundation, 59 -- -- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ -- [$Revision : 1.4 $] with Ada.Command_Line, POSIX.C, POSIX.Implementation, Unchecked_Conversion, Unchecked_Deallocation; package body POSIX.Process_Environment is use POSIX.C; use POSIX.Implementation; type Environment_List is new POSIX.Implementation.String_List; function To_Environment is new Unchecked_Conversion (POSIX_String_List, Environment); type var_char_ptr_ptr is access all char_ptr; function To_Variable is new Unchecked_Conversion (char_ptr_ptr, var_char_ptr_ptr); function To_POSIX_String_List is new Unchecked_Conversion (Environment, POSIX_String_List); procedure Free is new Unchecked_Deallocation (POSIX_String, POSIX_String_Ptr); --------------------------------------- -- Interfaced C String Subprograms -- --------------------------------------- function strlen (str : in char_ptr) return size_t; pragma Import (C, strlen, "strlen"); function strcpy (dest : char_ptr; src : char_ptr) return char_ptr; pragma Import (C, strcpy, "strcpy"); function strcat (dest : char_ptr; src : char_ptr) return char_ptr; pragma Import (C, strcat, "strcat"); function strncat (dest : char_ptr; src : char_ptr; n : size_t) return char_ptr; pragma Import (C, strncat, "strncat"); ---------------------------------------------------------- -- Interfaced C Environment Subprograms and Variables -- ---------------------------------------------------------- environ : char_ptr_ptr; pragma Import (C, environ, "environ"); function c_setenv (name : char_ptr; value : char_ptr; overwrite : int) return int; pragma Import (C, c_setenv, setenv_LINKNAME); function c_getenv (name : char_ptr) return char_ptr; pragma Import (C, c_getenv, getenv_LINKNAME); function c_putenv (pair : char_ptr) return int; -- This creates a potentially permanent reference; the -- storage pointed to by pair must not be recovered! pragma Import (C, c_putenv, putenv_LINKNAME); function c_unsetenv (name : char_ptr) return int; pragma Import (C, c_unsetenv, unsetenv_LINKNAME); ------------------------- -- Local_Subprograms -- ------------------------- procedure Validate (Name : POSIX_String); -- Verify that a name is legal, raising posix_error otherwise. function Split_Point (Str : POSIX_String) return Natural; -- Return location of first "=" in string, -- or zero if no "=" is found. -- Assume the string is NUL terminated. function Match (Pair : in POSIX_String_Ptr; Name : in POSIX_String) return Natural; -- Match returns zero unless Pair has the form -- Name & '=' & ..., in which case it returns the index -- immediately following the '=' in Pair. -- The following C-style version of Match is used -- only if the environment does not provide one or more -- of the standard functions putenv, setenv, getenv, unsetenv. function C_Match (Pair : in char_ptr; Name : in char_ptr) return char_ptr; -- If the C environment has the standard functions to modify -- the environment, we use those. Otherwise, we hack our own. function Setenv (Name : char_ptr; Value : char_ptr; Overwrite : int) return int; function Unsetenv (Name : char_ptr) return int; function Getenv (Name : char_ptr) return char_ptr; function Create_Pair (Name, Value : char_ptr) return char_ptr; ------------------- -- Create_Pair -- ------------------- function Create_Pair (Name, Value : char_ptr) return char_ptr is Tmp : char_ptr; Eqls : aliased constant POSIX_String := "="; begin Tmp := malloc (strlen (Name) + strlen (Value) + 2); Tmp := strcpy (Tmp, Name); Tmp := strncat (Tmp, Eqls (1)'Unchecked_Access, 1); Tmp := strcat (Tmp, Value); return Tmp; end Create_Pair; -------------- -- Setenv -- -------------- function Setenv (Name : char_ptr; Value : char_ptr; Overwrite : int) return int is begin if HAVE_putenv then if Overwrite = 0 and then c_getenv (Name) /= null then return 0; end if; return c_putenv (Create_Pair (Name, Value)); elsif HAVE_setenv then return c_setenv (Name, Value, Overwrite); else declare P : char_ptr_ptr := environ; PP : char_ptr_ptr; T : char_ptr_ptr; K : size_t := 0; begin while P.all /= null loop if C_Match (P.all, Name) /= null then if Overwrite = 0 then return 0; end if; -- don't risk freeing P.all! To_Variable (P).all := Create_Pair (Name, Value); end if; K := K + 1; Advance (P); end loop; PP := malloc ((K + 2) * (char_ptr'Size / char'Size)); T := PP; P := environ; for I in 1 .. K loop To_Variable (T).all := P.all; Advance (T); Advance (P); end loop; To_Variable (T).all := Create_Pair (Name, Value); Advance (T); To_Variable (T).all := null; environ := PP; -- .... this risks storage leakage (see note above) end; return 0; end if; end Setenv; ---------------- -- Unsetenv -- ---------------- function Unsetenv (Name : char_ptr) return int is begin if HAVE_unsetenv then return c_unsetenv (Name); else declare P : char_ptr_ptr := environ; PP : char_ptr_ptr; Q : char_ptr; begin while P.all /= null loop Q := C_Match (P.all, Name); if Q /= null then loop PP := P; Advance (P); To_Variable (PP).all := P.all; if P.all = null then return 0; end if; end loop; end if; Advance (P); end loop; end; return 0; end if; end Unsetenv; -------------- -- Getenv -- -------------- function Getenv (Name : char_ptr) return char_ptr is begin if HAVE_getenv then return c_getenv (Name); else declare P : char_ptr_ptr := environ; Q : char_ptr; begin while P.all /= null loop Q := C_Match (P.all, Name); if Q /= null then return Q; end if; Advance (P); end loop; end; end if; return null; end Getenv; ---------------- -- Validate -- ---------------- procedure Validate (Name : POSIX_String) is begin if Name = "" then Raise_POSIX_Error (Invalid_Argument); end if; for P in Name'Range loop if Name (P) = '=' or Name (P) = NUL then Raise_POSIX_Error (Invalid_Argument); end if; end loop; end Validate; ------------------- -- Split_Point -- ------------------- function Split_Point (Str : POSIX_String) return Natural is begin for I in Str'Range loop if Str (I) = '=' then return I; end if; if Str (I) = NUL then return 0; end if; end loop; return 0; end Split_Point; ------------- -- Match -- ------------- function Match (Pair : in POSIX_String_Ptr; Name : in POSIX_String) return Natural is J, JL, K, KL : Integer; begin J := Pair'First; K := Name'First; JL := Pair'Last; KL := Name'Last; while (J <= JL and K <= KL) and then Pair (J) = Name (K) loop J := J + 1; K := K + 1; end loop; -- J > JL or K > KL or Pair (J) /= Name (K) if (K > KL and J <= JL) and then Pair (J) = '=' then return J + 1; end if; return 0; end Match; function C_Match (Pair : in char_ptr; Name : in char_ptr) return char_ptr is J, K : char_ptr; begin J := Pair; K := Name; while (J.all /= NUL and K.all /= NUL) and then J.all = K.all loop Advance (J); Advance (K); end loop; -- J.all = NUL or K.all = NUL or J.all /= K.all if K.all = NUL and J.all = '=' then Advance (J); return J; end if; return null; end C_Match; -------------------------- -- Current Environment -- -------------------------- -- .... Change P1003.5? -- It is not clear from P1003.5 whether the current environment -- should be shared between Ada and C code. We assume that -- it should be shared, and therefore we use the C-language -- operations to access the current environment. -- P1003.5 says we need to recover the storage of the old value -- of the current environment when we modify it. We must trust -- the C interface to do it, if we want compatibility. -- We choose not to try to make these operations tasking-safe, -- as it is not required by the standard and there is no way -- we can make the C interfaces tasking safe. -- .... consider trying to reduce storage leakage here -- Suppose every string that we allocate to become part of the current -- environment is actually part of a record, with a pointer field -- that is used to keep a linked list of all such records. -- When we change an environment value we could run down the list -- and if the string is found, we could safely recover the storage. -- Of course, for this to be safe for concurrent usage, we would need -- to make the operations that modify the list into critical sections. -- Similarly, we could reduce storage leakage for the object corresponding -- to the current environment, when we need to grow it, in Setenv. -- For example, we might declare : -- Our_Environ : char_ptr_ptr := null; -- Points to the last storage we malloced and used for C's environ. -- Our_Environ_Length : Integer := -1; -- The length in pointers of Our_Environ, if that is not null. -- When we shrink the environment, we could remember that there is -- extra space, using Our_Environ_Length, so that when we need to -- grow it again we would not need to allocate a new block. -- When we need to allocate a larger block, we could recover the -- old one, if environ = Our_Environ. --------------------- -- Argument_List -- --------------------- function Argument_List return POSIX.POSIX_String_List is use Ada.Command_Line; Argv : POSIX_String_List; begin Append (Argv, To_POSIX_String (Command_Name)); for I in 1 .. Argument_Count loop Append (Argv, To_POSIX_String (Argument (I))); end loop; return Argv; end Argument_List; -- .... Consider rewriting the above to use the direct C interface. -- That is, get rid of the extra string copying and type conversion. ------------------------------------- -- Copy_From_Current_Environment -- ------------------------------------- procedure Copy_From_Current_Environment (Env : in out Environment) is P : char_ptr_ptr := environ; Tmp : POSIX_String_List := To_POSIX_String_List (Env); begin if P /= null then while P.all /= null loop -- .... concise but inefficient -- We first remove the NUL and then reappend it. Append (Tmp, Form_POSIX_String (P.all)); Advance (P); end loop; end if; Env := To_Environment (Tmp); end Copy_From_Current_Environment; ----------------------------------- -- Copy_To_Current_Environment -- ----------------------------------- procedure Copy_To_Current_Environment (Env : in Environment) is procedure Copy_One (Name : POSIX_String; Value : POSIX_String; Quit : in out Boolean); procedure Copy_One (Name : POSIX_String; Value : POSIX_String; Quit : in out Boolean) is pragma Warnings (Off, Quit); begin Set_Environment_Variable (Name, Value); end Copy_One; procedure Copy_All is new For_Every_Environment_Variable (Copy_One); -- .... concise but inefficient -- We split up pairs, and recombine them, -- adding and removing NUL along the way. -- If we could count on having putenv(), -- the splitting and recombining could be avoided. begin Clear_Environment; Copy_All (Env); end Copy_To_Current_Environment; ------------------------ -- Copy_Environment -- ------------------------ procedure Copy_Environment (Source : in Environment; Target : in out Environment) is T_Source : POSIX_String_List := To_POSIX_String_List (Source); T_Target : POSIX_String_List; procedure Copy_One (Str : POSIX_String; Done : in out Boolean); procedure Copy_One (Str : POSIX_String; Done : in out Boolean) is pragma Warnings (Off, Done); begin Append (T_Target, Str); end Copy_One; procedure Copy_All is new For_Every_Item (Copy_One); begin Clear_Environment (Target); Copy_All (T_Source); Target := To_Environment (T_Target); end Copy_Environment; ---------------------------- -- Environment_Value_Of -- ---------------------------- function Environment_Value_Of (Name : POSIX.POSIX_String; Env : Environment; Undefined : POSIX.POSIX_String := "") return POSIX.POSIX_String is J : Integer; begin Validate (Name); if Env /= null then for I in 1 .. Env.Length loop exit when Env.List (I) = null; J := Match (Env.List (I), Name); if J /= 0 then return Form_POSIX_String (Env.List (I)(J)'Unchecked_Access); end if; end loop; end if; return Undefined; end Environment_Value_Of; ---------------------------- -- Environment_Value_Of -- ---------------------------- function Environment_Value_Of (Name : POSIX.POSIX_String; Undefined : POSIX.POSIX_String := "") return POSIX.POSIX_String is c_name : POSIX_String := Name & NUL; Result : char_ptr := Getenv (c_name (c_name'First)'Unchecked_Access); begin Validate (Name); if Result = null then return Undefined; end if; return Form_POSIX_String (Result); end Environment_Value_Of; ------------------------------- -- Is_Environment_Variable -- ------------------------------- function Is_Environment_Variable (Name : POSIX.POSIX_String; Env : Environment) return Boolean is Result : Boolean := False; procedure Check (Name : POSIX_String; Value : POSIX_String; Done : in out Boolean); procedure Check (Name : POSIX_String; Value : POSIX_String; Done : in out Boolean) is pragma Warnings (Off, Value); begin if Name = Is_Environment_Variable.Name then Result := True; Done := True; end if; end Check; procedure Check_All is new For_Every_Environment_Variable (Check); begin Validate (Name); Check_All (Env); return Result; end Is_Environment_Variable; ------------------------------- -- Is_Environment_Variable -- ------------------------------- function Is_Environment_Variable (Name : POSIX.POSIX_String) return Boolean is c_name : POSIX_String := Name & NUL; begin Validate (Name); return Getenv (c_name (c_name'First)'Unchecked_Access) /= null; end Is_Environment_Variable; ------------------------- -- Clear_Environment -- ------------------------- procedure Clear_Environment (Env : in out Environment) is Tmp : POSIX_String_List := To_POSIX_String_List (Env); begin Make_Empty (Tmp); Env := To_Environment (Tmp); end Clear_Environment; ------------------------- -- Clear_Environment -- ------------------------- procedure Clear_Environment is P : char_ptr_ptr := environ; Strings : POSIX_String_List; procedure Clear_One (Str : POSIX_String; Done : in out Boolean); procedure Clear_One (Str : POSIX_String; Done : in out Boolean) is pragma Warnings (Off, Done); begin Check (Unsetenv (Str (Str'First)'Unchecked_Access)); end Clear_One; procedure Clear_All is new For_Every_Item (Clear_One); begin if P /= null then while P.all /= null loop -- .... concise but inefficient declare S : POSIX_String := Form_POSIX_String (P.all); J : constant Integer := Split_Point (S); begin Append (Strings, S (1 .. J - 1)); end; Advance (P); end loop; Clear_All (Strings); Make_Empty (Strings); P := environ; while P.all /= null loop Advance (P); end loop; end if; end Clear_Environment; -------------------------------- -- Set_Environment_Variable -- -------------------------------- procedure Set_Environment_Variable (Name : in POSIX.POSIX_String; Value : in POSIX.POSIX_String; Env : in out Environment) is J, L : Natural; Tmp : POSIX_String_List; begin Validate (Name); if Env /= null then L := 0; -- last empty location for I in 1 .. Env.Length loop if Env.List (I) = null then if L = 0 then L := I; end if; exit; end if; J := Match (Env.List (I), Name); if J /= 0 then Free (Env.List (I)); Env.List (I) := new POSIX_String'(Name & "=" & Value & NUL); Env.Char (I) := Env.List (I)(1)'Unchecked_Access; return; end if; end loop; pragma Assert (L /= 0); if L < Env.Length then Env.List (L) := new POSIX_String'(Name & "=" & Value & NUL); Env.Char (L) := Env.List (L)(1)'Unchecked_Access; return; end if; end if; Tmp := To_POSIX_String_List (Env); Append (Tmp, Name & "=" & Value); Env := To_Environment (Tmp); end Set_Environment_Variable; -------------------------------- -- Set_Environment_Variable -- -------------------------------- procedure Set_Environment_Variable (Name : in POSIX.POSIX_String; Value : in POSIX.POSIX_String) is c_name : POSIX_String := Name & NUL; c_value : POSIX_String := Value & NUL; begin Validate (Name); Check (Setenv (c_name (c_name'First)'Unchecked_Access, c_value (c_value'First)'Unchecked_Access, 1)); end Set_Environment_Variable; ----------------------------------- -- Delete_Environment_Variable -- ----------------------------------- procedure Delete_Environment_Variable (Name : in POSIX.POSIX_String; Env : in out Environment) is K : Natural; -- the location where Env.List (I) should be; -- eventually lags behind I if we have deleted something begin Validate (Name); if Env /= null then K := 1; for I in 1 .. Env.Length loop -- copy Ith pair down, if necessary -- to fill in for deleted pair if K /= I then Env.List (K) := Env.List (I); Env.Char (K) := Env.Char (I); Env.List (I) := null; Env.Char (I) := null; end if; exit when Env.List (K) = null; if Match (Env.List (K), Name) /= 0 then Free (Env.List (K)); Env.Char (K) := null; else K := K + 1; end if; end loop; end if; end Delete_Environment_Variable; ----------------------------------- -- Delete_Environment_Variable -- ----------------------------------- procedure Delete_Environment_Variable (Name : in POSIX.POSIX_String) is c_name : POSIX_String := Name & NUL; begin Validate (Name); Check (Unsetenv (c_name (c_name'First)'Unchecked_Access)); end Delete_Environment_Variable; -------------- -- Length -- -------------- function Length (Env : Environment) return Natural is begin return Length (To_POSIX_String_List (Env)); end Length; -------------- -- Length -- -------------- function Length return Natural is P : char_ptr_ptr := environ; L : Natural := 0; begin if P /= null then while P.all /= null loop L := L + 1; Advance (P); end loop; end if; return L; end Length; -------------------------------------- -- For_Every_Environment_Variable -- -------------------------------------- -- .... Should we try to protect against side-effects of Action? -- We can do this by making a temporary local copy of the -- environment, to use in the traversal. The cost is the overhead -- of making this copy. We currently choose not to do this, -- though it means cannot use For_Every_Environment_Variable to implement -- Clear_Environment. procedure For_Every_Environment_Variable (Env : in Environment) is Quit : Boolean := False; begin if Env = null then return; end if; for I in 1 .. Env.Length loop exit when Env.List (I) = null; declare L : constant Integer := Env.List (I)'Length; J : constant Integer := Split_Point (Env.List (I).all); begin if J /= 0 then if J < L then declare Value : constant POSIX_String (1 .. L - (J + 1)) := Env.List (I)(J + 1 .. L - 1); -- contortion needed so index range starts with 1 begin Action (Env.List (I)(1 .. J - 1), Value, Quit); end; else Action (Env.List (I)(1 .. J - 1), "", Quit); end if; end if; end; exit when Quit; end loop; end For_Every_Environment_Variable; ---------------------------------------------- -- For_Every_Current_Environment_Variable -- ---------------------------------------------- procedure For_Every_Current_Environment_Variable is Quit : Boolean := False; P : char_ptr_ptr := environ; begin if P = null then return; end if; while P.all /= null loop declare Str : POSIX_String := Form_POSIX_String (P.all); I : constant Natural := Split_Point (Str); begin if I /= 0 then Str (I) := NUL; Action (Str (1 .. I - 1), Str (I + 1 .. Str'Last), Quit); end if; end; exit when Quit; Advance (P); end loop; end For_Every_Current_Environment_Variable; -------------------------------- -- Change_Working_Directory -- -------------------------------- procedure Change_Working_Directory (Directory_Name : in POSIX.Pathname) is function chdir (path : char_ptr) return int; pragma Import (C, chdir, chdir_LINKNAME); c_name : POSIX_String := Directory_Name & NUL; begin Check (chdir (c_name (c_name'First)'Unchecked_Access)); end Change_Working_Directory; ----------------------------- -- Get_Working_Directory -- ----------------------------- function Get_Working_Directory return POSIX.Pathname is function getcwd (buf : char_ptr; size : size_t) return char_ptr; pragma Import (C, getcwd, getcwd_LINKNAME); Guessed_Length : Positive := 256; Result : char_ptr; begin loop declare Buf : POSIX_String (1 .. Guessed_Length); begin Result := getcwd (Buf (1)'Unchecked_Access, size_t (Guessed_Length)); if Result /= null then return Form_POSIX_String (Result); end if; end; exit when Fetch_Errno /= ERANGE; Guessed_Length := Guessed_Length * 2; end loop; Raise_POSIX_Error; return ""; -- to suppress compiler warning end Get_Working_Directory; end POSIX.Process_Environment;