ada/florist
0
0
Fork 0
mirror of https://github.com/AdaCore/florist.git synced 2026-02-12 13:10:32 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
florist/libsrc/posix-process_environment.adb
Piotr Trojanek 5fdae93f53 Remove excessive constant qualifier on overlayed slice 
The constant qualifiers on overlays, while perfectly safe and reasonable here,
cause spurious warnings from GNAT.
2025-11-26 12:42:00 +01:00

853 lines
27 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- --
-- 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-1997 Florida State University --
-- Copyright (C) 1998-2014, AdaCore --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
with Ada.Command_Line,
Ada.Unchecked_Deallocation,
POSIX.C,
POSIX.Implementation;
package body POSIX.Process_Environment is
use POSIX.C;
use POSIX.Implementation;
type Environment_List is new POSIX.Implementation.String_List;
type var_char_ptr_ptr is access all char_ptr;
pragma Warnings (Off);
function To_Variable is
new Ada.Unchecked_Conversion (char_ptr_ptr, var_char_ptr_ptr);
pragma Warnings (On);
procedure Free is
new Ada.Unchecked_Deallocation (POSIX_String, POSIX_String_Ptr);
---------------------------------------
-- Interfaced C String Subprograms --
---------------------------------------
function strlen (str : 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 : POSIX_String_Ptr;
Name : 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 : char_ptr;
Name : 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 J in Str'Range loop
if Str (J) = '=' then
return J;
end if;
if Str (J) = NUL then
return 0;
end if;
end loop;
return 0;
end Split_Point;
-------------
-- Match --
-------------
function Match
(Pair : POSIX_String_Ptr;
Name : 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 : char_ptr;
Name : 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 : 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 : Environment;
Target : in out Environment) is
T_Source : constant 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 : constant 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 : constant 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 : POSIX.POSIX_String;
Value : 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 : POSIX.POSIX_String;
Value : 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 : 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 : 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 : 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 : POSIX_String (1 .. L - (J + 1));
for Value'Address use
Env.List (I)(J + 1 .. L - 1)'Address;
pragma Import (Ada, Value);
-- 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;
declare
Value : POSIX_String (1 .. Str'Last - I);
for Value'Address use Str (I + 1 .. Str'Last)'Address;
pragma Import (Ada, Value);
-- contortion needed so index range starts with 1
begin
Action (Str (1 .. I - 1), Value, Quit);
end;
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 : 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;
Reference in New Issue View Git Blame Copy Permalink