diff --git a/.gitmodules b/.gitmodules index 5d4d3201c..fc56fd8ee 100644 --- a/.gitmodules +++ b/.gitmodules @@ -57,3 +57,6 @@ [submodule "deps/diskflags"] path = deps/diskflags url = https://github.com/mosteo/diskflags +[submodule "deps/dirty_booleans"] + path = deps/dirty_booleans + url = https://github.com/mosteo/dirty_booleans diff --git a/alire.gpr b/alire.gpr index e7c8f2b45..3490e92de 100644 --- a/alire.gpr +++ b/alire.gpr @@ -4,6 +4,7 @@ with "alire_common"; with "ajunitgen"; with "ansiada"; with "clic"; +with "dirty_booleans"; with "diskflags"; with "gnatcoll"; with "minirest"; diff --git a/alire.toml b/alire.toml index 31dfb506d..0647d91cc 100644 --- a/alire.toml +++ b/alire.toml @@ -20,6 +20,7 @@ ada_toml = "~0.3" ajunitgen = "^1.0.1" ansiada = "^1.0" clic = "~0.3" +dirty_booleans = "~0.1" diskflags = "~0.1" gnatcoll = "^21" minirest = "~0.3" @@ -49,6 +50,7 @@ windows = { ALIRE_OS = "windows" } aaa = { url = "https://github.com/mosteo/aaa", commit = "ecc38772bd4a6b469b54c62363766ea1c0e9f912" } ada_toml = { url = "https://github.com/mosteo/ada-toml", commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" } clic = { url = "https://github.com/alire-project/clic", commit = "6879b90876a1c918b4e112f59c6db0e25b713f52" } +dirty_booleans = { url = "https://github.com/mosteo/dirty_booleans", branch = "main" } diskflags = { url = "https://github.com/mosteo/diskflags", branch = "main" } gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "4e663b87a028252e7e074f054f8f453661397166" } minirest = { url = "https://github.com/mosteo/minirest.git", commit = "9a9c660f9c6f27f5ef75417e7fac7061dff14d78" } diff --git a/alr_env.gpr b/alr_env.gpr index dda7596d8..0fbb9ba12 100644 --- a/alr_env.gpr +++ b/alr_env.gpr @@ -14,6 +14,7 @@ aggregate project Alr_Env is "deps/ajunitgen", "deps/ansi", "deps/clic", + "deps/dirty_booleans", "deps/diskflags", "deps/gnatcoll-slim", "deps/minirest", diff --git a/deps/dirty_booleans b/deps/dirty_booleans new file mode 160000 index 000000000..05c40d88e --- /dev/null +++ b/deps/dirty_booleans @@ -0,0 +1 @@ +Subproject commit 05c40d88ecfe109e575ec8b21dd6ffa2e61df1dc diff --git a/src/alire/alire-builds-hashes.adb b/src/alire/alire-builds-hashes.adb index b80dddcb8..324f29eb8 100644 --- a/src/alire/alire-builds-hashes.adb +++ b/src/alire/alire-builds-hashes.adb @@ -1,6 +1,6 @@ with Alire.Crate_Configuration.Hashes; with Alire.Directories; -with Alire.Environment; +with Alire.Environment.Loading; with Alire.GPR; with Alire.Hashes.SHA256_Impl; with Alire.Paths; @@ -249,7 +249,7 @@ package body Alire.Builds.Hashes is Trace.Debug ("build hashing root " & Root.Path); This.Hashes.Clear; - Environment.Load (Context, Root, For_Hashing => True); + Environment.Loading.Load (Context, Root, For_Hashing => True); Env := Context.Get_All; Root.Configuration.Ensure_Complete; diff --git a/src/alire/alire-environment-loading.adb b/src/alire/alire-environment-loading.adb new file mode 100644 index 000000000..7c2a72071 --- /dev/null +++ b/src/alire/alire-environment-loading.adb @@ -0,0 +1,173 @@ +with Alire_Early_Elaboration; +with Alire.Environment.Formatting; +with Alire.GPR; +with Alire.Platforms.Current; +with Alire.Properties.Scenarios; +with Alire.Releases; +with Alire.Solutions; +with Alire.Toolchains.Solutions; +with Alire.Utils.TTY; + +with GNAT.IO; + +package body Alire.Environment.Loading is + + ---------- + -- Load -- + ---------- + + Already_Warned : Boolean := False; + + procedure Load (This : in out Context; + Root : in out Alire.Roots.Root; + For_Hashing : Boolean := False) + is + Solution : constant Solutions.Solution := + Toolchains.Solutions.Add_Toolchain (Root.Solution); + Tool_Root : Roots.Editable.Root := + Roots.Editable.New_Root (Root); + -- We use a copy of the base root to add the toolchain elements that + -- might be missing from its solution + begin + Tool_Root.Set (Solution); + + -- Load platform environment + Alire.Platforms.Current.Load_Environment (This); + + -- Warnings when setting up an incomplete environment + + if not Solution.Is_Complete then + Trace.Debug ("Generating possibly incomplete environment" + & " because of missing dependencies"); + + -- Normally we would generate a warning, but since that will pollute + -- the output making it unusable, for once we write directly to + -- stderr (unless quiet is in effect): + + if not Alire_Early_Elaboration.Switch_Q and then not Already_Warned + then + Already_Warned := True; + + GNAT.IO.Put_Line + (GNAT.IO.Standard_Error, + TTY.Warn ("warn:") + & " Generating possibly incomplete environment" + & " because of missing dependencies"); + end if; + end if; + + -- Project paths for all releases in the solution, implicitly defined by + -- supplied project files. + + if not For_Hashing then + declare + Sorted_Paths : constant AAA.Strings.Set := + Tool_Root.Current.Project_Paths; + begin + if not Sorted_Paths.Is_Empty then + for Path of reverse Sorted_Paths loop + -- Reverse should not matter as our paths shouldn't overlap, + -- but at least is nicer for user inspection to respect + -- alphabetical order. + + This.Prepend ("GPR_PROJECT_PATH", Path, "crates"); + end loop; + end if; + end; + end if; + + -- Custom definitions provided by each release + + for Rel of Solution.Releases.Including (Root.Release) loop + Load (This => This, + Root => Tool_Root, + Crate => Rel.Name, + For_Hashing => For_Hashing); + end loop; + + This.Set ("ALIRE", "True", "Alire"); + end Load; + + ---------- + -- Load -- + ---------- + + procedure Load (This : in out Context; + Root : in out Roots.Editable.Root; + Crate : Crate_Name; + For_Hashing : Boolean := False) + is + Env : constant Properties.Vector := Root.Current.Environment; + Rel : constant Releases.Release := Root.Current.Release (Crate); + Origin : constant String := Rel.Name_Str; + + Release_Base : constant String + := (if For_Hashing + then Rel.Base_Folder + else Root.Current.Release_Base (Rel.Name, Roots.For_Build)); + -- Before we can known the Release_Base, we supplant it with its + -- simple name. This shouldn't be a problem for hashing, as this + -- is only used for $CRATE_ROOT paths, and the important parts + -- that might merit a hash change are the rest of the path. + begin + Trace.Debug ("Loading environment for crate " + & Alire.Utils.TTY.Name (Crate) + & " release: " & Rel.Milestone.TTY_Image); + + -- Environment variables defined in the crate manifest + for Act of Rel.Environment (Env) loop + Trace.Debug ("Processing env entry: " & Act.Name + & " of type " & Act.Action'Image + & " with value " & Act.Value); + begin + declare + Value : constant String := + Formatting.Format (Release_Base, Act.Value); + begin + case Act.Action is + + when Properties.Environment.Set => + + This.Set (Act.Name, Value, Origin & " (env)"); + + when Properties.Environment.Append => + + This.Append (Act.Name, Value, Origin & " (env)"); + + when Properties.Environment.Prepend => + + This.Prepend (Act.Name, Value, Origin & " (env)"); + + end case; + end; + exception + when Formatting.Unknown_Formatting_Key => + Raise_Checked_Error + ("Unknown environment variable formatting key in var '" & + Act.Name & " of '" & Origin & "'"); + end; + end loop; + + -- Environment variables for GPR external scenario variables + for Property of Rel.On_Platform_Properties (Env) loop + if Property in Alire.Properties.Scenarios.Property'Class then + declare + use all type Alire.GPR.Variable_Kinds; + Variable : constant Alire.GPR.Variable + := Alire.Properties.Scenarios.Property (Property).Value; + begin + if Variable.Kind = External then + This.Set (Variable.Name, Variable.External_Value, + Origin & " (gpr ext)"); + end if; + end; + end if; + end loop; + + -- Set the crate PREFIX location for access to resources + This.Set (AAA.Strings.To_Upper_Case (+Rel.Name) & "_ALIRE_PREFIX", + Release_Base, + "Crate prefix for resources location"); + end Load; + +end Alire.Environment.Loading; diff --git a/src/alire/alire-environment-loading.ads b/src/alire/alire-environment-loading.ads new file mode 100644 index 000000000..2a6d741c2 --- /dev/null +++ b/src/alire/alire-environment-loading.ads @@ -0,0 +1,24 @@ +with Alire.Roots.Editable; + +package Alire.Environment.Loading is + + procedure Load (This : in out Context; + Root : in out Alire.Roots.Root; + For_Hashing : Boolean := False); + -- Load the environment variables of a releases found in the workspace + -- Solution (GPR_PROJECT_PATH and custom variables) in the context. If + -- For_Hashing, skip or mock actions that require the build hash which is + -- part of the build path. We use this to gather all configuration when + -- paths aren't yet known (as they depend on the hash that is computed + -- from the configuration which will become itself part of the path). + +private + + procedure Load (This : in out Context; + Root : in out Roots.Editable.Root; + Crate : Crate_Name; + For_Hashing : Boolean := False); + -- Load the environment variables of a release (GPR_PROJECT_PATH and custom + -- variables) in the context. See note in previous Load about For_Hashing. + +end Alire.Environment.Loading; diff --git a/src/alire/alire-environment.adb b/src/alire/alire-environment.adb index 4aa71d4b8..1a34cc841 100644 --- a/src/alire/alire-environment.adb +++ b/src/alire/alire-environment.adb @@ -2,21 +2,11 @@ with GNAT.OS_Lib; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Alire_Early_Elaboration; -with Alire.Environment.Formatting; with Alire.Errors; with Alire.Properties.Environment; use Alire.Properties.Environment; with Alire.OS_Lib; -with Alire.GPR; -with Alire.Properties.Scenarios; -with Alire.Releases; -with Alire.Roots.Editable; -with Alire.Solutions; -with Alire.Toolchains.Solutions; -with Alire.Utils.TTY; -with Alire.Platforms.Current; -with GNAT.IO; +with Dirty_Booleans; package body Alire.Environment is @@ -77,163 +67,6 @@ package body Alire.Environment is This.Add (Name, Action); end Prepend; - ---------- - -- Load -- - ---------- - - Already_Warned : Boolean := False; - - procedure Load (This : in out Context; - Root : in out Alire.Roots.Root; - For_Hashing : Boolean := False) - is - Solution : constant Solutions.Solution := - Toolchains.Solutions.Add_Toolchain (Root.Solution); - Tool_Root : Roots.Editable.Root := - Roots.Editable.New_Root (Root); - -- We use a copy of the base root to add the toolchain elements that - -- might be missing from its solution - begin - Tool_Root.Set (Solution); - - -- Load platform environment - Alire.Platforms.Current.Load_Environment (This); - - -- Warnings when setting up an incomplete environment - - if not Solution.Is_Complete then - Trace.Debug ("Generating possibly incomplete environment" - & " because of missing dependencies"); - - -- Normally we would generate a warning, but since that will pollute - -- the output making it unusable, for once we write directly to - -- stderr (unless quiet is in effect): - - if not Alire_Early_Elaboration.Switch_Q and then not Already_Warned - then - Already_Warned := True; - - GNAT.IO.Put_Line - (GNAT.IO.Standard_Error, - TTY.Warn ("warn:") - & " Generating possibly incomplete environment" - & " because of missing dependencies"); - end if; - end if; - - -- Project paths for all releases in the solution, implicitly defined by - -- supplied project files. - - if not For_Hashing then - declare - Sorted_Paths : constant AAA.Strings.Set := - Tool_Root.Current.Project_Paths; - begin - if not Sorted_Paths.Is_Empty then - for Path of reverse Sorted_Paths loop - -- Reverse should not matter as our paths shouldn't overlap, - -- but at least is nicer for user inspection to respect - -- alphabetical order. - - This.Prepend ("GPR_PROJECT_PATH", Path, "crates"); - end loop; - end if; - end; - end if; - - -- Custom definitions provided by each release - - for Rel of Solution.Releases.Including (Root.Release) loop - This.Load (Root => Tool_Root, - Crate => Rel.Name, - For_Hashing => For_Hashing); - end loop; - - This.Set ("ALIRE", "True", "Alire"); - end Load; - - ---------- - -- Load -- - ---------- - - procedure Load (This : in out Context; - Root : in out Roots.Editable.Root; - Crate : Crate_Name; - For_Hashing : Boolean := False) - is - Env : constant Properties.Vector := Root.Current.Environment; - Rel : constant Releases.Release := Root.Current.Release (Crate); - Origin : constant String := Rel.Name_Str; - - Release_Base : constant String - := (if For_Hashing - then Rel.Base_Folder - else Root.Current.Release_Base (Rel.Name, Roots.For_Build)); - -- Before we can known the Release_Base, we supplant it with its - -- simple name. This shouldn't be a problem for hashing, as this - -- is only used for $CRATE_ROOT paths, and the important parts - -- that might merit a hash change are the rest of the path. - begin - Trace.Debug ("Loading environment for crate " - & Alire.Utils.TTY.Name (Crate) - & " release: " & Rel.Milestone.TTY_Image); - - -- Environment variables defined in the crate manifest - for Act of Rel.Environment (Env) loop - Trace.Debug ("Processing env entry: " & Act.Name - & " of type " & Act.Action'Image - & " with value " & Act.Value); - begin - declare - Value : constant String := - Formatting.Format (Release_Base, Act.Value); - begin - case Act.Action is - - when Properties.Environment.Set => - - This.Set (Act.Name, Value, Origin & " (env)"); - - when Properties.Environment.Append => - - This.Append (Act.Name, Value, Origin & " (env)"); - - when Properties.Environment.Prepend => - - This.Prepend (Act.Name, Value, Origin & " (env)"); - - end case; - end; - exception - when Formatting.Unknown_Formatting_Key => - Raise_Checked_Error - ("Unknown environment variable formatting key in var '" & - Act.Name & " of '" & Origin & "'"); - end; - end loop; - - -- Environment variables for GPR external scenario variables - for Property of Rel.On_Platform_Properties (Env) loop - if Property in Alire.Properties.Scenarios.Property'Class then - declare - use all type Alire.GPR.Variable_Kinds; - Variable : constant Alire.GPR.Variable := - Alire.Properties.Scenarios.Property (Property).Value; - begin - if Variable.Kind = External then - This.Set (Variable.Name, Variable.External_Value, - Origin & " (gpr ext)"); - end if; - end; - end if; - end loop; - - -- Set the crate PREFIX location for access to resources - This.Set (AAA.Strings.To_Upper_Case (+Rel.Name) & "_ALIRE_PREFIX", - Release_Base, - "Crate prefix for resources location"); - end Load; - ----------------- -- Print_Shell -- ----------------- @@ -420,4 +253,16 @@ package body Alire.Environment is end return; end Get_All; + ----------------------- + -- Traceback_Enabled -- + ----------------------- + + function Traceback_Enabled return Boolean + is + package Dirty is new Dirty_Booleans; + use type Dirty.Boolean; + begin + return Dirty.Value (OS_Lib.Getenv (Traceback, "false")) = True; + end Traceback_Enabled; + end Alire.Environment; diff --git a/src/alire/alire-environment.ads b/src/alire/alire-environment.ads index e15784491..778e33d16 100644 --- a/src/alire/alire-environment.ads +++ b/src/alire/alire-environment.ads @@ -2,7 +2,6 @@ with Ada.Strings.Unbounded; with Alire.Properties; with Alire.Platforms; -limited with Alire.Roots.Editable; private with Ada.Strings.Unbounded.Hash; private with Ada.Containers.Vectors; @@ -10,7 +9,7 @@ private with Ada.Containers.Hashed_Maps; private with Alire.Properties.Environment; private with Ada.Containers.Generic_Array_Sort; -package Alire.Environment is +package Alire.Environment with Preelaborate is Config : constant String := "ALR_CONFIG"; -- Folder where current alr will look for configuration @@ -18,6 +17,11 @@ package Alire.Environment is Testsuite : constant String := "ALR_TESTSUITE"; -- If defined, we are running under the testsuite harness + Traceback : constant String := "ALR_TRACEBACK_ENABLED"; + -- If set to True/1, dump unexpected exceptions to console (same as `-d`) + + function Traceback_Enabled return Boolean; + type Context is tagged limited private; procedure Set (This : in out Context; Name, Value, Origin : String); @@ -29,16 +33,6 @@ package Alire.Environment is procedure Prepend (This : in out Context; Name, Value, Origin : String); -- Prepend a value to a variable in the context - procedure Load (This : in out Context; - Root : in out Alire.Roots.Root; - For_Hashing : Boolean := False); - -- Load the environment variables of a releases found in the workspace - -- Solution (GPR_PROJECT_PATH and custom variables) in the context. If - -- For_Hashing, skip or mock actions that require the build hash which is - -- part of the build path. We use this to gather all configuration when - -- paths aren't yet known (as they depend on the hash that is computed - -- from the configuration which will become itself part of the path). - procedure Export (This : Context); -- Export the environment variables built from the variables previously -- loaded and defined in the context to the OS. @@ -111,11 +105,4 @@ private procedure Add (This : in out Context; Name : String; Action : Env_Action); - procedure Load (This : in out Context; - Root : in out Roots.Editable.Root; - Crate : Crate_Name; - For_Hashing : Boolean := False); - -- Load the environment variables of a release (GPR_PROJECT_PATH and custom - -- variables) in the context. See note in previous Load about For_Hashing. - end Alire.Environment; diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index 23f83ab95..1b2fd5048 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -4,7 +4,7 @@ with Alire.Builds; with Alire.Conditional; with Alire.Dependencies.Containers; with Alire.Directories; -with Alire.Environment; +with Alire.Environment.Loading; with Alire.Errors; with Alire.Flags; with Alire.Install; @@ -218,7 +218,7 @@ package body Alire.Roots is is begin return Context : Alire.Environment.Context do - Context.Load (This); + Alire.Environment.Loading.Load (Context, This); end return; end Build_Context; @@ -1120,7 +1120,7 @@ package body Alire.Roots is procedure Export_Build_Environment (This : in out Root) is Context : Alire.Environment.Context; begin - Context.Load (This); + Alire.Environment.Loading.Load (Context, This); Context.Export; end Export_Build_Environment; diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 3e2ea7eff..42c814ae0 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -1,5 +1,6 @@ with AAA.Debug; +with Alire.Environment; with Alire.Errors; with Alire.Warnings; with Alire.Utils.TTY; @@ -76,7 +77,7 @@ package body Alire is Log (Exception_Information (E), Level); Log ("--->8--- Exception dump end ----->8---", Level); - if Log_Debug then + if Log_Debug or else Environment.Traceback_Enabled then Err_Log (Exception_Name (E)); Err_Log (Full_Msg); Err_Log (Exception_Information (E)); diff --git a/testsuite/tests/misc/env-traceback/test.py b/testsuite/tests/misc/env-traceback/test.py new file mode 100644 index 000000000..fb2dceaea --- /dev/null +++ b/testsuite/tests/misc/env-traceback/test.py @@ -0,0 +1,36 @@ +""" +Check ALR_TRACEBACK_ENABLED env var +""" + +import os +from drivers.alr import run_alr +from drivers.asserts import assert_eq, assert_match + +def check_no_traceback(): + assert_eq('ERROR: Raising forcibly\n' + 'ERROR: alr encountered an unexpected error,' + ' re-run with -d for details.\n', + run_alr("dev", "--raise", + debug=False, complain_on_error=False).out) + + +def check_traceback(): + assert_match(".*0x", # appears in both symbolic and raw tracebacks + run_alr("dev", "--raise", + debug=False, complain_on_error=False).out) + + +# By default (no `-d` or ALR_TRACEBACK_ENABLED) we don't get a backtrace + +check_no_traceback() +for val in ["", "0", "false", "no"]: + os.environ['ALR_TRACEBACK_ENABLED'] = val + check_no_traceback() + +# With ALR_TRACEBACK_ENABLED we do get a backtrace + +for val in ["1", "true", "yes"]: + os.environ['ALR_TRACEBACK_ENABLED'] = val + check_traceback() + +print('SUCCESS') diff --git a/testsuite/tests/misc/env-traceback/test.yaml b/testsuite/tests/misc/env-traceback/test.yaml new file mode 100644 index 000000000..32c747b3f --- /dev/null +++ b/testsuite/tests/misc/env-traceback/test.yaml @@ -0,0 +1 @@ +driver: python-script