bugfix: pin loading from out-of-root paths (#1699)

* Fix bug in pin loading from out-of-root paths

* Self-review

src/alire/alire-lockfiles.adb

@@ -57,7 +57,11 @@ package body Alire.Lockfiles is
    -- Read --
    ----------
 
-   function Read (Filename : Absolute_Path) return Contents is
+   function Read (Root, Filename : Absolute_Path) return Contents is
+      --  Enter the workspace root for this lockfile, so any
+      --  relative pin paths can be properly resolved.
+      use Alire.Directories;
+      CWD : Guard (Enter (Root)) with Unreferenced;
    begin
       Trace.Debug ("Reading persistent contents from " & Filename);
 
@@ -93,7 +97,7 @@ package body Alire.Lockfiles is
    -- Validity --
    --------------
 
-   function Validity (File : Any_Path) return Validities is
+   function Validity (Root, File : Absolute_Path) return Validities is
    begin
       if not GNAT.OS_Lib.Is_Read_Accessible_File (File) then
          return Missing;
@@ -102,7 +106,7 @@ package body Alire.Lockfiles is
       --  Try to load to assess validity
 
       declare
-         Unused : constant Contents := Read (File);
+         Unused : constant Contents := Read (Root, File);
       begin
          return Valid;
       end;

src/alire/alire-lockfiles.ads

@@ -27,11 +27,11 @@ package Alire.Lockfiles is
    --  Return the location /path/to/crate/dir/alire.lock, filename included,
    --  given the root directory where the crate is deployed.
 
-   function Read (Filename : Absolute_Path) return Contents;
-   --  Read contents from the given lockfile
+   function Read (Root, Filename : Absolute_Path) return Contents;
+   --  Read contents from the given lockfile, for a crate rooted at Root
 
-   function Validity (File : Any_Path) return Validities;
-   --  Check if given file is a valid lockfile
+   function Validity (Root, File : Absolute_Path) return Validities;
+   --  Check if given file is a valid lockfile, for a crate at Root
 
    procedure Write (Contents : Lockfiles.Contents;
                     Filename : Absolute_Path);

src/alire/alire-manifest.adb

@@ -53,11 +53,14 @@ package body Alire.Manifest is
    -- Is_Valid --
    --------------
 
-   function Is_Valid (Name : Any_Path; Source : Sources) return Boolean is
+   function Is_Valid (Name   : Any_Path;
+                      Source : Sources;
+                      Root   : Any_Path := "")
+                      return Boolean is
    begin
       --  Check we are able to load the manifest file
       if Releases.From_Manifest
-        (Name, Source, Strict => False).Version_Image /= ""
+        (Name, Source, Strict => False, Root_Path => Root).Version_Image /= ""
       then
          Trace.Debug ("Checked valid manifest at " & Name);
          return True;

src/alire/alire-manifest.ads

@@ -27,7 +27,12 @@ package Alire.Manifest is
    --  As removal of dependencies, but for pins. If the pin is not found, or
    --  it cannot be safely removed, it will raise.
 
-   function Is_Valid (Name : Any_Path; Source : Sources) return Boolean;
-   --  Check that the given Name is a loadable manifest
+   function Is_Valid (Name   : Any_Path;
+                      Source : Sources;
+                      Root   : Any_Path := "")
+                      return Boolean
+     with Pre => Source /= Local or else Check_Absolute_Path (Root);
+   --  Check that the given Name is a loadable manifest. For a local manifest
+   --  that may contain links, we need the root path.
 
 end Alire.Manifest;

src/alire/alire-publish.adb

@@ -41,6 +41,7 @@ with TOML_Slicer;
 
 package body Alire.Publish is
 
+   package Adirs renames Ada.Directories;
    package Semver renames Semantic_Versioning;
 
    use all type UString;
@@ -390,7 +391,8 @@ package body Alire.Publish is
          Check_Release (Releases.From_Manifest
                           (Starting_Manifest (Context),
                            Alire.Manifest.Local,
-                           Strict => True));
+                           Strict    => True,
+                           Root_Path => Adirs.Full_Name (+Context.Path)));
          --  Will have raised if the release is not loadable or incomplete
       else
          declare
@@ -612,7 +614,8 @@ package body Alire.Publish is
 
    procedure Prepare_Archive (Context : in out Data) with
      Pre => Alire.Manifest.Is_Valid (Context.Options.Manifest,
-                                     Alire.Manifest.Local);
+                                     Alire.Manifest.Local,
+                                     Adirs.Full_Name (+Context.Path));
    --  Prepare a tar file either using git archive (if git repo detected) or
    --  plain tar otherwise.
 
@@ -622,9 +625,11 @@ package body Alire.Publish is
       Target_Dir : constant Relative_Path :=
                      Paths.Working_Folder_Inside_Root / "archives";
       Release    : constant Releases.Release :=
-                     Releases.From_Manifest (Context.Options.Manifest,
-                                             Alire.Manifest.Local,
-                                             Strict => True);
+                     Releases.From_Manifest
+                       (Context.Options.Manifest,
+                        Alire.Manifest.Local,
+                        Strict    => True,
+                        Root_Path => Adirs.Full_Name (+Context.Path));
       Milestone  : constant String :=
                      TOML_Index.Manifest_File (Release.Name,
                                                Release.Version,
@@ -788,7 +793,8 @@ package body Alire.Publish is
                     .From_Manifest
                       (Packaged_Manifest (Context),
                        Alire.Manifest.Local,
-                       Strict => True)
+                       Strict    => True,
+                       Root_Path => Adirs.Full_Name (+Context.Path))
                     .Replacing (Origin => Context.Origin);
    begin
       Check_Release (Release);

src/alire/alire-releases.adb

@@ -966,9 +966,17 @@ package body Alire.Releases is
 
    function From_Manifest (File_Name : Any_Path;
                            Source    : Manifest.Sources;
-                           Strict    : Boolean)
+                           Strict    : Boolean;
+                           Root_Path : Any_Path := "")
                            return Release
    is
+      --  Move to file base dir, as relative paths in pins are resolved during
+      --  loading relative to CWD.
+      CWD : Directories.Guard
+        (if Root_Path /= "" then
+            Directories.Enter (Root_Path)
+         else
+            Directories.Stay) with Unreferenced;
    begin
       return From_TOML
         (TOML_Adapters.From

src/alire/alire-releases.ads

@@ -323,8 +323,12 @@ package Alire.Releases is
 
    function From_Manifest (File_Name : Any_Path;
                            Source    : Manifest.Sources;
-                           Strict    : Boolean)
-                           return Release;
+                           Strict    : Boolean;
+                           Root_Path : Any_Path := "")
+                           return Release
+     with Pre => Source in Manifest.Index or else Root_Path in Absolute_Path;
+   --  When loading a manifest for a workspace, it may contain pins that we
+   --  must resolve relative to Root_Path.
 
    function From_TOML (From   : TOML_Adapters.Key_Queue;
                        Source : Manifest.Sources;

src/alire/alire-roots-optional.adb

@@ -51,9 +51,11 @@ package body Alire.Roots.Optional is
                   return This : constant Root :=
                     Outcome_Success
                       (Roots.New_Root
-                         (R    => Releases.From_Manifest (Crate_File,
-                                                          Manifest.Local,
-                                                          Strict => True),
+                         (R    => Releases.From_Manifest
+                            (Crate_File,
+                             Manifest.Local,
+                             Strict    => True,
+                             Root_Path => Directories.Current),
                           Path => Directories.Current,
                           Env  => Alire.Root.Platform_Properties))
                   do

src/alire/alire-roots.adb

@@ -1177,7 +1177,9 @@ package body Alire.Roots is
          return
            "Expected ordinary manifest file but found a: "
            & Kind (This.Crate_File)'Img;
-      elsif not Alire.Manifest.Is_Valid (This.Crate_File, Alire.Manifest.Local)
+      elsif not Alire.Manifest.Is_Valid (This.Crate_File,
+                                         Alire.Manifest.Local,
+                                         Path (This))
       then
          return "Manifest is not loadable: " & This.Crate_File;
       end if;
@@ -1201,6 +1203,11 @@ package body Alire.Roots is
    ------------------------------
 
    procedure Export_Build_Environment (This : in out Root) is
+      CWD : Directories.Guard (Directories.Enter (Path (This)))
+        with Unreferenced;
+      --  Required as this function gets called sometimes directly from
+      --  commands that may not have relocated to the crate root.
+
       Context : Alire.Environment.Context;
    begin
       Alire.Environment.Loading.Load (Context, This);
@@ -1342,6 +1349,15 @@ package body Alire.Roots is
 
    function Solution (This : in out Root) return Solutions.Solution
    is
+      --  Enter the lockfile parent dir, which will be the crate root, so any
+      --  relative pin paths can be properly resolved, if the lockfile is not
+      --  yet loaded.
+      use Alire.Directories;
+      CWD : Guard (if This.Cached_Solution.Has_Element
+                   then Stay
+                   else Enter (Parent (Parent (This.Lock_File))))
+        with Unreferenced;
+
       Result : constant Cached_Solutions.Cached_Info
         := This.Cached_Solution.Element (This.Lock_File);
    begin
@@ -1650,9 +1666,10 @@ package body Alire.Roots is
          --  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)));
+         (if Check_Valid then
+            Lockfiles.Validity (Path (This), This.Lock_File) in Lockfiles.Valid
+          else
+            Ada.Directories.Exists (This.Lock_File)));
 
    --------------------------
    -- Is_Lockfile_Outdated --
@@ -2023,7 +2040,8 @@ package body Alire.Roots is
         (Releases.From_Manifest
            (This.Crate_File,
             Manifest.Local,
-            Strict => True));
+            Strict    => True,
+            Root_Path => Path (This)));
 
       --  And our pins
 

src/alire/alire-roots.ads

@@ -374,7 +374,8 @@ private
    --  triggered when doing This.Configuration here.
 
    function Load_Solution (Lockfile : Absolute_Path) return Solutions.Solution
-   is (Lockfiles.Read (Lockfile).Solution);
+   is (Lockfiles.Read (Directories.Current, Lockfile).Solution);
+   --  Note that this function requires CWD to already be the crate root
 
    procedure Write_Solution (Solution : Solutions.Solution;
                              Lockfile : Absolute_Path);

src/alire/alire-user_pins.adb

@@ -408,6 +408,12 @@ package body Alire.User_Pins is
                   Result.Path :=
                     +Utils.User_Input.To_Absolute_From_Portable
                     (This.Checked_Pop (Keys.Path, TOML_String).As_String);
+
+                  if not GNAT.OS_Lib.Is_Directory (+Result.Path) then
+                     This.Recoverable_Error
+                       ("Pin path is not a valid directory: "
+                        & (+Result.Path));
+                  end if;
                end return;
             end if;
          end From_Lockfile;

src/alr/alr-commands.adb

@@ -363,7 +363,7 @@ package body Alr.Commands is
          --  For workspaces created pre-lockfiles, or with older format,
          --  recreate:
 
-         case Lockfiles.Validity (Checked.Lock_File) is
+         case Lockfiles.Validity (Checked.Path, Checked.Lock_File) is
             when Lockfiles.Valid =>
                Trace.Debug ("Lockfile at " & Checked.Lock_File & " is valid");
 

testsuite/tests/printenv/out-of-root/test.py

@@ -0,0 +1,30 @@
+"""
+Verify that printenv output is correct for regular and pinned crates when
+invoked not from the root of the workspace.
+"""
+
+import os
+import re
+from drivers.alr import alr_pin, init_local_crate, run_alr
+from drivers.asserts import assert_eq, assert_match
+
+parent = os.getcwd()
+
+init_local_crate("base")
+init_local_crate("pinned", enter=False)
+alr_pin("pinned", path="pinned")
+
+os.chdir("src") # Enter a subfolder
+p = run_alr("printenv")
+
+# Verify root crate proper path in GPR_PROJECT_PATH
+assert_match(r".*GPR_PROJECT_PATH[^\n]+"
+             + re.escape(os.path.join(parent, "base"))
+             + "(:|;|\")", p.out)
+
+# Verify pinned crate proper path in GPR_PROJECT_PATH
+assert_match(r".*GPR_PROJECT_PATH[^\n]+"
+             + re.escape(os.path.join(parent, "base", "pinned"))
+             + "(:|;|\")", p.out)
+
+print("SUCCESS")

testsuite/tests/printenv/out-of-root/test.yaml

@@ -0,0 +1,4 @@
+driver: python-script
+build_mode: both
+indexes:
+    compiler_only_index: {}