From b21b0d23725a52f3d4ab01c05c6f1eec01788d70 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Fri, 5 Mar 2021 15:46:56 +0100 Subject: [PATCH] Cache lockfiles, remove Root global, and related refactorings (#690) * Changes up to Alire.Roots * Finished migrating from Workspace * Root is stored in Alr.Commands.Command for reuse This way the global Root is no longer reloaded many times, and modifications are properly encapsulated via the Alire.Roots.Root type. This removes one of the outstanding code smells in Alire. * Speed-ups related to lockfile checks There were a number of overkill checks that furthermore were expensive, loading the lockfile many times. This became quite noticeable for large lockfiles (once there is a decent number of dependencies). * Minor tweaks to comments * Tweaks after merging from master Two big PRs were merged from upstream that created some friction with these changes, requiring minor tweaks. * Temporarily disable `alr build` CI check To allow merging with changes in dependencies, temporarily disable the aforementioned check. --- .../{ci-self.yml => ci-self.yml.disabled} | 0 deps/aaa | 2 +- src/alire/alire-crate_configuration.adb | 8 +- src/alire/alire-crate_configuration.ads | 8 +- src/alire/alire-environment.adb | 8 +- src/alire/alire-environment.ads | 4 +- src/alire/alire-paths.ads | 3 + src/alire/alire-releases.adb | 56 +++ src/alire/alire-releases.ads | 10 + src/alire/alire-root.ads | 7 +- src/alire/alire-roots-optional.adb | 4 +- src/alire/alire-roots-optional.ads | 5 +- src/alire/alire-roots.adb | 406 +++++++++++++++--- src/alire/alire-roots.ads | 130 ++++-- src/alire/alire-workspace.adb | 363 ---------------- src/alire/alire-workspace.ads | 59 --- src/alr/alr-commands-build.adb | 19 +- src/alr/alr-commands-build.ads | 3 +- src/alr/alr-commands-clean.adb | 7 +- src/alr/alr-commands-edit.adb | 9 +- src/alr/alr-commands-get.adb | 31 +- src/alr/alr-commands-index.adb | 8 +- src/alr/alr-commands-pin.adb | 27 +- src/alr/alr-commands-printenv.adb | 8 +- src/alr/alr-commands-publish.adb | 1 - src/alr/alr-commands-run.adb | 34 +- src/alr/alr-commands-search.adb | 4 +- src/alr/alr-commands-show.adb | 21 +- src/alr/alr-commands-test.adb | 2 +- src/alr/alr-commands-update.adb | 7 +- src/alr/alr-commands-version.adb | 11 +- src/alr/alr-commands-withing.adb | 118 ++--- src/alr/alr-commands.adb | 57 ++- src/alr/alr-commands.ads | 31 +- src/alr/alr-root.ads | 3 - .../tests/workflows/action-command/test.py | 2 +- 36 files changed, 764 insertions(+), 712 deletions(-) rename .github/workflows/{ci-self.yml => ci-self.yml.disabled} (100%) delete mode 100644 src/alire/alire-workspace.adb delete mode 100644 src/alire/alire-workspace.ads delete mode 100644 src/alr/alr-root.ads diff --git a/.github/workflows/ci-self.yml b/.github/workflows/ci-self.yml.disabled similarity index 100% rename from .github/workflows/ci-self.yml rename to .github/workflows/ci-self.yml.disabled diff --git a/deps/aaa b/deps/aaa index adb51bfb..b0825ac9 160000 --- a/deps/aaa +++ b/deps/aaa @@ -1 +1 @@ -Subproject commit adb51bfb8cbe8c46b714a346fcbea2a52fe031ed +Subproject commit b0825ac9373ed587394cf5e7ecf51fd7caf9290a diff --git a/src/alire/alire-crate_configuration.adb b/src/alire/alire-crate_configuration.adb index c5c7c7fd..814bf9da 100644 --- a/src/alire/alire-crate_configuration.adb +++ b/src/alire/alire-crate_configuration.adb @@ -21,7 +21,7 @@ package body Alire.Crate_Configuration is ---------- procedure Load (This : in out Global_Config; - Root : Alire.Roots.Root) + Root : in out Alire.Roots.Root) is Solution : constant Solutions.Solution := Root.Solution; begin @@ -49,7 +49,7 @@ package body Alire.Crate_Configuration is --------------------------- procedure Generate_Config_Files (This : Global_Config; - Root : Alire.Roots.Root) + Root : in out Alire.Roots.Root) is use Alire.Directories; use Alire.Origins; @@ -235,7 +235,7 @@ package body Alire.Crate_Configuration is ---------------------- procedure Load_Definitions (This : in out Global_Config; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name) is @@ -278,7 +278,7 @@ package body Alire.Crate_Configuration is ------------------- procedure Load_Settings (This : in out Global_Config; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name) is diff --git a/src/alire/alire-crate_configuration.ads b/src/alire/alire-crate_configuration.ads index 58255101..d162c414 100644 --- a/src/alire/alire-crate_configuration.ads +++ b/src/alire/alire-crate_configuration.ads @@ -15,10 +15,10 @@ package Alire.Crate_Configuration is type Global_Config is tagged limited private; procedure Load (This : in out Global_Config; - Root : Alire.Roots.Root); + Root : in out Alire.Roots.Root); procedure Generate_Config_Files (This : Global_Config; - Root : Alire.Roots.Root); + Root : in out Alire.Roots.Root); private @@ -48,11 +48,11 @@ private -- has no default value. procedure Load_Definitions (This : in out Global_Config; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name); procedure Load_Settings (This : in out Global_Config; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name); procedure Generate_Ada_Config (This : Global_Config; diff --git a/src/alire/alire-environment.adb b/src/alire/alire-environment.adb index cc901769..766fb165 100644 --- a/src/alire/alire-environment.adb +++ b/src/alire/alire-environment.adb @@ -3,15 +3,15 @@ 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.Properties.Scenarios; with Alire.OS_Lib; with Alire.GPR; +with Alire.Properties.Scenarios; with Alire.Roots; with Alire.Solutions; with Alire.Utils; -with Alire.Environment.Formatting; with Alire.Utils.TTY; with Alire.Platform; @@ -83,7 +83,7 @@ package body Alire.Environment is ---------- procedure Load (This : in out Context; - Root : Alire.Roots.Root) + Root : in out Alire.Roots.Root) is Solution : constant Solutions.Solution := Root.Solution; begin @@ -137,7 +137,7 @@ package body Alire.Environment is ---------- procedure Load (This : in out Context; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name) is Rel : constant Releases.Release := Root.Release (Crate); diff --git a/src/alire/alire-environment.ads b/src/alire/alire-environment.ads index 66d54a24..69de6ca7 100644 --- a/src/alire/alire-environment.ads +++ b/src/alire/alire-environment.ads @@ -32,7 +32,7 @@ package Alire.Environment is -- Prepend a value to a variable in the context procedure Load (This : in out Context; - Root : Alire.Roots.Root); + Root : in out Alire.Roots.Root); -- Load the environment variables of a releases found in the workspace -- Solution (GPR_PROJECT_PATH and custom variables) in the context. @@ -93,7 +93,7 @@ private procedure Add (This : in out Context; Name : String; Action : Env_Action); procedure Load (This : in out Context; - Root : Roots.Root; + Root : in out Roots.Root; Crate : Crate_Name); -- Load the environment variables of a release (GPR_PROJECT_PATH and custom -- variables) in the context. diff --git a/src/alire/alire-paths.ads b/src/alire/alire-paths.ads index 12e3d443..6c9b33c5 100644 --- a/src/alire/alire-paths.ads +++ b/src/alire/alire-paths.ads @@ -2,6 +2,9 @@ with Alire.OS_Lib; use Alire.OS_Lib.Operators; package Alire.Paths with Preelaborate is + Crate_File_Name : constant String := "alire.toml"; + -- Name of the manifest file in a regular workspace + function Working_Folder_Inside_Root return Relative_Path is ("alire"); -- Folder within a working release that will contain metadata/build files, diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index a7e5af23..847991cd 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -4,9 +4,12 @@ with Ada.Text_IO; with Alire.Config; with Alire.Crates; +with Alire.Directories; with Alire.Defaults; with Alire.Errors; +with Alire.Origins.Deployers; with Alire.Properties.Bool; +with Alire.Properties.Actions.Executor; with Alire.Requisites.Booleans; with Alire.TOML_Expressions; with Alire.TOML_Load; @@ -90,6 +93,59 @@ package body Alire.Releases is return False; end Check_Caret_Warning; + ------------ + -- Deploy -- + ------------ + + procedure Deploy + (This : Alire.Releases.Release; + Env : Alire.Properties.Vector; + Parent_Folder : String; + Was_There : out Boolean; + Perform_Actions : Boolean := True) + is + use Alire.OS_Lib.Operators; + use all type Alire.Properties.Actions.Moments; + Folder : constant Any_Path := Parent_Folder / This.Unique_Folder; + Result : Alire.Outcome; + begin + + -- Deploy if the target dir is not already there + + if Ada.Directories.Exists (Folder) then + Was_There := True; + Trace.Detail ("Skipping checkout of already available " & + This.Milestone.Image); + else + Was_There := False; + Trace.Detail ("About to deploy " & This.Milestone.Image); + Result := Alire.Origins.Deployers.Deploy (This, Folder); + if not Result.Success then + Raise_Checked_Error (Message (Result)); + end if; + + -- For deployers that do nothing, we ensure the folder exists so all + -- dependencies leave a trace in the cache/dependencies folder, and + -- a place from where to run their actions by default. + + Ada.Directories.Create_Path (Folder); + end if; + + -- Run actions on first retrieval + + if Perform_Actions and then not Was_There then + declare + use Alire.Directories; + Work_Dir : Guard (Enter (Folder)) with Unreferenced; + begin + Alire.Properties.Actions.Executor.Execute_Actions + (Release => This, + Env => Env, + Moment => Post_Fetch); + end; + end if; + end Deploy; + --------------- -- Extending -- --------------- diff --git a/src/alire/alire-releases.ads b/src/alire/alire-releases.ads index 070c5374..bc2760b1 100644 --- a/src/alire/alire-releases.ads +++ b/src/alire/alire-releases.ads @@ -297,6 +297,8 @@ package Alire.Releases is function To_TOML (R : Release; Format : Manifest.Sources) return TOML.TOML_Value; + -- Convert the manifest to TOML. This is done currently only for a concrete + -- platform, hence R.Whenever should have been already called. overriding function To_YAML (R : Release) return String; @@ -316,6 +318,14 @@ package Alire.Releases is -- Check if this release contains a ^0.x dependency, and warn about it. -- Returns whether a warning was emitted. + procedure Deploy + (This : Release; + Env : Alire.Properties.Vector; + Parent_Folder : String; + Was_There : out Boolean; + Perform_Actions : Boolean := True); + -- Deploy the sources of this release under the given Parent_Folder + private use Semantic_Versioning; diff --git a/src/alire/alire-root.ads b/src/alire/alire-root.ads index 12a67e00..60718ac8 100644 --- a/src/alire/alire-root.ads +++ b/src/alire/alire-root.ads @@ -3,6 +3,9 @@ with Alire.Roots.Optional; package Alire.Root is + -- NOTE: Detecting and loading roots is expensive, so it should be done as + -- few times as possible. Once a valid root is obtained, just reuse it. + function Current return Roots.Root; -- Returns the current root, that must exist, or raises Checked_Error @@ -10,10 +13,6 @@ package Alire.Root is -- Returns an optional root, that may be empty if none detected, or broken -- if the manifest is not loadable. - -- TODO - -- This global is a remain of when self-compilation existed - -- To be removed in the short term - function Platform_Properties return Properties.Vector; procedure Set_Platform_Properties (Env : Properties.Vector); diff --git a/src/alire/alire-roots-optional.adb b/src/alire/alire-roots-optional.adb index 2db8e1e0..6264d220 100644 --- a/src/alire/alire-roots-optional.adb +++ b/src/alire/alire-roots-optional.adb @@ -112,7 +112,9 @@ package body Alire.Roots.Optional is is begin This.Assert; - return Reference'(Ptr => This.Data.Value'Access); + -- The following Unrestricted_Access cannot fail as we just asserted + -- the value is stored. + return Reference'(Ptr => This.Data.Value'Unrestricted_Access); end Value; --------------------- diff --git a/src/alire/alire-roots-optional.ads b/src/alire/alire-roots-optional.ads index 8208501d..c324839a 100644 --- a/src/alire/alire-roots-optional.ads +++ b/src/alire/alire-roots-optional.ads @@ -15,10 +15,13 @@ package Alire.Roots.Optional is type Root is new Outcome with private; - type Reference (Ptr : not null access constant Roots.Root) + type Reference (Ptr : not null access Roots.Root) is limited null record with Implicit_Dereference => Ptr; + -- NOTE: Detecting and loading roots is expensive, so it should be done as + -- few times as possible. Once a valid root is obtained, just reuse it. + function Detect_Root (Path : Any_Path) return Optional.Root; -- Try to detect a root at the given Path diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index cf151647..702eee2d 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -1,16 +1,16 @@ with Ada.Calendar; with Ada.Directories; +with Alire.Conditional; +with Alire.Crate_Configuration; +with Alire.Dependencies.Containers; +with Alire.Directories; with Alire.Environment; -with Alire.Lockfiles; with Alire.Manifest; with Alire.OS_Lib; with Alire.Roots.Optional; with Alire.Solutions.Diffs; with Alire.Utils.TTY; -with Alire.Utils.User_Input; -with Alire.Workspace; -with Alire.Crate_Configuration; with GNAT.OS_Lib; @@ -22,7 +22,8 @@ package body Alire.Roots is -- Build_Context -- ------------------- - function Build_Context (This : Root) return Alire.Environment.Context is + function Build_Context (This : in out Root) return Alire.Environment.Context + is begin return Context : Alire.Environment.Context do Context.Load (This); @@ -33,7 +34,7 @@ package body Alire.Roots is -- Direct_Withs -- ------------------ - function Direct_Withs (This : Root; + function Direct_Withs (This : in out Root; Dependent : Releases.Release) return Utils.String_Set is @@ -66,7 +67,7 @@ package body Alire.Roots is -- Generate_Configuration -- ---------------------------- - procedure Generate_Configuration (This : Root) is + procedure Generate_Configuration (This : in out Root) is Conf : Alire.Crate_Configuration.Global_Config; begin Conf.Load (This); @@ -85,6 +86,193 @@ package body Alire.Roots is end if; end Check_Stored; + ------------------------ + -- Create_For_Release -- + ------------------------ + + function Create_For_Release (This : Releases.Release; + Parent_Folder : Any_Path; + Env : Alire.Properties.Vector; + Perform_Actions : Boolean := True) + return Root + is + use Directories; + Was_There : Boolean with Unreferenced; + begin + This.Deploy + (Env => Env, + Parent_Folder => Parent_Folder, + Was_There => Was_There, + Perform_Actions => Perform_Actions); + + -- Backup a potentially packaged manifest, so our authoritative manifest + -- from the index is always used. + + declare + Working_Dir : Guard (Enter (This.Unique_Folder)) + with Unreferenced; + begin + Ada.Directories.Create_Path (Paths.Working_Folder_Inside_Root); + + if GNAT.OS_Lib.Is_Regular_File (Paths.Crate_File_Name) then + Trace.Debug ("Backing up bundled manifest file as *.upstream"); + declare + Upstream_File : constant String := + Paths.Working_Folder_Inside_Root / + (Paths.Crate_File_Name & ".upstream"); + begin + Alire.Directories.Backup_If_Existing + (Upstream_File, + Base_Dir => Paths.Working_Folder_Inside_Root); + Ada.Directories.Rename + (Old_Name => Paths.Crate_File_Name, + New_Name => Upstream_File); + end; + end if; + end; + + -- And generate its working files, if they do not exist + + declare + Working_Dir : Guard (Enter (This.Unique_Folder)) + with Unreferenced; + Root : Alire.Roots.Root := + Alire.Roots.New_Root + (This, + Ada.Directories.Current_Directory, + Env); + begin + + Ada.Directories.Create_Path (Root.Working_Folder); + + -- Generate the authoritative manifest from index information for + -- eventual use of the gotten crate as a local workspace. + + Root.Write_Manifest; + + -- Create also a preliminary lockfile (since dependencies are + -- still unretrieved). Once they are checked out, the lockfile + -- will be replaced with the complete solution. + + Root.Set + (Solution => (if This.Dependencies (Env).Is_Empty + then Alire.Solutions.Empty_Valid_Solution + else Alire.Solutions.Empty_Invalid_Solution)); + + return Root; + end; + end Create_For_Release; + + ------------------------- + -- Deploy_Dependencies -- + ------------------------- + + procedure Deploy_Dependencies (This : in out Roots.Root) + is + Was_There : Boolean; + Pending : Alire.Solutions.Release_Map := This.Solution.Releases; + Deployed : Containers.Crate_Name_Sets.Set; + Round : Natural := 0; + begin + + -- Prepare environment for any post-fetch actions. This must be done + -- after the lockfile on disk is written, since the root will read + -- dependencies from there. + + This.Export_Build_Environment; + + -- Mark any dependencies without a corresponding regular release as + -- already deployed (in practice, we don't have to deploy them, and + -- dependents don't need to wait for their deployment). + + for Dep of This.Solution.Required loop + if not Dep.Has_Release then + Deployed.Include (Dep.Crate); + end if; + end loop; + + -- Deploy regular resolved dependencies: + + while not Pending.Is_Empty loop + Round := Round + 1; + + declare + To_Remove : Alire.Containers.Release_Set; + function Enum (Deps : Conditional.Dependencies) + return Alire.Dependencies.Containers.List + renames Conditional.Enumerate; + begin + + -- TODO: this can be done in parallel within each round + + for Rel of Pending loop + + -- In the 1st step of each round we identify releases that + -- don't have undeployed dependencies. We also identify + -- releases that need not to be deployed (e.g. linked ones). + + if not This.Solution.State (Rel.Name).Is_Solved then + Trace.Debug ("Round" & Round'Img & ": NOOP " & + Rel.Milestone.Image); + + To_Remove.Include (Rel); + + elsif + (for some Dep of Enum (Rel.Dependencies (This.Environment)) => + not Deployed.Contains (Dep.Crate)) + then + Trace.Debug ("Round" & Round'Img & ": SKIP not-ready " & + Rel.Milestone.Image); + + else + Trace.Debug ("Round" & Round'Img & ": CHECKOUT ready " & + Rel.Milestone.Image); + + To_Remove.Include (Rel); + + if Rel.Name /= Release (This).Name then + Rel.Deploy (Env => This.Environment, + Parent_Folder => This.Dependencies_Dir, + Was_There => Was_There); + else + Trace.Debug + ("Skipping checkout of root crate as dependency"); + end if; + end if; + end loop; + + -- In the 2nd step of each round we mark as deployed all releases + -- that were deployed in the 1st step of the round. + + if To_Remove.Is_Empty then + raise Program_Error + with "No release checked out in round" & Round'Img; + else + for Rel of To_Remove loop + Pending.Exclude (Rel.Name); + Deployed.Include (Rel.Name); + end loop; + end if; + end; + end loop; + + -- Show hints for missing externals to the user after all the noise of + -- dependency post-fetch compilations. + + This.Solution.Print_Hints (This.Environment); + + -- Update/Create configuration files + This.Generate_Configuration; + + -- Check that the solution does not contain suspicious dependencies, + -- taking advantage that this procedure is called whenever a change + -- to dependencies is happening. + + pragma Assert (Release (This).Check_Caret_Warning or else True); + -- We don't care about the return value here + + end Deploy_Dependencies; + --------------- -- Is_Stored -- --------------- @@ -131,7 +319,7 @@ package body Alire.Roots is -- Export_Build_Environment -- ------------------------------ - procedure Export_Build_Environment (This : Root) is + procedure Export_Build_Environment (This : in out Root) is Context : Alire.Environment.Context; begin Context.Load (This); @@ -142,7 +330,7 @@ package body Alire.Roots is -- Project_Paths -- ------------------- - function Project_Paths (This : Root) return Utils.String_Set + function Project_Paths (This : in out Root) return Utils.String_Set is use Alire.OS_Lib; Paths : Utils.String_Set; @@ -184,16 +372,23 @@ package body Alire.Roots is end return; end Project_Paths; + --------- + -- Set -- + --------- + + procedure Set (This : in out Root; + Solution : Solutions.Solution) + is + begin + This.Cached_Solution.Set (Solution, This.Lock_File); + end Set; + -------------- -- Solution -- -------------- - function Solution (This : Root) return Solutions.Solution is - begin - -- TODO: This probably is a good target for caching unless file - -- timestamp has changed. - return Lockfiles.Read (This.Lock_File).Solution; - end Solution; + function Solution (This : in out Root) return Solutions.Solution + is (This.Cached_Solution.Element (This.Lock_File)); ----------------- -- Environment -- @@ -208,10 +403,8 @@ package body Alire.Roots is function New_Root (Name : Crate_Name; Path : Absolute_Path; - Env : Properties.Vector) return Root is - (Env, - +Path, - Containers.To_Release_H (Releases.New_Working_Release (Name))); + Env : Properties.Vector) return Root + is (New_Root (Releases.New_Working_Release (Name), Path, Env)); -------------- -- New_Root -- @@ -220,9 +413,10 @@ package body Alire.Roots is function New_Root (R : Releases.Release; Path : Absolute_Path; Env : Properties.Vector) return Root is - (Env, - +Path, - Containers.To_Release_H (R)); + (Environment => Env, + Path => +Path, + Release => Containers.To_Release_H (R), + Cached_Solution => <>); ---------- -- Path -- @@ -241,7 +435,7 @@ package body Alire.Roots is -- Release -- ------------- - function Release (This : Root; + function Release (This : in out Root; Crate : Crate_Name) return Releases.Release is (if This.Release.Element.Name = Crate then This.Release.Element @@ -253,16 +447,22 @@ package body Alire.Roots is -- Release_Base -- ------------------ - function Release_Base (This : Root; Crate : Crate_Name) return Any_Path is - (if This.Release.Element.Name = Crate then - +This.Path + function Release_Base (This : in out Root; + Crate : Crate_Name) + return Any_Path + is + Deps_Dir : constant Any_Path := This.Dependencies_Dir; + begin + if This.Release.Element.Name = Crate then + return +This.Path; elsif This.Solution.State (Crate).Is_Solved then - This.Dependencies_Dir - / Release (This, Crate).Unique_Folder + return Deps_Dir / Release (This, Crate).Unique_Folder; elsif This.Solution.State (Crate).Is_Linked then - This.Solution.State (Crate).Link.Path + return This.Solution.State (Crate).Link.Path; else - raise Program_Error with "release must be either solved or linked"); + raise Program_Error with "release must be either solved or linked"; + end if; + end Release_Base; --------------- -- Lock_File -- @@ -294,12 +494,33 @@ package body Alire.Roots is function Working_Folder (This : Root) return Absolute_Path is ((+This.Path) / "alire"); + -------------------- + -- Write_Solution -- + -------------------- + + procedure Write_Solution (Solution : Solutions.Solution; + Lockfile : String) + is + begin + Lockfiles.Write (Contents => (Solution => Solution), + Filename => Lockfile); + end Write_Solution; + ------------------ -- Has_Lockfile -- ------------------ - function Has_Lockfile (This : Root) return Boolean - is (Lockfiles.Validity (This.Lock_File) in Lockfiles.Valid); + function Has_Lockfile (This : Root; + Check_Valid : Boolean := False) + return Boolean + is (This.Cached_Solution.Has_Element + -- The following validity check is very expensive. This shortcut + -- speeds up things greatly and both should be in sync if things + -- are as they should. + or else + (if Check_Valid + then Lockfiles.Validity (This.Lock_File) in Lockfiles.Valid + else Ada.Directories.Exists (This.Lock_File))); -------------------------- -- Is_Lockfile_Outdated -- @@ -318,11 +539,11 @@ package body Alire.Roots is -- Sync_Solution_And_Deps -- ---------------------------- - procedure Sync_Solution_And_Deps (This : Root) is + procedure Sync_Solution_And_Deps (This : in out Root) is begin if This.Is_Lockfile_Outdated then Trace.Info ("Detected changes in manifest, updating workspace..."); - Workspace.Update_And_Deploy_Dependencies (This, Confirm => False); + This.Update_And_Deploy_Dependencies (Confirm => False); -- Don't ask for confirmation as this is an automatic update in -- reaction to a manually edited manifest, and we need the lockfile -- to match the manifest. As any change in dependencies will be @@ -342,10 +563,7 @@ package body Alire.Roots is then Trace.Info ("Detected missing dependencies, updating workspace..."); -- Some dependency is missing; redeploy. Should we clean first ??? - Workspace.Deploy_Dependencies - (Root => This, - Solution => This.Solution, - Deps_Dir => This.Dependencies_Dir); + This.Deploy_Dependencies; end if; end Sync_Solution_And_Deps; @@ -365,12 +583,50 @@ package body Alire.Roots is end if; end Sync_Manifest_And_Lockfile_Timestamps; + -------------------- + -- Compute_Update -- + -------------------- + + function Compute_Update + (This : in out Root; + Allowed : Containers.Crate_Name_Sets.Set := + Containers.Crate_Name_Sets.Empty_Set; + Options : Solver.Query_Options := + Solver.Default_Options) + return Solutions.Solution + is + use type Conditional.Dependencies; + + Old : constant Solutions.Solution := This.Solution; + Deps : Conditional.Dependencies := + Release (This).Dependencies (This.Environment); + begin + + -- Identify crates that must be held back + + if not Allowed.Is_Empty then + for Release of Old.Releases loop + if not Allowed.Contains (Release.Name) then + Trace.Debug ("Forcing release in solution: " + & Release.Version.Image); + Deps := Release.To_Dependency and Deps; + end if; + end loop; + end if; + + return Solver.Resolve + (Deps => Deps, + Props => This.Environment, + Current => Old, + Options => Options); + end Compute_Update; + ------------------------- -- Update_Dependencies -- ------------------------- procedure Update_Dependencies - (This : Root; + (This : in out Root; Silent : Boolean; Options : Solver.Query_Options := Solver.Default_Options; Allowed : Containers.Crate_Name_Sets.Set := @@ -397,8 +653,8 @@ package body Alire.Roots is end loop; declare - Needed : constant Solutions.Solution := - Workspace.Update (This.Environment, Allowed, Options); + Needed : constant Solutions.Solution := This.Compute_Update + (Allowed, Options); Diff : constant Solutions.Diffs.Diff := Old.Changes (Needed); begin -- Early exit when there are no changes @@ -430,28 +686,66 @@ package body Alire.Roots is -- Apply the update - Workspace.Deploy_Dependencies (Solution => Needed); + This.Set (Solution => Needed); + This.Deploy_Dependencies; + + -- Update/Create configuration files + This.Generate_Configuration; Trace.Detail ("Update completed"); end; end Update_Dependencies; - ------------ - -- Extend -- - ------------ + ------------------------------------ + -- Update_And_Deploy_Dependencies -- + ------------------------------------ - procedure Extend - (This : in out Root; - Dependencies : Conditional.Dependencies := Conditional.No_Dependencies; - Properties : Conditional.Properties := Conditional.No_Properties; - Available : Alire.Requisites.Tree := Requisites.No_Requisites) + procedure Update_And_Deploy_Dependencies + (This : in out Roots.Root; + Options : Solver.Query_Options := Solver.Default_Options; + Confirm : Boolean := not Utils.User_Input.Not_Interactive) is + Prev : constant Solutions.Solution := This.Solution; + Next : constant Solutions.Solution := + This.Compute_Update (Options => Options); + Diff : constant Solutions.Diffs.Diff := Prev.Changes (Next); begin - This.Release.Replace_Element - (This.Release.Element.Extending - (Dependencies, - Properties, - Available)); - end Extend; + if Diff.Contains_Changes then + if not Confirm or else + Utils.User_Input.Confirm_Solution_Changes (Diff) + then + if not Confirm then + Trace.Info ("Changes to dependency solution:"); + Diff.Print (Changed_Only => not Alire.Detailed); + end if; + + This.Set (Solution => Next); + This.Deploy_Dependencies; + end if; + end if; + + -- Update/Create configuration files + This.Generate_Configuration; + + end Update_And_Deploy_Dependencies; + + -------------------- + -- Write_Manifest -- + -------------------- + + procedure Write_Manifest (This : Root) is + Release : constant Releases.Release := Roots.Release (This); + begin + Trace.Debug ("Generating " & Release.Name_Str & ".toml file for " + & Release.Milestone.Image & " with" + & Release.Dependencies.Leaf_Count'Img & " dependencies"); + + Directories.Backup_If_Existing + (This.Crate_File, + Base_Dir => Paths.Working_Folder_Inside_Root); + + Release.Whenever (This.Environment) + .To_File (This.Crate_File, Manifest.Local); + end Write_Manifest; end Alire.Roots; diff --git a/src/alire/alire-roots.ads b/src/alire/alire-roots.ads index 05ef944e..079051a5 100644 --- a/src/alire/alire-roots.ads +++ b/src/alire/alire-roots.ads @@ -1,22 +1,38 @@ +private with AAA.Caches.Files; + limited with Alire.Environment; -with Alire.Conditional; with Alire.Containers; +private with Alire.Lockfiles; +with Alire.Paths; with Alire.Properties; with Alire.Releases; with Alire.Requisites; with Alire.Solutions; with Alire.Solver; -with Alire.Utils; +with Alire.Utils.User_Input; package Alire.Roots is - Crate_File_Name : constant String := "alire.toml"; + Crate_File_Name : String renames Paths.Crate_File_Name; -- Type used to encapsulate the information about the working context. -- A valid alire working dir is one containing an alire/crate.toml file. type Root (<>) is tagged private; + function Create_For_Release (This : Releases.Release; + Parent_Folder : Any_Path; + Env : Properties.Vector; + Perform_Actions : Boolean := True) + return Root; + -- Prepare a workspace with This release as the root one, with manifest and + -- lock files. IOWs, does everything but deploying dependencies. Intended + -- to be called before a root exists, to build it. After this call, + -- the Root is usable. For when retrieval is with --only (e.g., in a + -- platform where it is unavailable, but we want to inspect the sources), + -- Perform_Actions allow disabling these operations that make no sense for + -- the Release on isolation. + function Load_Root (Path : Any_Path) return Root; -- Attempt to detect a root at the given path. The root will be valid if -- path/alire exists, path/alire/*.toml is unique and loadable as a crate @@ -35,6 +51,11 @@ package Alire.Roots is -- From existing release -- Path must point to the session folder (parent of alire metadata folder) + procedure Set (This : in out Root; + Solution : Solutions.Solution) with + Post => This.Has_Lockfile; + -- Set Solution as the new solution for This, also storing it on disk + procedure Check_Stored (This : Root); -- Check that the Root information exists on disk (paths exist, manifest -- file is at expected place...); otherwise Checked_Error. Does not check @@ -47,60 +68,52 @@ package Alire.Roots is is (This.Storage_Error = ""); -- Check that a root is properly stored (manifest on disk is loadable) + function Direct_Withs (This : in out Root; + Dependent : Releases.Release) + return Utils.String_Set; + -- Obtain the project files required by Dependent in This.Solution + function Environment (This : Root) return Properties.Vector; -- Retrieve the environment stored within this root. Environment here -- refers to the platform properties. - function Build_Context (This : Root) return Alire.Environment.Context; + function Build_Context (This : in out Root) + return Alire.Environment.Context; - function Direct_Withs (This : Root; - Dependent : Releases.Release) - return Utils.String_Set; - -- Returns project file names of direct dependencies of the given dependent - - procedure Export_Build_Environment (This : Root); + procedure Export_Build_Environment (This : in out Root); -- Export the build environment (PATH, GPR_PROJECT_PATH) of the given root - procedure Generate_Configuration (This : Root); - - procedure Extend - (This : in out Root; - Dependencies : Conditional.Dependencies := Conditional.No_Dependencies; - Properties : Conditional.Properties := Conditional.No_Properties; - Available : Alire.Requisites.Tree := Requisites.No_Requisites); - -- Add dependencies/properties/requisites to the root release - function Path (This : Root) return Absolute_Path; - function Project_Paths (This : Root) + function Project_Paths (This : in out Root) return Utils.String_Set; -- Return all the paths that should be set in GPR_PROJECT_PATH for the - -- solution in this root. This includes al releases' paths and any linked + -- solution in this root. This includes all releases' paths and any linked -- directories. - type Solution_Components is (Root_Release, - Direct_Dependencies, - Indirect_Dependencies); - - type Components_Array is array (Solution_Components) of Boolean; - function Release (This : Root) return Releases.Release; - function Release (This : Root; Crate : Crate_Name) return Releases.Release + function Release (This : in out Root; + Crate : Crate_Name) + return Releases.Release with Pre => (Crate = This.Release.Name or else This.Solution.Depends_On (Crate)); -- Retrieve a release, that can be either the root or any in the solution - function Release_Base (This : Root; Crate : Crate_Name) return Any_Path; + function Release_Base (This : in out Root; + Crate : Crate_Name) + return Any_Path; -- Find the base folder in which a release can be found for the given root - function Solution (This : Root) return Solutions.Solution with + function Solution (This : in out Root) return Solutions.Solution with Pre => This.Has_Lockfile; -- Returns the solution stored in the lockfile - function Has_Lockfile (This : Root) return Boolean; + function Has_Lockfile (This : Root; + Check_Valid : Boolean := False) + return Boolean; -- Check the corresponding lockfile storing a solution for the root - -- dependencies exists and is loadable. + -- dependencies exists and (optionally, expensive) whether it is loadable. function Is_Lockfile_Outdated (This : Root) return Boolean with Pre => This.Has_Lockfile; @@ -109,7 +122,7 @@ package Alire.Roots is -- conceivably we could use checksums to make it more robust against -- automated changes within the same second. - procedure Sync_Solution_And_Deps (This : Root); + procedure Sync_Solution_And_Deps (This : in out Root); -- Ensure that dependencies are up to date in regard to the lockfile and -- manifest: if the manifest is newer than the lockfile, resolve again, -- as dependencies may have been edited by hand. Otherwise, ensure that @@ -122,36 +135,71 @@ package Alire.Roots is -- edited but the solution hasn't changed (and so the lockfile hasn't been -- regenerated). This way we know the lockfile is valid for the manifest. + function Compute_Update + (This : in out Root; + Allowed : Containers.Crate_Name_Sets.Set := + Containers.Crate_Name_Sets.Empty_Set; + Options : Solver.Query_Options := Solver.Default_Options) + return Solutions.Solution; + -- Compute a new solution for the workspace. If Allowed is not empty, + -- crates not appearing in Allowed are held back at their current version. + -- This function loads configured indexes from disk. No changes are + -- applied to This root. + + procedure Deploy_Dependencies (This : in out Root); + -- Download all dependencies not already on disk from This.Solution + procedure Update_Dependencies - (This : Root; + (This : in out Root; Silent : Boolean; Options : Solver.Query_Options := Solver.Default_Options; Allowed : Containers.Crate_Name_Sets.Set := - Alire.Containers.Crate_Name_Sets.Empty_Set) - with Pre => This.Has_Lockfile; + Alire.Containers.Crate_Name_Sets.Empty_Set); -- Resolve and update all or given crates in a root. When silent, run -- as in non-interactive mode as this is an automatically-triggered update. + procedure Update_And_Deploy_Dependencies + (This : in out Roots.Root; + Options : Solver.Query_Options := Solver.Default_Options; + Confirm : Boolean := not Utils.User_Input.Not_Interactive); + -- Call Update and Deploy_Dependencies in succession for the given root + + procedure Write_Manifest (This : Root); + -- Generates the crate.toml manifest at the appropriate location for Root + -- Files and folders derived from the root path (this obsoletes Alr.Paths): function Working_Folder (This : Root) return Absolute_Path; -- The "alire" folder inside the root path function Crate_File (This : Root) return Absolute_Path; - -- The "$crate.toml" file inside Working_Folder + -- The "/path/to/alire.toml" file inside Working_Folder function Dependencies_Dir (This : Root) return Absolute_Path; -- The folder where dependencies are checked out for this root function Lock_File (This : Root) return Absolute_Path; - -- The "$crate.lock" file inside Working_Folder + -- The "/path/to/alire.lock" file inside Working_Folder private + function Load_Solution (Lockfile : String) return Solutions.Solution + is (Lockfiles.Read (Lockfile).Solution); + + procedure Write_Solution (Solution : Solutions.Solution; + Lockfile : String); + -- Wrapper for use with Cached_Solutions + + package Cached_Solutions is new AAA.Caches.Files + (Cached => Solutions.Solution, + Load => Load_Solution, + Write => Write_Solution); + type Root is tagged record - Environment : Properties.Vector; - Path : UString; - Release : Containers.Release_H; + Environment : Properties.Vector; + Path : UString; + Release : Containers.Release_H; + Cached_Solution : Cached_Solutions.Cache; end record; end Alire.Roots; diff --git a/src/alire/alire-workspace.adb b/src/alire/alire-workspace.adb deleted file mode 100644 index 70fe982d..00000000 --- a/src/alire/alire-workspace.adb +++ /dev/null @@ -1,363 +0,0 @@ -with Ada.Directories; - -with Alire.Conditional; -with Alire.Dependencies.Containers; -with Alire.Dependencies.States; -with Alire.Directories; -with Alire.Lockfiles; -with Alire.Manifest; -with Alire.Origins.Deployers; -with Alire.OS_Lib; -with Alire.Paths; -with Alire.Properties.Actions.Executor; -with Alire.Roots; -with Alire.Solutions.Diffs; - -package body Alire.Workspace is - - use type Conditional.Dependencies; - - ------------------------- - -- Deploy_Dependencies -- - ------------------------- - - procedure Deploy_Dependencies - (Root : Roots.Root := Alire.Root.Current; - Solution : Solutions.Solution := Alire.Root.Current.Solution; - Deps_Dir : Absolute_Path := Alire.Root.Current.Dependencies_Dir) - is - Was_There : Boolean; - Pending : Alire.Solutions.Release_Map := Solution.Releases; - Deployed : Containers.Crate_Name_Sets.Set; - Round : Natural := 0; - begin - - -- Store given solution on disk to ensure consistency between deployed - -- dependencies and stored lockfile. - - Alire.Lockfiles.Write ((Solution => Solution), Root.Lock_File); - - -- Prepare environment for any post-fetch actions. This must be done - -- after the lockfile on disk is written, since the root will read - -- dependencies from there. - - Root.Export_Build_Environment; - - -- Mark any dependencies without a corresponding regular release as - -- already deployed (in practice, we don't have to deploy them, and - -- dependents don't need to wait for their deployment). - - for Dep of Solution.Required loop - if not Dep.Has_Release then - Deployed.Include (Dep.Crate); - end if; - end loop; - - -- Deploy regular resolved dependencies: - - while not Pending.Is_Empty loop - Round := Round + 1; - - declare - To_Remove : Alire.Containers.Release_Set; - function Enum (Deps : Conditional.Dependencies) - return Alire.Dependencies.Containers.List - renames Conditional.Enumerate; - begin - - -- TODO: this can be done in parallel within each round - - for Rel of Pending loop - - -- In the 1st step of each round we identify releases that - -- don't have undeployed dependencies. We also identify - -- releases that need not to be deployed (e.g. linked ones). - - if not Solution.State (Rel.Name).Is_Solved then - Trace.Debug ("Round" & Round'Img & ": NOOP " & - Rel.Milestone.Image); - - To_Remove.Include (Rel); - - elsif - (for some Dep of Enum (Rel.Dependencies (Root.Environment)) => - not Deployed.Contains (Dep.Crate)) - then - Trace.Debug ("Round" & Round'Img & ": SKIP not-ready " & - Rel.Milestone.Image); - - else - Trace.Debug ("Round" & Round'Img & ": CHECKOUT ready " & - Rel.Milestone.Image); - - To_Remove.Include (Rel); - - if Rel.Name /= Root.Release.Name then - Deploy_Release (Release => Rel, - Env => Root.Environment, - Parent_Folder => Deps_Dir, - Was_There => Was_There); - else - Trace.Debug - ("Skipping checkout of root crate as dependency"); - end if; - end if; - end loop; - - -- In the 2nd step of each round we mark as deployed all releases - -- that were deployed in the 1st step of the round. - - if To_Remove.Is_Empty then - raise Program_Error - with "No release checked out in round" & Round'Img; - else - for Rel of To_Remove loop - Pending.Exclude (Rel.Name); - Deployed.Include (Rel.Name); - end loop; - end if; - end; - end loop; - - -- Show hints for missing externals to the user after all the noise of - -- dependency post-fetch compilations. - - Solution.Print_Hints (Root.Environment); - - -- Update/Create configuration files - Root.Generate_Configuration; - - -- Check that the solution does not contain suspicious dependencies, - -- taking advantage that this procedure is called whenever a change - -- to dependencies is happening. - - pragma Assert (Root.Release.Check_Caret_Warning or else True); - -- We don't care about the return value here - - end Deploy_Dependencies; - - -------------------- - -- Deploy_Release -- - -------------------- - - procedure Deploy_Release - (Release : Alire.Releases.Release; - Env : Properties.Vector; - Parent_Folder : String; - Was_There : out Boolean; - Perform_Actions : Boolean := True) - is - use Alire.OS_Lib.Operators; - use all type Alire.Properties.Actions.Moments; - Folder : constant Any_Path := Parent_Folder / Release.Unique_Folder; - Result : Alire.Outcome; - begin - - -- Deploy if the target dir is not already there - - if Ada.Directories.Exists (Folder) then - Was_There := True; - Trace.Detail ("Skipping checkout of already available " & - Release.Milestone.Image); - else - Was_There := False; - Trace.Detail ("About to deploy " & Release.Milestone.Image); - Result := Alire.Origins.Deployers.Deploy (Release, Folder); - if not Result.Success then - Raise_Checked_Error (Message (Result)); - end if; - - -- For deployers that do nothing, we ensure the folder exists so all - -- dependencies leave a trace in the cache/dependencies folder, and - -- a place from where to run their actions by default. - - Ada.Directories.Create_Path (Folder); - end if; - - -- Run actions on first retrieval - - if Perform_Actions and then not Was_There then - declare - use Alire.Directories; - Work_Dir : Guard (Enter (Folder)) with Unreferenced; - begin - Alire.Properties.Actions.Executor.Execute_Actions - (Release => Release, - Env => Env, - Moment => Post_Fetch); - end; - end if; - end Deploy_Release; - - ----------------- - -- Deploy_Root -- - ----------------- - - procedure Deploy_Root (Release : Releases.Release; - Parent_Folder : Any_Path; - Env : Properties.Vector; - Generate_Files : Boolean := True; - Perform_Actions : Boolean := True) - is - use Directories; - Was_There : Boolean with Unreferenced; - begin - Alire.Workspace.Deploy_Release - (Release => Release, - Env => Env, - Parent_Folder => Parent_Folder, - Was_There => Was_There, - Perform_Actions => Perform_Actions); - - -- Backup a potentially packaged manifest, so our authoritative manifest - -- from the index is always used. - - declare - Working_Dir : Guard (Enter (Release.Unique_Folder)) - with Unreferenced; - begin - Ada.Directories.Create_Path (Paths.Working_Folder_Inside_Root); - - if GNAT.OS_Lib.Is_Regular_File (Roots.Crate_File_Name) then - Trace.Debug ("Backing up bundled manifest file as *.upstream"); - declare - Upstream_File : constant String := - Paths.Working_Folder_Inside_Root / - (Roots.Crate_File_Name & ".upstream"); - begin - Alire.Directories.Backup_If_Existing - (Upstream_File, - Base_Dir => Paths.Working_Folder_Inside_Root); - Ada.Directories.Rename - (Old_Name => Roots.Crate_File_Name, - New_Name => Upstream_File); - end; - end if; - end; - - -- And generate its working files, if they do not exist - - if Generate_Files then - declare - Working_Dir : Guard (Enter (Release.Unique_Folder)) - with Unreferenced; - Root : constant Alire.Roots.Root := - Alire.Roots.New_Root - (Release.Name, - Ada.Directories.Current_Directory, - Env); - begin - - Ada.Directories.Create_Path (Root.Working_Folder); - - -- Generate the authoritative manifest from index information for - -- eventual use of the gotten crate as a local workspace. - - Workspace.Generate_Manifest - (Release.Whenever (Env), -- TODO: until dynamic export - Root); - - -- Create also a preliminary lockfile (since dependencies are - -- still unretrieved). Once they are checked out, the lockfile - -- will be replaced with the complete solution. - - Lockfiles.Write - ((Solution => (if Release.Dependencies (Env).Is_Empty - then Alire.Solutions.Empty_Valid_Solution - else Alire.Solutions.Empty_Invalid_Solution)), - Filename => Root.Lock_File); - end; - end if; - end Deploy_Root; - - ----------------------- - -- Generate_Manifest -- - ----------------------- - - procedure Generate_Manifest (Release : Releases.Release; - Root : Roots.Root := Alire.Root.Current) - is - begin - Trace.Debug ("Generating " & Release.Name_Str & ".toml file for " - & Release.Milestone.Image & " with" - & Release.Dependencies.Leaf_Count'Img & " dependencies"); - - Directories.Backup_If_Existing - (Root.Crate_File, - Base_Dir => Paths.Working_Folder_Inside_Root); - - Release.To_File (Root.Crate_File, Manifest.Local); - end Generate_Manifest; - - ------------ - -- Update -- - ------------ - - function Update (Environment : Properties.Vector; - Allowed : Containers.Crate_Name_Sets.Set := - Containers.Crate_Name_Sets.Empty_Set; - Options : Solver.Query_Options := - Solver.Default_Options) - return Solutions.Solution - is - Old : constant Solutions.Solution := Root.Current.Solution; - Deps : Conditional.Dependencies := - Root.Current.Release.Dependencies (Environment); - begin - - -- Identify crates that must be held back - - if not Allowed.Is_Empty then - for Release of Old.Releases loop - if not Allowed.Contains (Release.Name) then - Trace.Debug ("Forcing release in solution: " - & Release.Version.Image); - Deps := Release.To_Dependency and Deps; - end if; - end loop; - end if; - - return Solver.Resolve - (Deps => Deps, - Props => Environment, - Current => Old, - Options => Options); - end Update; - - ------------------------------------ - -- Update_And_Deploy_Dependencies -- - ------------------------------------ - - procedure Update_And_Deploy_Dependencies - (Root : Roots.Root := Alire.Root.Current; - Options : Solver.Query_Options := Solver.Default_Options; - Confirm : Boolean := not Utils.User_Input.Not_Interactive) - is - Prev : constant Solutions.Solution := Root.Solution; - Next : constant Solutions.Solution := - Update (Environment => Root.Environment, - Options => Options); - Diff : constant Solutions.Diffs.Diff := Prev.Changes (Next); - begin - if Diff.Contains_Changes then - if not Confirm or else - Utils.User_Input.Confirm_Solution_Changes (Diff) - then - if not Confirm then - Trace.Info ("Changes to dependency solution:"); - Diff.Print (Changed_Only => not Alire.Detailed); - end if; - - Deploy_Dependencies - (Root => Root, - Solution => Next, - Deps_Dir => Root.Dependencies_Dir); - end if; - end if; - - -- Update/Create configuration files - Root.Generate_Configuration; - - end Update_And_Deploy_Dependencies; - -end Alire.Workspace; diff --git a/src/alire/alire-workspace.ads b/src/alire/alire-workspace.ads deleted file mode 100644 index 02c369c1..00000000 --- a/src/alire/alire-workspace.ads +++ /dev/null @@ -1,59 +0,0 @@ -with Alire.Containers; -with Alire.Properties; -with Alire.Releases; -with Alire.Root; -limited with Alire.Roots; -with Alire.Solver; -with Alire.Solutions; -with Alire.Utils.User_Input; - -package Alire.Workspace is - - procedure Deploy_Dependencies - (Root : Roots.Root := Alire.Root.Current; - Solution : Solutions.Solution := Alire.Root.Current.Solution; - Deps_Dir : Absolute_Path := Alire.Root.Current.Dependencies_Dir); - -- Deploy Release dependencies in Solution to Deps_Dir - - procedure Deploy_Root (Release : Releases.Release; - Parent_Folder : Any_Path; - Env : Properties.Vector; - Generate_Files : Boolean := True; - Perform_Actions : Boolean := True); - -- The root release is the one deployed in the working session, the one - -- whose dependencies are needed. For when retrieval is with --only (e.g., - -- in a platform where it is unavailable, but we want to inspect the - -- sources), Generate_Files and Perform_Actions allow disabling these - -- operations that make no sense for the Release on isolation. - - procedure Generate_Manifest (Release : Releases.Release; - Root : Roots.Root := Alire.Root.Current); - -- Generates the crate.toml manifest at the appropriate location for Root - - function Update (Environment : Properties.Vector; - Allowed : Containers.Crate_Name_Sets.Set := - Containers.Crate_Name_Sets.Empty_Set; - Options : Solver.Query_Options := - Solver.Default_Options) - return Solutions.Solution; - -- Compute a new solution for the workspace. If Allowed is not empty, - -- crates not appearing in Allowed are held back at their current version. - -- This function loads configured indexes from disk. - - procedure Update_And_Deploy_Dependencies - (Root : Roots.Root := Alire.Root.Current; - Options : Solver.Query_Options := Solver.Default_Options; - Confirm : Boolean := not Utils.User_Input.Not_Interactive); - -- Call Update and Deploy_Dependencies in succession for the given root - -private - - procedure Deploy_Release - (Release : Alire.Releases.Release; - Env : Properties.Vector; - Parent_Folder : String; - Was_There : out Boolean; - Perform_Actions : Boolean := True); - -- Used internally to deploy a single release, be it root or dependency - -end Alire.Workspace; diff --git a/src/alr/alr-commands-build.adb b/src/alr/alr-commands-build.adb index 4675cfed..b1c2af02 100644 --- a/src/alr/alr-commands-build.adb +++ b/src/alr/alr-commands-build.adb @@ -1,7 +1,6 @@ with Alire.Errors; with Alire.Properties.Actions.Executor; -with Alr.Root; with Alr.Spawn; with Alr.Platform; @@ -12,9 +11,8 @@ package body Alr.Commands.Build is ------------- overriding procedure Execute (Cmd : in out Command) is - pragma Unreferenced (Cmd); begin - if not Execute (Export_Build_Env => True) then + if not Execute (Cmd, Export_Build_Env => True) then Reportaise_Command_Failed ("Compilation failed."); end if; end Execute; @@ -23,20 +21,21 @@ package body Alr.Commands.Build is -- Execute -- ------------- - function Execute (Export_Build_Env : Boolean) return Boolean is + function Execute (Cmd : in out Commands.Command'Class; + Export_Build_Env : Boolean) return Boolean is begin - Requires_Full_Index; + Cmd.Requires_Full_Index; - Requires_Valid_Session; + Cmd.Requires_Valid_Session; if Export_Build_Env then - Alr.Root.Current.Export_Build_Environment; + Cmd.Root.Export_Build_Environment; end if; -- PRE-BUILD ACTIONS begin Alire.Properties.Actions.Executor.Execute_Actions - (Release => Root.Current.Release, + (Release => Cmd.Root.Release, Env => Platform.Properties, Moment => Alire.Properties.Actions.Pre_Build); exception @@ -50,7 +49,7 @@ package body Alr.Commands.Build is begin -- Build all the project files - for Gpr_File of Root.Current.Release.Project_Files + for Gpr_File of Cmd.Root.Release.Project_Files (Platform.Properties, With_Path => True) loop @@ -70,7 +69,7 @@ package body Alr.Commands.Build is -- POST-BUILD ACTIONS begin Alire.Properties.Actions.Executor.Execute_Actions - (Release => Root.Current.Release, + (Release => Cmd.Root.Release, Env => Platform.Properties, Moment => Alire.Properties.Actions.Post_Build); exception diff --git a/src/alr/alr-commands-build.ads b/src/alr/alr-commands-build.ads index 766bac9a..4af19e73 100644 --- a/src/alr/alr-commands-build.ads +++ b/src/alr/alr-commands-build.ads @@ -5,7 +5,8 @@ package Alr.Commands.Build is overriding procedure Execute (Cmd : in out Command); - function Execute (Export_Build_Env : Boolean) return Boolean; + function Execute (Cmd : in out Commands.Command'Class; + Export_Build_Env : Boolean) return Boolean; -- Returns True if compilation succeeded. For invocations after some other -- command that already has set up the build environment we need to avoid -- redoing it, or it results in "variable already set" errors. diff --git a/src/alr/alr-commands-clean.adb b/src/alr/alr-commands-clean.adb index e0d2edd6..d2ba5d0c 100644 --- a/src/alr/alr-commands-clean.adb +++ b/src/alr/alr-commands-clean.adb @@ -3,7 +3,6 @@ with Ada.Directories; with Alire.Utils; with Alr.Paths; -with Alr.Root; with Alr.Spawn; with Alr.Platform; @@ -17,15 +16,15 @@ package body Alr.Commands.Clean is procedure Execute (Cmd : in out Command) is use Alire.Utils; begin - Requires_Valid_Session; + Cmd.Requires_Valid_Session; if not Cmd.Cache then - Alr.Root.Current.Export_Build_Environment; + Cmd.Root.Export_Build_Environment; Trace.Detail ("Cleaning project and dependencies..."); -- Clean all the project files - for Gpr_File of Root.Current.Release.Project_Files + for Gpr_File of Cmd.Root.Release.Project_Files (Platform.Properties, With_Path => True) loop diff --git a/src/alr/alr-commands-edit.adb b/src/alr/alr-commands-edit.adb index 07668c15..3616bb9e 100644 --- a/src/alr/alr-commands-edit.adb +++ b/src/alr/alr-commands-edit.adb @@ -6,7 +6,6 @@ with Alire.OS_Lib.Subprocess; with Alire.Config; with Alr.Platform; -with Alr.Root; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package body Alr.Commands.Edit is @@ -68,11 +67,11 @@ package body Alr.Commands.Edit is ("No editor defined in config key '" & Keys.Editor_Cmd & "'."); end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; - Requires_Valid_Session; + Cmd.Requires_Valid_Session; - Alr.Root.Current.Export_Build_Environment; + Cmd.Root.Export_Build_Environment; declare Exec : constant String := Args.First_Element; @@ -94,7 +93,7 @@ package body Alr.Commands.Edit is declare Project_Files : constant Alire.Utils.String_Vector := - Root.Current.Release.Project_Files + Cmd.Root.Release.Project_Files (Platform.Properties, With_Path => True); begin if Project_Files.Length = 0 then diff --git a/src/alr/alr-commands-get.adb b/src/alr/alr-commands-get.adb index 95f90d3f..94279567 100644 --- a/src/alr/alr-commands-get.adb +++ b/src/alr/alr-commands-get.adb @@ -13,7 +13,6 @@ with Alire.Root; with Alire.Solutions.Diffs; with Alire.Solver; with Alire.Utils.User_Input; -with Alire.Workspace; with Alr.Commands.Build; with Alr.Platform; @@ -29,7 +28,7 @@ package body Alr.Commands.Get is -- Retrieve -- -------------- - procedure Retrieve (Cmd : Command; + procedure Retrieve (Cmd : in out Command; Name : Alire.Crate_Name; Versions : Semver.Extended.Version_Set) is @@ -93,8 +92,7 @@ package body Alr.Commands.Get is (Rel.Dependencies (Platform.Properties), Platform.Properties, Alire.Solutions.Empty_Valid_Solution); - Diff := Alire.Solutions.New_Solution (Platform.Properties) - .Changes (Solution); + Diff := Alire.Solutions.Empty_Valid_Solution.Changes (Solution); if not Solution.Is_Complete then Diff.Print (Changed_Only => False, @@ -123,11 +121,19 @@ package body Alr.Commands.Get is Root_Dir : Alire.Directories.Temp_File := Alire.Directories.With_Name (Rel.Unique_Folder); begin - Alire.Workspace.Deploy_Root - (Rel, - Ada.Directories.Current_Directory, - Platform.Properties, - Perform_Actions => False); + -- Create the Root for the given release, and store it for possible + -- future use. + + Cmd.Set + (Alire.Roots.Create_For_Release + (Rel, + Ada.Directories.Current_Directory, + Platform.Properties, + Perform_Actions => False)); + + -- Set the initial solution we just found + + Cmd.Root.Set (Solution); -- At this point, both crate and lock files must exist and -- be correct, so the working session is correct. Errors with @@ -158,7 +164,7 @@ package body Alr.Commands.Get is -- Check out rest of dependencies and optionally compile - Alire.Workspace.Deploy_Dependencies (Solution => Solution); + Cmd.Root.Deploy_Dependencies; -- Execute the checked out release post_fetch actions, now that -- dependencies are in place. The complete build environment has @@ -170,7 +176,8 @@ package body Alr.Commands.Get is Moment => Alire.Properties.Actions.Post_Fetch); if Cmd.Build then - Build_OK := Commands.Build.Execute (Export_Build_Env => False); + Build_OK := Commands.Build.Execute (Cmd, + Export_Build_Env => False); -- Environment is already set up else Build_OK := True; @@ -302,7 +309,7 @@ package body Alr.Commands.Get is ("--only is incompatible with --build"); end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; if not Alire.Index.Exists (Allowed.Crate) then Reportaise_Command_Failed diff --git a/src/alr/alr-commands-index.adb b/src/alr/alr-commands-index.adb index bc1dd76a..3757d9d5 100644 --- a/src/alr/alr-commands-index.adb +++ b/src/alr/alr-commands-index.adb @@ -12,7 +12,7 @@ package body Alr.Commands.Index is procedure Add (Cmd : Command); - procedure Check; + procedure Check (Cmd : in out Command); procedure List; @@ -105,7 +105,7 @@ package body Alr.Commands.Index is elsif Cmd.Del.all /= "" then Delete (Cmd.Del.all); elsif Cmd.Check then - Check; + Check (Cmd); elsif Cmd.List then List; elsif Cmd.Update_All then @@ -121,10 +121,10 @@ package body Alr.Commands.Index is -- Check -- ----------- - procedure Check is + procedure Check (Cmd : in out Command) is begin Alire.TOML_Expressions.Strict_Enums := True; - Requires_Full_Index; + Cmd.Requires_Full_Index; Alire.Log_Success ("No unknown values found in index contents."); end Check; diff --git a/src/alr/alr-commands-pin.adb b/src/alr/alr-commands-pin.adb index c3c03839..bbf487bf 100644 --- a/src/alr/alr-commands-pin.adb +++ b/src/alr/alr-commands-pin.adb @@ -3,11 +3,9 @@ with Alire.Solutions.Diffs; with Alire.Pinning; with Alire.Utils.TTY; with Alire.Utils.User_Input; -with Alire.Workspace; with Alr.Commands.User_Input; with Alr.Platform; -with Alr.Root; with Semantic_Versioning; @@ -20,7 +18,7 @@ package body Alr.Commands.Pin is -- Change_One_Pin -- -------------------- - procedure Change_One_Pin (Cmd : Command; + procedure Change_One_Pin (Cmd : in out Command; Solution : in out Alire.Solutions.Solution; Target : String) is @@ -37,13 +35,12 @@ package body Alr.Commands.Pin is -- We let to re-pin without checks because the requested version may -- be different. - Requires_Full_Index; + Cmd.Requires_Full_Index; Solution := Alire.Pinning.Pin (Crate => Name, Version => Version, - Dependencies => - Root.Current.Release.Dependencies, + Dependencies => Cmd.Root.Release.Dependencies, Environment => Platform.Properties, Solution => Solution); @@ -61,12 +58,11 @@ package body Alr.Commands.Pin is Reportaise_Command_Failed ("Requested crate is already unpinned"); end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; Solution := Alire.Pinning.Unpin (Crate => Name, - Dependencies => - Root.Current.Release.Dependencies, + Dependencies => Cmd.Root.Release.Dependencies, Environment => Platform.Properties, Solution => Solution); end Unpin; @@ -127,7 +123,8 @@ package body Alr.Commands.Pin is begin if Diff.Contains_Changes then if Alire.Utils.User_Input.Confirm_Solution_Changes (Diff) then - Alire.Workspace.Deploy_Dependencies (Solution => New_Sol); + Cmd.Root.Set (Solution => New_Sol); + Cmd.Root.Deploy_Dependencies; end if; else Trace.Info ("No changes to apply."); @@ -147,12 +144,12 @@ package body Alr.Commands.Pin is ("--use must be used alone with a crate name"); end if; - Requires_Valid_Session; + Cmd.Requires_Valid_Session; -- Listing of pins if not Cmd.Pin_All and then Num_Arguments = 0 then - Root.Current.Solution.Print_Pins; + Cmd.Root.Solution.Print_Pins; return; elsif Num_Arguments > 1 then Reportaise_Wrong_Arguments @@ -162,7 +159,7 @@ package body Alr.Commands.Pin is -- Apply changes; declare - New_Sol : Alire.Solutions.Solution := Root.Current.Solution; + New_Sol : Alire.Solutions.Solution := Cmd.Root.Solution; Old_Sol : constant Alire.Solutions.Solution := New_Sol; begin @@ -180,12 +177,12 @@ package body Alr.Commands.Pin is -- Pin to dir - Requires_Full_Index; -- Next statement recomputes a solution + Cmd.Requires_Full_Index; -- Next statement recomputes a solution New_Sol := Alire.Pinning.Pin_To (+Argument (1), Cmd.URL.all, - Root.Current.Release.Dependencies, + Cmd.Root.Release.Dependencies, Platform.Properties, Old_Sol); diff --git a/src/alr/alr-commands-printenv.adb b/src/alr/alr-commands-printenv.adb index ee41d4fa..d57b411b 100644 --- a/src/alr/alr-commands-printenv.adb +++ b/src/alr/alr-commands-printenv.adb @@ -1,8 +1,6 @@ with Alire.Environment; with Alire.Platforms; -with Alr.Root; - package body Alr.Commands.Printenv is ------------- @@ -22,13 +20,13 @@ package body Alr.Commands.Printenv is Reportaise_Wrong_Arguments ("Specify at most one subcommand"); end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; - Requires_Valid_Session; + Cmd.Requires_Valid_Session; declare Context : constant Alire.Environment.Context := - Alr.Root.Current.Build_Context; + Cmd.Root.Build_Context; begin if Cmd.Details then Context.Print_Details; diff --git a/src/alr/alr-commands-publish.adb b/src/alr/alr-commands-publish.adb index e41c8b48..b67392ab 100644 --- a/src/alr/alr-commands-publish.adb +++ b/src/alr/alr-commands-publish.adb @@ -1,6 +1,5 @@ with Alire.Origins; with Alire.Publish; -with Alire.Roots; with Alire.URI; package body Alr.Commands.Publish is diff --git a/src/alr/alr-commands-run.adb b/src/alr/alr-commands-run.adb index 92669286..6b8149da 100644 --- a/src/alr/alr-commands-run.adb +++ b/src/alr/alr-commands-run.adb @@ -6,7 +6,6 @@ with Alr.Commands.Build; with Alr.Files; with Alr.OS_Lib; with Alr.Platform; -with Alr.Root; with Alr.Utils; with GNAT.OS_Lib; @@ -21,11 +20,12 @@ package body Alr.Commands.Run is -- Check_Report -- ------------------ - procedure Check_Report (Exe_Name : String) is + procedure Check_Report (Cmd : in out Command; + Exe_Name : String) is use Ada.Text_IO; Found_At : constant Utils.String_Vector := - Files.Locate_File_Under (Root.Current.Path, + Files.Locate_File_Under (Cmd.Root.Path, Exe_Name, Max_Depth => Max_Search_Depth); begin Put (" " & Exe_Name); @@ -47,9 +47,9 @@ package body Alr.Commands.Run is overriding procedure Execute (Cmd : in out Command) is use type GNAT.Strings.String_Access; - Name : constant String := Root.Current.Release.Name_Str; + Name : constant String := Cmd.Root.Release.Name_Str; Declared : constant Utils.String_Vector := - Root.Current.Release.Executables (Platform.Properties); + Cmd.Root.Release.Executables (Platform.Properties); ---------- -- List -- @@ -58,8 +58,8 @@ package body Alr.Commands.Run is procedure List is Candidates : constant Utils.String_Vector := Files.Locate_File_Under - (Root.Current.Path, - Root.Current.Release.Default_Executable, + (Cmd.Root.Path, + Cmd.Root.Release.Default_Executable, Max_Depth => Max_Search_Depth); -- Candidate default executable begin @@ -74,30 +74,30 @@ package body Alr.Commands.Run is else Put_Line ("However, the following default executables" & " have been autodetected:"); - Check_Report (Root.Current.Release.Default_Executable); + Check_Report (Cmd, Cmd.Root.Release.Default_Executable); end if; else Put_Line ("Crate " & Name & " builds these executables:"); for Exe of Declared loop - Check_Report (Exe); + Check_Report (Cmd, Exe); end loop; -- Default one: if not Declared.Contains - (Root.Current.Release.Default_Executable) + (Cmd.Root.Release.Default_Executable) and then not Candidates.Is_Empty then Put_Line ("In addition, the following default-named" & " executables have been detected:"); - Check_Report (Root.Current.Release.Default_Executable); + Check_Report (Cmd, Cmd.Root.Release.Default_Executable); end if; end if; end List; begin - Requires_Valid_Session; + Cmd.Requires_Valid_Session; -- Validation if Cmd.List @@ -118,7 +118,7 @@ package body Alr.Commands.Run is declare Declared : Utils.String_Vector; begin - Declared := Root.Current.Release.Executables (Platform.Properties); + Declared := Cmd.Root.Release.Executables (Platform.Properties); -- LISTING -- if Cmd.List then @@ -128,7 +128,7 @@ package body Alr.Commands.Run is -- COMPILATION -- if not Cmd.No_Compile then - if not Commands.Build.Execute (Export_Build_Env => True) then + if not Commands.Build.Execute (Cmd, Export_Build_Env => True) then Reportaise_Command_Failed ("Build failed"); end if; end if; @@ -153,7 +153,7 @@ package body Alr.Commands.Run is if Num_Arguments = 1 and then not Declared.Contains (Argument (1)) - and then Argument (1) /= Root.Current.Release.Default_Executable + and then Argument (1) /= Cmd.Root.Release.Default_Executable then Reportaise_Wrong_Arguments ("The requested executable is not built by this release" @@ -171,7 +171,7 @@ package body Alr.Commands.Run is else (if Declared.Length = 1 then Declared.First_Element - else Root.Current.Release.Default_Executable)); + else Cmd.Root.Release.Default_Executable)); Target : constant String := (if Alire.OS_Lib.Exe_Suffix /= "" @@ -182,7 +182,7 @@ package body Alr.Commands.Run is Target_Exes : Utils.String_Vector := Files.Locate_File_Under - (Root.Current.Path, + (Cmd.Root.Path, Target, Max_Depth => Max_Search_Depth); begin diff --git a/src/alr/alr-commands-search.adb b/src/alr/alr-commands-search.adb index 5b918f2c..4832b6c7 100644 --- a/src/alr/alr-commands-search.adb +++ b/src/alr/alr-commands-search.adb @@ -110,7 +110,7 @@ package body Alr.Commands.Search is ("Search substring and --list are incompatible"); end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; Alire.Index.Search.Print_Crates (Substring => (case Num_Arguments is @@ -152,7 +152,7 @@ package body Alr.Commands.Search is -- End of option verification, start of search. First load the index, -- required to look at its entries. - Requires_Full_Index; + Cmd.Requires_Full_Index; Tab.Append (TTY.Bold ("NAME")); Tab.Append (TTY.Bold ("STATUS")); diff --git a/src/alr/alr-commands-show.adb b/src/alr/alr-commands-show.adb index 3f0f6a79..70f17e23 100644 --- a/src/alr/alr-commands-show.adb +++ b/src/alr/alr-commands-show.adb @@ -12,7 +12,6 @@ with Alire.Solver; with Alire.Utils.Tables; with Alr.Platform; -with Alr.Root; with Semantic_Versioning.Extended; @@ -29,7 +28,7 @@ package body Alr.Commands.Show is Versions : Semver.Extended.Version_Set; Current : Boolean; -- session or command-line requested release - Cmd : Command) + Cmd : in out Command) is begin if Current then @@ -43,7 +42,7 @@ package body Alr.Commands.Show is Rel : constant Alire.Releases.Release := (if Current - then Root.Current.Release + then Cmd.Root.Release else Query.Find (Name, Versions, Query_Policy)); begin if Cmd.System then @@ -60,7 +59,7 @@ package body Alr.Commands.Show is declare Needed : constant Query.Solution := (if Current - then Root.Current.Solution + then Cmd.Root.Solution else Query.Resolve (Rel.Dependencies (Platform.Properties), Platform.Properties, @@ -167,7 +166,8 @@ package body Alr.Commands.Show is -- Report_Jekyll -- ------------------- - procedure Report_Jekyll (Name : Alire.Crate_Name; + procedure Report_Jekyll (Cmd : in out Command; + Name : Alire.Crate_Name; Versions : Semver.Extended.Version_Set; Current : Boolean) is @@ -175,7 +175,7 @@ package body Alr.Commands.Show is declare Rel : constant Alire.Releases.Release := (if Current - then Root.Current.Release + then Cmd.Root.Release else Query.Find (Name, Versions, Query_Policy)); begin Put_Line ("---"); @@ -209,7 +209,7 @@ package body Alr.Commands.Show is Reportaise_Wrong_Arguments ("Cannot proceed without a crate name"); else - Requires_Valid_Session; + Cmd.Requires_Valid_Session; end if; end if; @@ -223,7 +223,7 @@ package body Alr.Commands.Show is if Num_Arguments = 1 or else Cmd.Graph or else Cmd.Solve or else Cmd.Tree then - Requires_Full_Index; + Cmd.Requires_Full_Index; end if; declare @@ -231,7 +231,7 @@ package body Alr.Commands.Show is (if Num_Arguments = 1 then Alire.Milestones.Crate_Versions (Argument (1)) else Alire.Milestones.Crate_Versions - (Root.Current.Release.Milestone.Image)); + (Cmd.Root.Release.Milestone.Image)); begin if Num_Arguments = 1 and not Alire.Index.Exists (Allowed.Crate) then raise Alire.Query_Unsuccessful; @@ -243,7 +243,8 @@ package body Alr.Commands.Show is -- Execute if Cmd.Jekyll then - Report_Jekyll (Allowed.Crate, + Report_Jekyll (Cmd, + Allowed.Crate, Allowed.Versions, Num_Arguments = 0); elsif Cmd.External then diff --git a/src/alr/alr-commands-test.adb b/src/alr/alr-commands-test.adb index f2cad458..6099899b 100644 --- a/src/alr/alr-commands-test.adb +++ b/src/alr/alr-commands-test.adb @@ -511,7 +511,7 @@ package body Alr.Commands.Test is end if; end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; -- Pre-find candidates to not have duplicate tests if overlapping -- requested. diff --git a/src/alr/alr-commands-update.adb b/src/alr/alr-commands-update.adb index 6b4fae3b..64527ff5 100644 --- a/src/alr/alr-commands-update.adb +++ b/src/alr/alr-commands-update.adb @@ -3,7 +3,6 @@ with Alire.Errors; with Alire.Utils.User_Input; with Alr.Commands.Index; -with Alr.Root; package body Alr.Commands.Update is @@ -34,7 +33,7 @@ package body Alr.Commands.Update is end Parse_Allowed; begin - Requires_Valid_Session (Sync => False); + Cmd.Requires_Valid_Session (Sync => False); -- The user has explicitly requested an update, so it makes no sense to -- sync previously, or the update would never find changes. @@ -42,9 +41,9 @@ package body Alr.Commands.Update is Index.Update_All; end if; - Requires_Full_Index; + Cmd.Requires_Full_Index; - Root.Current.Update_Dependencies + Cmd.Root.Update_Dependencies (Allowed => Parse_Allowed, Options => (Age => Query_Policy, others => <>), diff --git a/src/alr/alr-commands-version.adb b/src/alr/alr-commands-version.adb index d5bb7c32..ea2fa310 100644 --- a/src/alr/alr-commands-version.adb +++ b/src/alr/alr-commands-version.adb @@ -8,7 +8,6 @@ with Alr.Bootstrap; with Alr.Files; with Alr.OS_Lib; with Alr.Paths; -with Alr.Root; with GNAT.Compiler_Version; with GNAT.Source_Info; @@ -22,9 +21,7 @@ package body Alr.Commands.Version is ------------- overriding procedure Execute (Cmd : in out Command) is - pragma Unreferenced (Cmd); use Ada.Text_IO; - Root : constant Alire.Roots.Optional.Root := Alr.Root.Current; use all type Alire.Roots.Optional.States; begin Trace.Always ("Alr version: " & Alr.Version); @@ -38,14 +35,14 @@ package body Alr.Commands.Version is & " force:" & Alire.Force'Img & " not-interactive:" & Alire.Utils.User_Input.Not_Interactive'Img); - case Root.Status is + case Cmd.Optional_Root.Status is when Outside => Trace.Always ("alr root is empty"); when Broken => Trace.Always ("alr root has invalid metadata: " - & Alire.Utils.TTY.Error (Root.Message)); + & Alire.Utils.TTY.Error (Cmd.Optional_Root.Message)); when Valid => - Trace.Always ("alr root is " & Root.Value.Release.Milestone.Image); + Trace.Always ("alr root is " & Cmd.Root.Release.Milestone.Image); end case; declare @@ -56,7 +53,7 @@ package body Alr.Commands.Version is Trace.Always ("alr is finding" & Files.Locate_Any_GPR_File'Img & " GPR project files"); Trace.Always - ("alr session state is [" & Root.Status'Img & "]"); + ("alr session state is [" & Cmd.Optional_Root.Status'Img & "]"); end; Log ("alr compiled on [" & diff --git a/src/alr/alr-commands-withing.adb b/src/alr/alr-commands-withing.adb index 8b6f8162..9f12c04a 100644 --- a/src/alr/alr-commands-withing.adb +++ b/src/alr/alr-commands-withing.adb @@ -14,12 +14,10 @@ with Alire.Roots.Optional; with Alire.Solutions; with Alire.Solver; with Alire.Utils.User_Input; -with Alire.Workspace; with Alr.Commands.User_Input; with Alr.OS_Lib; with Alr.Platform; -with Alr.Root; with Alr.Utils.Auto_GPR_With; with Semantic_Versioning.Extended; @@ -31,22 +29,23 @@ package body Alr.Commands.Withing is Switch_URL : constant String := "--use"; procedure Replace_Current - (Old_Deps, + (Cmd : in out Command; + Old_Deps, New_Deps : Alire.Conditional.Dependencies; - Old_Solution : Alire.Solutions.Solution := Root.Current.Solution); + Old_Solution : Alire.Solutions.Solution); ------------------- -- Auto_GPR_With -- ------------------- - procedure Auto_GPR_With is + procedure Auto_GPR_With (Cmd : in out Command) is begin - for File of Root.Current.Release.Project_Files - (Root.Current.Environment, With_Path => True) + for File of Cmd.Root.Release.Project_Files + (Cmd.Root.Environment, With_Path => True) loop Utils.Auto_GPR_With.Update - (Alire.OS_Lib."/" (Root.Current.Path, File), - Root.Current.Direct_Withs (Root.Current.Release)); + (Alire.OS_Lib."/" (Cmd.Root.Path, File), + Cmd.Root.Direct_Withs (Cmd.Root.Release)); end loop; end Auto_GPR_With; @@ -93,7 +92,8 @@ package body Alr.Commands.Withing is -- Add_Softlink -- ------------------ - procedure Add_Softlink (Dep_Spec : String; + procedure Add_Softlink (Cmd : in out Command; + Dep_Spec : String; Path : String) is Requested : constant Alire.Milestones.Allowed_Milestones := Alire.Milestones.Crate_Versions (Dep_Spec); @@ -104,8 +104,8 @@ package body Alr.Commands.Withing is use Alire; use type Conditional.Dependencies; Old_Deps : constant Conditional.Dependencies := - Root.Current.Release.Dependencies; - Old_Solution : constant Solutions.Solution := Root.Current.Solution; + Cmd.Root.Release.Dependencies; + Old_Solution : constant Solutions.Solution := Cmd.Root.Solution; New_Solution : constant Solutions.Solution := Old_Solution .Depending_On (New_Dep) @@ -131,7 +131,8 @@ package body Alr.Commands.Withing is -- and storing the softlink. We can proceed to confirming the -- replacement. - Replace_Current (Old_Deps => Old_Deps, + Replace_Current (Cmd, + Old_Deps => Old_Deps, New_Deps => Old_Deps and New_Dep, Old_Solution => New_Solution); -- We use the New_Solution with the softlink as previous solution, so @@ -144,7 +145,7 @@ package body Alr.Commands.Withing is -- Detect_Softlink -- --------------------- - procedure Detect_Softlink (Path : String) is + procedure Detect_Softlink (Cmd : in out Command; Path : String) is Root : constant Alire.Roots.Optional.Root := Alire.Roots.Optional.Detect_Root (Path); use all type Semver.Point; @@ -154,7 +155,8 @@ package body Alr.Commands.Withing is -- Add a dependency on ^(detected version) (i.e., safely -- upgradable) or ~(detected version) (if pre-1.0). Add_Softlink - (Dep_Spec => Root.Value.Release.Name_Str + (Cmd, + Dep_Spec => Root.Value.Release.Name_Str & (if Semver.Major (Root.Value.Release.Version) = 0 then "~" else "^") @@ -229,19 +231,20 @@ package body Alr.Commands.Withing is --------------------- procedure Replace_Current - (Old_Deps, + (Cmd : in out Command; + Old_Deps, New_Deps : Alire.Conditional.Dependencies; - Old_Solution : Alire.Solutions.Solution := Root.Current.Solution) + Old_Solution : Alire.Solutions.Solution) is begin - Requires_Full_Index; + Cmd.Requires_Full_Index; -- Set, regenerate and update declare New_Root : constant Alire.Roots.Root := Alire.Roots.New_Root - (Root.Current.Release.Replacing (Dependencies => New_Deps), - Root.Current.Path, + (Cmd.Root.Release.Replacing (Dependencies => New_Deps), + Cmd.Root.Path, Platform.Properties); New_Solution : constant Alire.Solutions.Solution := Alire.Solver.Resolve @@ -282,7 +285,7 @@ package body Alr.Commands.Withing is -- Show the effects on the solution if not Alire.Utils.User_Input.Confirm_Solution_Changes - (Root.Current.Solution.Changes (New_Solution), + (Cmd.Root.Solution.Changes (New_Solution), Changed_Only => not Alire.Detailed) then Trace.Info ("No changes applied."); @@ -291,19 +294,19 @@ package body Alr.Commands.Withing is -- Add changes to the manifest: - Alire.Manifest.Append (Root.Current.Crate_File, + Alire.Manifest.Append (Cmd.Root.Crate_File, Deps_Diff.Added); - Alire.Manifest.Remove (Root.Current.Crate_File, + Alire.Manifest.Remove (Cmd.Root.Crate_File, Deps_Diff.Removed); Trace.Detail ("Manifest updated, fetching dependencies now"); -- And apply changes (will also generate new lockfile) - Alire.Workspace.Deploy_Dependencies - (Root => New_Root, - Solution => New_Solution); + Cmd.Set (New_Root); + Cmd.Root.Set (Solution => New_Solution); + Cmd.Root.Deploy_Dependencies; - Auto_GPR_With; + Cmd.Auto_GPR_With; end; end Replace_Current; @@ -312,9 +315,9 @@ package body Alr.Commands.Withing is -- Add -- --------- - procedure Add is + procedure Add (Cmd : in out Command) is Old_Deps : constant Alire.Conditional.Dependencies := - Root.Current.Release.Dependencies; + Cmd.Root.Release.Dependencies; New_Deps : Alire.Conditional.Dependencies := Old_Deps; use type Alire.Conditional.Dependencies; begin @@ -323,7 +326,7 @@ package body Alr.Commands.Withing is end loop; if Old_Deps /= New_Deps then - Replace_Current (Old_Deps, New_Deps); + Cmd.Replace_Current (Old_Deps, New_Deps, Cmd.Root.Solution); end if; end Add; @@ -331,9 +334,9 @@ package body Alr.Commands.Withing is -- Del -- --------- - procedure Del is + procedure Del (Cmd : in out Command) is Old_Deps : constant Alire.Conditional.Dependencies := - Root.Current.Release.Dependencies; + Cmd.Root.Release.Dependencies; New_Deps : Alire.Conditional.Dependencies := Old_Deps; use type Alire.Conditional.Dependencies; begin @@ -342,7 +345,7 @@ package body Alr.Commands.Withing is end loop; if Old_Deps /= New_Deps then - Replace_Current (Old_Deps, New_Deps); + Cmd.Replace_Current (Old_Deps, New_Deps, Cmd.Root.Solution); else Trace.Warning ("There are no changes to apply."); end if; @@ -352,7 +355,7 @@ package body Alr.Commands.Withing is -- From -- ---------- - procedure From is + procedure From (Cmd : in out Command) is use Ada.Text_IO; use Utils; @@ -436,8 +439,10 @@ package body Alr.Commands.Withing is end loop; if not Deps.Is_Empty then - Replace_Current (Old_Deps => Alire.Conditional.No_Dependencies, - New_Deps => Deps); + Cmd.Replace_Current + (Old_Deps => Alire.Conditional.No_Dependencies, + New_Deps => Deps, + Old_Solution => Alire.Solutions.Empty_Valid_Solution); else Trace.Warning ("No dependencies found."); end if; @@ -447,8 +452,8 @@ package body Alr.Commands.Withing is -- List -- ---------- - procedure List (Cmd : Command) is - Root_Release : constant Alire.Releases.Release := Root.Current.Release; + procedure List (Cmd : in out Command) is + Root_Release : constant Alire.Releases.Release := Cmd.Root.Release; begin Put_Line ("Dependencies (direct):"); Root_Release.Dependencies.Print (" ", @@ -456,11 +461,11 @@ package body Alr.Commands.Withing is Sorted => True); if Cmd.Solve then - Requires_Full_Index; -- Load possible hints - Root.Current.Solution.Print (Root_Release, - Platform.Properties, - Detailed => True, - Level => Always); + Cmd.Requires_Full_Index; -- Load possible hints + Cmd.Root.Solution.Print (Root_Release, + Platform.Properties, + Detailed => True, + Level => Always); end if; end List; @@ -484,7 +489,7 @@ package body Alr.Commands.Withing is end Check; begin - Requires_Valid_Session; + Cmd.Requires_Valid_Session; if Cmd.URL.all /= "" then Flags := Flags + 1; @@ -505,15 +510,14 @@ package body Alr.Commands.Withing is List (Cmd); return; elsif Cmd.Tree then - Root.Current.Solution.Print_Tree (Root.Current.Release); + Cmd.Root.Solution.Print_Tree (Cmd.Root.Release); return; elsif Cmd.Graph then - Root.Current.Solution.Print_Graph - (Root.Current.Release, Platform.Properties); + Cmd.Root.Solution.Print_Graph + (Cmd.Root.Release, Platform.Properties); return; elsif Cmd.Versions then - Requires_Full_Index; - Root.Current.Solution.Print_Versions (Root.Current); + Cmd.Root.Solution.Print_Versions (Cmd.Root); return; end if; end if; @@ -533,21 +537,23 @@ package body Alr.Commands.Withing is if Cmd.URL.all /= "" then if Num_Arguments = 1 then - Add_Softlink (Dep_Spec => Argument (1), + Add_Softlink (Cmd, + Dep_Spec => Argument (1), Path => Cmd.URL.all); else - Detect_Softlink (Cmd.URL.all); + Detect_Softlink (Cmd, + Cmd.URL.all); end if; else - Requires_Full_Index; - Add; + Cmd.Requires_Full_Index; + Cmd.Add; end if; elsif Cmd.Del then - Del; + Del (Cmd); elsif Cmd.From then - Requires_Full_Index; - From; + Cmd.Requires_Full_Index; + From (Cmd); else raise Program_Error with "List should have already happened"; end if; diff --git a/src/alr/alr-commands.adb b/src/alr/alr-commands.adb index be341bb1..44a9cbcc 100644 --- a/src/alr/alr-commands.adb +++ b/src/alr/alr-commands.adb @@ -15,7 +15,7 @@ with Alire.Features.Index; with Alire.Lockfiles; with Alire.Paths; with Alire.Platforms; -with Alire.Roots.Optional; +with Alire.Root; with Alire.Solutions; with Alire.Utils.Tables; with Alire.Utils.TTY; @@ -41,7 +41,6 @@ with Alr.Commands.Update; with Alr.Commands.Version; with Alr.Commands.Withing; with Alr.Platform; -with Alr.Root; with GNAT.Command_Line.Extra; with GNAT.OS_Lib; @@ -522,7 +521,9 @@ package body Alr.Commands is -- Requires_Full_Index -- ------------------------- - procedure Requires_Full_Index (Force_Reload : Boolean := False) is + procedure Requires_Full_Index (Cmd : in out Command'Class; + Force_Reload : Boolean := False) is + pragma Unreferenced (Cmd); begin Alire.Features.Index.Setup_And_Load (From => Alire.Config.Edit.Indexes_Directory, @@ -533,7 +534,8 @@ package body Alr.Commands is -- Requires_Valid_Session -- ---------------------------- - procedure Requires_Valid_Session (Sync : Boolean := True) is + procedure Requires_Valid_Session (Cmd : in out Command'Class; + Sync : Boolean := True) is use Alire; ------------------------------ @@ -551,12 +553,25 @@ package body Alr.Commands is end if; end Notify_Of_Initialization; - Unchecked : constant Alire.Roots.Optional.Root := Root.Current; + Unchecked : Alire.Roots.Optional.Root renames Cmd.Optional_Root; Manual_Only : constant Boolean := Alire.Config.Get (Alire.Config.Keys.Update_Manually, False); begin + + -- If the root has been already loaded, then all following checks have + -- been already performed, and we are done: + + if Cmd.Optional_Root.Is_Valid then + Trace.Debug ("Workspace is valid [already loaded]"); + return; + end if; + + Trace.Debug ("Workspace is being checked and loaded for the first time"); + + Unchecked := Alire.Root.Current; + if not Unchecked.Is_Valid then Raise_Checked_Error (Alire.Errors.Wrap @@ -566,7 +581,7 @@ package body Alr.Commands is Unchecked.Value.Check_Stored; declare - Checked : constant Roots.Root := Unchecked.Value; + Checked : Roots.Root := Unchecked.Value; begin -- For workspaces created pre-lockfiles, or with older format, @@ -592,7 +607,7 @@ package body Alr.Commands is if Checked.Solution.Is_Attempted then -- Check deps on disk match those in lockfile - Requires_Full_Index; + Cmd.Requires_Full_Index; Checked.Sync_Solution_And_Deps; return; else @@ -650,7 +665,7 @@ package body Alr.Commands is -- upcoming) we are done. Otherwise, do a silent update. if Sync then - Requires_Full_Index; + Cmd.Requires_Full_Index; Checked.Update_Dependencies (Silent => True); end if; end; @@ -966,4 +981,30 @@ package body Alr.Commands is .Append ("crate~version" & ASCII.HT & "Minor-compatible version"); end Crate_Version_Sets; + ---------- + -- Root -- + ---------- + + function Root (Cmd : in out Command'Class) + return Alire.Roots.Optional.Reference + is + begin + if not Cmd.Optional_Root.Is_Valid then + Cmd.Requires_Valid_Session; + end if; + + return Cmd.Optional_Root.Value; + end Root; + + --------- + -- Set -- + --------- + + procedure Set (Cmd : in out Command'Class; + Root : Alire.Roots.Root) + is + begin + Cmd.Optional_Root := Alire.Roots.Optional.Outcome_Success (Root); + end Set; + end Alr.Commands; diff --git a/src/alr/alr-commands.ads b/src/alr/alr-commands.ads index a56ce35c..e9236b96 100644 --- a/src/alr/alr-commands.ads +++ b/src/alr/alr-commands.ads @@ -1,6 +1,7 @@ with GNAT.Command_Line; with Alire.Directories; +with Alire.Roots.Optional; with Alire.Solver; with Alire.Utils; @@ -28,7 +29,7 @@ package Alr.Commands is -- Command -- ------------- - type Command is limited interface; + type Command is abstract tagged limited private; -- This type encapsulates configuration and execution of a specific -- command. It also has help-related subprograms. Help is structured as: -- 1. SUMMARY, showing @@ -80,13 +81,27 @@ package Alr.Commands is -- Supporting subprograms for commands -- ----------------------------------------- - procedure Requires_Full_Index (Force_Reload : Boolean := False); + function Root (Cmd : in out Command'Class) + return Alire.Roots.Optional.Reference; + -- Using this call will ensure the Root detection has been attempted + + procedure Set (Cmd : in out Command'Class; + Root : Alire.Roots.Root); + -- Replace the current root in use by the command. Modifying the root via + -- the Cmd.Root reference is valid and intended usage that does not require + -- resetting the root. + + procedure Requires_Full_Index (Cmd : in out Command'Class; + Force_Reload : Boolean := False); -- Unless Force_Reload, if the index is not empty we no nothing - procedure Requires_Valid_Session (Sync : Boolean := True); - -- Verifies that a valid working dir is in scope. If Sync, enforce that the - -- manifest, lockfile and dependencies on disk are in sync, by performing - -- a silent update. If not Sync, only a minimal empty lockfile is created. + procedure Requires_Valid_Session (Cmd : in out Command'Class; + Sync : Boolean := True); + -- Verifies that a valid working dir is in scope. After calling it, + -- Cmd.Root will be usable if alr was run inside a Root. If Sync, enforce + -- that the manifest, lockfile and dependencies on disk are in sync, by + -- performing a silent update. If not Sync, only a minimal empty lockfile + -- is created. --------------------------- -- command-line helpers -- @@ -166,6 +181,10 @@ package Alr.Commands is private + type Command is abstract tagged limited record + Optional_Root : Alire.Roots.Optional.Root; + end record; + -- Facilities for command/argument identification. These are available to -- commands. diff --git a/src/alr/alr-root.ads b/src/alr/alr-root.ads deleted file mode 100644 index be11f00e..00000000 --- a/src/alr/alr-root.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Alire.Root; - -package Alr.Root renames Alire.Root; diff --git a/testsuite/tests/workflows/action-command/test.py b/testsuite/tests/workflows/action-command/test.py index 4818fe71..99d731e7 100644 --- a/testsuite/tests/workflows/action-command/test.py +++ b/testsuite/tests/workflows/action-command/test.py @@ -1,5 +1,5 @@ """ -Test invalid command TOML type +Test pre-build/post-build/post-fetch executions """ from drivers.alr import run_alr -- 2.39.5