From 205ba02b3f80f27c0ea0aeb0fe519c736bddc07f Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Wed, 23 Jun 2021 12:15:18 +0200 Subject: [PATCH] Fixes/tests for recursive link pins (#751) * Fixes for recursive link pins * Use link relative paths in output Internally absolute paths are used, which allows to remove some complex logic. * Bypass dangling reference warning in some gnat versions * Fixes for absolute paths on Windows * Cosmetic fix for `alr pin` * Ensure user pins in memory use absolute paths This simplifies internals when referring to recursive pins. Paths in the lockfile and displayed to the user are still shown as relative to the root. * New improved remote pin management * Remove some redundant info output * Remove Externals.Softlinks in favor of User_Pins * Found cause & workaround of CE2021 path corruption bug * Testcase minor fix * Fix spellcheck CI I broke it inadvertently when disabling spelling for the lockfile * New tests for recursive pins and more * Clarifications and tweaks during self-review * Backport VCSs.Git changes * Update pins in alire.toml for self-build * Fixes found by the testsuite on Windows * Cosmetic fixes found during self-review --- .github/workflows/spellcheck.yml | 4 +- alire.lock | 221 ------- alire.toml | 6 +- deps/semantic_versioning | 2 +- .../alire-conditional_trees-case_nodes.adb | 3 + src/alire/alire-dependencies-states.adb | 4 +- src/alire/alire-dependencies-states.ads | 53 +- src/alire/alire-directories.adb | 29 + src/alire/alire-directories.ads | 10 + src/alire/alire-environment.adb | 1 + .../alire-externals-softlinks-holders.ads | 4 - src/alire/alire-externals-softlinks.adb | 178 ------ src/alire/alire-externals-softlinks.ads | 159 ----- src/alire/alire-externals.adb | 2 - src/alire/alire-externals.ads | 4 - src/alire/alire-origins.adb | 26 +- src/alire/alire-origins.ads | 3 + src/alire/alire-paths.ads | 2 + src/alire/alire-pinning.adb | 20 - src/alire/alire-pinning.ads | 10 - src/alire/alire-releases.adb | 10 +- src/alire/alire-roots-optional.adb | 95 +-- src/alire/alire-roots-optional.ads | 10 + src/alire/alire-roots.adb | 562 +++++++----------- src/alire/alire-roots.ads | 42 +- src/alire/alire-solutions-diffs.adb | 6 +- src/alire/alire-solutions.adb | 63 +- src/alire/alire-solutions.ads | 22 +- src/alire/alire-user_pins-maps.adb | 28 +- src/alire/alire-user_pins.adb | 361 ++++++++++- src/alire/alire-user_pins.ads | 57 +- src/alire/alire-utils-user_input.adb | 30 + src/alire/alire-utils-user_input.ads | 16 + src/alire/alire-vcss-git.adb | 58 +- src/alire/alire-vcss-git.ads | 14 +- src/alire/alire-vfs.adb | 19 + src/alire/alire-vfs.ads | 19 + src/alire/alire.ads | 7 +- src/alr/alr-commands-pin.adb | 35 +- src/alr/alr-commands-withing.adb | 66 +- src/alr/alr-commands.adb | 21 - testsuite/drivers/alr.py | 20 +- testsuite/drivers/helpers.py | 7 +- testsuite/tests/pin/bad-path/test.py | 16 + testsuite/tests/pin/bad-path/test.yaml | 3 + testsuite/tests/pin/change-type/test.py | 4 +- testsuite/tests/pin/pin-dir/test.py | 4 +- testsuite/tests/pin/portable-path/test.py | 40 ++ testsuite/tests/pin/portable-path/test.yaml | 3 + testsuite/tests/pin/recursive_local/test.py | 31 + testsuite/tests/pin/recursive_local/test.yaml | 3 + testsuite/tests/pin/recursive_remote/test.py | 48 ++ .../tests/pin/recursive_remote/test.yaml | 3 + testsuite/tests/update/manual-once/test.py | 2 +- 54 files changed, 1175 insertions(+), 1291 deletions(-) delete mode 100644 alire.lock delete mode 100644 src/alire/alire-externals-softlinks-holders.ads delete mode 100644 src/alire/alire-externals-softlinks.adb delete mode 100644 src/alire/alire-externals-softlinks.ads create mode 100644 testsuite/tests/pin/bad-path/test.py create mode 100644 testsuite/tests/pin/bad-path/test.yaml create mode 100644 testsuite/tests/pin/portable-path/test.py create mode 100644 testsuite/tests/pin/portable-path/test.yaml create mode 100644 testsuite/tests/pin/recursive_local/test.py create mode 100644 testsuite/tests/pin/recursive_local/test.yaml create mode 100644 testsuite/tests/pin/recursive_remote/test.py create mode 100644 testsuite/tests/pin/recursive_remote/test.yaml diff --git a/.github/workflows/spellcheck.yml b/.github/workflows/spellcheck.yml index 88d010e2..3a376f48 100644 --- a/.github/workflows/spellcheck.yml +++ b/.github/workflows/spellcheck.yml @@ -15,4 +15,6 @@ jobs: github_token: ${{ secrets.github_token }} reporter: github-pr-review locale: "US" - exclude: "*.lock* +# exclude: '*.lock' +# It seems exclusion is not working: +# https://github.com/reviewdog/action-hadolint/issues/35 diff --git a/alire.lock b/alire.lock deleted file mode 100644 index e3203f1f..00000000 --- a/alire.lock +++ /dev/null @@ -1,221 +0,0 @@ -# THIS IS A MACHINE-GENERATED FILE. DO NOT EDIT MANUALLY. - -[solution] -[solution.context] -solved = true -[[solution.state]] -crate = "aaa" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "~0.2.1" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/aaa_0.2.3-dev_ccb78861" -relative = true -remote = true -[solution.state.link.origin] -commit = "ccb78861bd7589dfcce08a70b69cdc72169bbf4a" -url = "git+https://github.com/mosteo/aaa.git" -[[solution.state]] -crate = "ada_toml" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "~0.1" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/ada_toml_ade3cc90" -relative = true -remote = true -[solution.state.link.origin] -commit = "ade3cc905cef405dbf53e16a54f6fb458482710f" -url = "git+https://github.com/pmderodat/ada-toml.git" -[[solution.state]] -crate = "ajunitgen" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "^1.0.1" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/ajunitgen_1.0.2-dev_e5d01db5" -relative = true -remote = true -[solution.state.link.origin] -commit = "e5d01db5e7834d15c4066f0a8e33d780deae3cc9" -url = "git+https://github.com/mosteo/ajunitgen.git" -[[solution.state]] -crate = "ansiada" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "~0.1" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/ansiada_0.2.0-dev_acf9afca" -relative = true -remote = true -[solution.state.link.origin] -commit = "acf9afca3afe1f8b8843c061f3cef860d7567307" -url = "git+https://github.com/mosteo/ansi-ada.git" -[[solution.state]] -crate = "curl" -fulfilment = "solved" -pinned = false -transitivity = "indirect" -versions = "*" -[solution.state.release] -description = "Command-line tool for transferring data with URL syntax" -maintainers = [ -"alejandro@mosteo.com", -] -maintainers-logins = [ -"mosteo", -] -name = "curl" -notes = "Provided by system package: curl" -version = "7.68.0" -[solution.state.release.origin] -url = "system:curl" -[[solution.state]] -crate = "gnatcoll" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "^21" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/gnatcoll_0.0.0_e250e4e4" -relative = true -remote = true -[solution.state.link.origin] -commit = "e250e4e42d9743b782788cf61b4ddc10a45e69e2" -url = "git+https://github.com/alire-project/gnatcoll-core.git" -[[solution.state]] -crate = "minirest" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "~0.2" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/minirest_0.2.0-dev_4550aa35" -relative = true -remote = true -[solution.state.link.origin] -commit = "4550aa356d55b9cd55f26acd34701f646021c5ff" -url = "git+https://github.com/mosteo/minirest.git" -[[solution.state]] -crate = "optional" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "~0.0.0" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/optional_0.1.0-rc1_30aaee65" -relative = true -remote = true -[solution.state.link.origin] -commit = "30aaee65d89d5a9ca1c71f6d38e4462fae2ef4ce" -url = "git+https://github.com/mosteo/optional.git" -[[solution.state]] -crate = "semantic_versioning" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "^2" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/semantic_versioning_2.0.0-dev_82c28f77" -relative = true -remote = true -[solution.state.link.origin] -commit = "82c28f773d0e3126d7cdf6e4ded228d2b733441e" -url = "git+https://github.com/alire-project/semantic_versioning.git" -[[solution.state]] -crate = "simple_logging" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "^1.2" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/simple_logging_1.2.0-dev_02a7de75" -relative = true -remote = true -[solution.state.link.origin] -commit = "02a7de7568af6af7cedd1048901fae8e9477b1d9" -url = "git+https://github.com/alire-project/simple_logging.git" -[[solution.state]] -crate = "spdx" -fulfilment = "solved" -pinned = false -transitivity = "direct" -versions = "~0.2" -[solution.state.release] -authors = [ -"Fabien Chouteau", -] -description = "SPDX License Expression Validator" -licenses = "MIT" -maintainers = [ -"Fabien Chouteau ", -] -maintainers-logins = [ -"Fabien-Chouteau", -] -name = "spdx" -tags = [ -"spdx", -"license", -] -version = "0.2.0" -website = "https://github.com/Fabien-Chouteau/spdx_ada" -[solution.state.release.origin] -commit = "2df9b1182544359c751544e52e14c94830d99fa6" -url = "git+https://github.com/Fabien-Chouteau/spdx_ada.git" -[[solution.state]] -crate = "uri_ada" -fulfilment = "linked" -pinned = false -transitivity = "direct" -versions = "^1" -[solution.state.link] -kind = "softlink" -path = "file:alire/cache/pins/uri_ada_1.0.0-dev_b61eba59" -relative = true -remote = true -[solution.state.link.origin] -commit = "b61eba59099b3ab39e59e228fe4529927f9e849e" -url = "git+https://github.com/mosteo/uri-ada.git" -[[solution.state]] -crate = "xml_ez_out" -fulfilment = "solved" -pinned = false -transitivity = "indirect" -versions = "^1.6" -[solution.state.release] -authors = [ -"Marc A. Criley", -] -description = "Creation of XML-formatted output from Ada programs" -executables = [ -"tmeztf", -] -maintainers = [ -"alejandro@mosteo.com", -] -maintainers-logins = [ -"mosteo", -] -name = "xml_ez_out" -version = "1.6.0" -website = "http://www.mckae.com/xmlEz.html" -[solution.state.release.origin] -hashes = [ -"sha512:c90d08dcdb96bf39f1e06def716ea9936b2aec25fec2ea4f3314c53a2befefa4ea84c037c35abe6d7675af1c91a8847f6ce4e5e8dd32da1008f2ba43ed79151b", -] -url = "https://github.com/alire-project/xmlezout/archive/alr-1.6.tar.gz" - diff --git a/alire.toml b/alire.toml index c8677d0e..b6ecc284 100644 --- a/alire.toml +++ b/alire.toml @@ -33,13 +33,13 @@ macos = { OS = "macOS" } # Most dependencies require precise versions during the development cycle: [[pins]] -aaa = { url = "https://github.com/mosteo/aaa.git", commit = "4b4aa047f29a4270c5b5003468617e153977ab97" } +aaa = { url = "https://github.com/mosteo/aaa.git", commit = "ccb78861bd7589dfcce08a70b69cdc72169bbf4a" } ada_toml = { url = "https://github.com/pmderodat/ada-toml.git", commit = "ade3cc905cef405dbf53e16a54f6fb458482710f" } ajunitgen = { url = "https://github.com/mosteo/ajunitgen.git", commit = "e5d01db5e7834d15c4066f0a8e33d780deae3cc9" } ansiada = { url = "https://github.com/mosteo/ansi-ada.git", commit = "acf9afca3afe1f8b8843c061f3cef860d7567307" } gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "f3bd1c51d12962879f52733e790b394f5bbfe05f" } minirest = { url = "https://github.com/mosteo/minirest.git", commit = "4550aa356d55b9cd55f26acd34701f646021c5ff" } -optional = { url = "https://github.com/mosteo/optional.git", commit = "30aaee65d89d5a9ca1c71f6d38e4462fae2ef4ce" } -semantic_versioning = { url = "https://github.com/alire-project/semantic_versioning.git", commit = "82c28f773d0e3126d7cdf6e4ded228d2b733441e" } +optional = { url = "https://github.com/mosteo/optional.git", commit = "eb929e67ccd357881997d4eed5e4477144923d7c" } +semantic_versioning = { url = "https://github.com/alire-project/semantic_versioning.git", commit = "85689acb6dfde74d00473b41563b75adf76f4881" } simple_logging = { url = "https://github.com/alire-project/simple_logging.git", commit = "02a7de7568af6af7cedd1048901fae8e9477b1d9" } uri_ada = { url = "https://github.com/mosteo/uri-ada.git", commit = "b61eba59099b3ab39e59e228fe4529927f9e849e" } diff --git a/deps/semantic_versioning b/deps/semantic_versioning index 82c28f77..85689acb 160000 --- a/deps/semantic_versioning +++ b/deps/semantic_versioning @@ -1 +1 @@ -Subproject commit 82c28f773d0e3126d7cdf6e4ded228d2b733441e +Subproject commit 85689acb6dfde74d00473b41563b75adf76f4881 diff --git a/src/alire/alire-conditional_trees-case_nodes.adb b/src/alire/alire-conditional_trees-case_nodes.adb index 1416c4e6..c502d5af 100644 --- a/src/alire/alire-conditional_trees-case_nodes.adb +++ b/src/alire/alire-conditional_trees-case_nodes.adb @@ -1,3 +1,5 @@ +with AAA.Debug; + with Alire.TOML_Adapters; with GNAT.IO; @@ -154,6 +156,7 @@ package body Alire.Conditional_Trees.Case_Nodes is & This.Cases.Base.Key & "; 'other' expressions discarded"); -- Not sure if this may happen and what we should do in that case; -- take the others branch or drop it as if the var was NaN + Trace.Debug (AAA.Debug.Stack_Trace); end if; end return; end Evaluate; diff --git a/src/alire/alire-dependencies-states.adb b/src/alire/alire-dependencies-states.adb index 40b1fb26..b0632867 100644 --- a/src/alire/alire-dependencies-states.adb +++ b/src/alire/alire-dependencies-states.adb @@ -93,8 +93,8 @@ package body Alire.Dependencies.States is when Hinted => null; when Linked => - Data.Target.Hold - (Externals.Softlinks.From_TOML + Data.Target := To_Holder + (User_Pins.From_TOML (From.Descend (Value => From.Checked_Pop (Keys.Link, TOML_Table), Context => Keys.Link))); diff --git a/src/alire/alire-dependencies-states.ads b/src/alire/alire-dependencies-states.ads index 3c6ea412..16ce1ca2 100644 --- a/src/alire/alire-dependencies-states.ads +++ b/src/alire/alire-dependencies-states.ads @@ -1,9 +1,9 @@ -private with AAA.Containers.Indefinite_Holders; +private with Ada.Containers.Indefinite_Holders; private with Alire.Containers; -with Alire.Externals.Softlinks; with Alire.Releases; with Alire.TOML_Adapters; +with Alire.User_Pins; package Alire.Dependencies.States is @@ -20,6 +20,10 @@ package Alire.Dependencies.States is Direct, -- A dependency of the root release Indirect); -- A dependency introduced transitively + subtype Softlink is User_Pins.Pin + with Dynamic_Predicate => + Softlink.Kind in User_Pins.Kinds_With_Path; + type State (<>) is new Dependency with private; overriding function "=" (L, R : State) return Boolean; @@ -39,7 +43,7 @@ package Alire.Dependencies.States is -- Change fulfilment to Hinted in copy of Base function Linking (Base : State; - Link : Externals.Softlinks.External) + Link : Softlink) return State; -- Returns a copy of Base fulfilled by Path @@ -107,7 +111,7 @@ package Alire.Dependencies.States is function Fulfilment (This : State) return Fulfillments; - function Link (This : State) return Externals.Softlinks.External + function Link (This : State) return Softlink with Pre => This.Is_Linked; function Pin_Version (This : State) return Semantic_Versioning.Version @@ -172,17 +176,19 @@ private -- Helper types - package External_Holders is - new AAA.Containers.Indefinite_Holders (Externals.Softlinks.External); - - type Link_Holder is new External_Holders.Holder with null record; - overriding function New_Dependency (Crate : Crate_Name; Versions : Semantic_Versioning.Extended.Version_Set) return State; + package Link_Holders is + new Ada.Containers.Indefinite_Holders (Softlink, User_Pins."="); + + type Link_Holder is new Link_Holders.Holder with null record; + + function Get (This : Link_Holder) return Softlink renames Element; + type Fulfillment_Data (Fulfillment : Fulfillments := Missed) is record case Fulfillment is when Linked => @@ -275,11 +281,13 @@ private else "") & Utils.To_Lower_Case (This.Fulfilled.Fulfillment'Img) & (if This.Fulfilled.Fulfillment = Linked - then ",pin=" & This.Fulfilled.Target.Get.Path - & (if GNAT.OS_Lib.Is_Directory - (This.Fulfilled.Target.Get.Path) - then "" - else "," & TTY.Error ("broken")) + then ",pin=" & This.Fulfilled.Target.Element.Relative_Path + & (if not This.Fulfilled.Target.Element.Is_Broken + then "" + else ",broken") + & (if This.Fulfilled.Target.Element.Is_Remote + then ",url=" & This.Fulfilled.Target.Element.URL + else "") & (if This.Has_Release then ",release" else "") @@ -321,7 +329,7 @@ private -- Link -- ---------- - function Link (This : State) return Externals.Softlinks.External + function Link (This : State) return Softlink is (This.Fulfilled.Target.Get); ------------- @@ -329,7 +337,7 @@ private ------------- function Linking (Base : State; - Link : Externals.Softlinks.External) + Link : Softlink) return State is (Base.As_Dependency with Name_Len => Base.Name_Len, @@ -480,11 +488,14 @@ private when others => This.Fulfilled.Fulfillment'Img) & (if This.Fulfilled.Fulfillment = Linked then "," & TTY.Emph ("pin") & "=" - & TTY.URL (This.Fulfilled.Target.Get.Path) - & (if GNAT.OS_Lib.Is_Directory - (This.Fulfilled.Target.Get.Path) - then "" - else "," & TTY.Error ("broken")) + & TTY.URL (This.Fulfilled.Target.Element.Relative_Path) + & (if not This.Fulfilled.Target.Element.Is_Broken + then "" + else "," & TTY.Error ("broken")) + & (if This.Fulfilled.Target.Element.Is_Remote + then ",url=" & TTY.URL + (This.Fulfilled.Target.Element.URL) + else "") & (if This.Has_Release then "," & TTY.OK ("release") else "") diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 64df9638..e0da9669 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -4,6 +4,7 @@ with Ada.Text_IO; with Ada.Unchecked_Deallocation; with Alire.OS_Lib.Subprocess; +with Alire.Paths; with Alire.Platform; with Alire.Properties; with Alire.Roots; @@ -381,6 +382,34 @@ package body Alire.Directories is for I in 5 .. 8 loop UStrings.Replace_Element (This.Name, I, Char_Random.Random (Gen)); end loop; + + -- Try to use our alire folder to hide temporaries; return an absolute + -- path in any case to avoid problems with the user of the tmp file + -- changing working directory. + + if Ada.Directories.Exists (Paths.Working_Folder_Inside_Root) then + + -- Create tmp folder if not existing + + if not Ada.Directories.Exists + (Paths.Working_Folder_Inside_Root + / Paths.Temp_Folder_Inside_Working_Folder) + then + Ada.Directories.Create_Path + (Paths.Working_Folder_Inside_Root + / Paths.Temp_Folder_Inside_Working_Folder); + end if; + + This.Name := +Ada.Directories.Full_Name + (Paths.Working_Folder_Inside_Root + / Paths.Temp_Folder_Inside_Working_Folder + / (+This.Name)); + + else + + This.Name := +Ada.Directories.Full_Name (+This.Name); + + end if; end Initialize; -------------- diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index c398c5c6..285de4b7 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -54,6 +54,9 @@ package Alire.Directories is -- May still return an absolute path if Child is not in the same drive -- (Windows) as Parent. + function Find_Relative_Path_To (Path : Any_Path) return Any_Path; + -- Same as Find_Relative_Path (Parent => Current, Child => Path) + function Find_Single_File (Path : String; Extension : String) return String; @@ -175,4 +178,11 @@ private Backup_Dir : Any_Path (1 .. Backup_Len); end record; + --------------------------- + -- Find_Relative_Path_To -- + --------------------------- + + function Find_Relative_Path_To (Path : Any_Path) return Any_Path + is (Find_Relative_Path (Current, Path)); + end Alire.Directories; diff --git a/src/alire/alire-environment.adb b/src/alire/alire-environment.adb index 00d2c83e..4f43f170 100644 --- a/src/alire/alire-environment.adb +++ b/src/alire/alire-environment.adb @@ -150,6 +150,7 @@ package body Alire.Environment is Rel : constant Releases.Release := Root.Release (Crate); Origin : constant String := Rel.Name_Str; begin + Trace.Debug ("Loading environment for release: " & TTY.Name (Crate)); -- Environment variables defined in the crate manifest for Act of Rel.Environment (Root.Environment) loop diff --git a/src/alire/alire-externals-softlinks-holders.ads b/src/alire/alire-externals-softlinks-holders.ads deleted file mode 100644 index adb75baa..00000000 --- a/src/alire/alire-externals-softlinks-holders.ads +++ /dev/null @@ -1,4 +0,0 @@ -with Ada.Containers.Indefinite_Holders; - -package Alire.Externals.Softlinks.Holders is - new Ada.Containers.Indefinite_Holders (Softlinks.External); diff --git a/src/alire/alire-externals-softlinks.adb b/src/alire/alire-externals-softlinks.adb deleted file mode 100644 index 9b808608..00000000 --- a/src/alire/alire-externals-softlinks.adb +++ /dev/null @@ -1,178 +0,0 @@ -with Alire.OS_Lib; -with Alire.TOML_Keys; -with Alire.URI; -with Alire.Utils.TTY; - -with GNATCOLL.VFS; - -package body Alire.Externals.Softlinks is - - package Adirs renames Ada.Directories; - use TOML; - - package Keys is - - -- TOML Keys used locally - - Kind : constant String := "kind"; - Origin : constant String := TOML_Keys.Origin; -- Must be the same key - Path : constant String := "path"; - Relative : constant String := "relative"; - Remote : constant String := "remote"; - - end Keys; - - --------------- - -- From_TOML -- - --------------- - - function From_TOML (Table : TOML_Adapters.Key_Queue) return External is - Path : constant String := - Table.Checked_Pop (Keys.Path, TOML_String).As_String; - Remote : constant Boolean := - Table.Checked_Pop (Keys.Remote, TOML_Boolean).As_Boolean; - begin - if Remote then - declare - Origin : Origins.Origin; - begin - Origin.From_TOML (Table).Assert; - return New_Remote (Origin => Origin, - Path => URI.Local_Path (Path)); - end; - else - return New_Softlink (Path); - end if; - end From_TOML; - - ---------------- - -- New_Remote -- - ---------------- - - function New_Remote (Origin : Origins.Origin; - Path : Relative_Path) return External - is - Stored_Path : constant Portable_Path := Alire.VFS.To_Portable (Path); - begin - return (Externals.External with - Has_Remote => True, - Remote => (Used => True, Origin => Origin), - Relative => True, - Path_Length => Stored_Path'Length, - Rel_Path => Stored_Path); - end New_Remote; - - ------------------ - -- New_Softlink -- - ------------------ - - function New_Softlink (From : URL) return External - is - begin - if URI.Scheme (From) not in URI.File_Schemes then - Raise_Checked_Error - ("Given URL does not seem to denote a local path: " - & Utils.TTY.Emph (From)); - end if; - - declare - Path : constant Any_Path := URI.Local_Path (From); - begin - - -- Store the path as a minimal relative path, so cloning a monorepo - -- will work as-is, when originally given as a relative path - - declare - use GNATCOLL.VFS; - Target : constant Filesystem_String := - (if Check_Absolute_Path (Path) - then +Path - else GNATCOLL.VFS.Relative_Path - (File => Create (+Adirs.Full_Name (Path)), - From => Create (+Adirs.Current_Directory))); - - begin - if Check_Absolute_Path (Path) then - return (Externals.External with - Has_Remote => False, - Remote => <>, - Relative => False, - Path_Length => Path'Length, - Abs_Path => Path); - else - declare - Portable_Target : constant Portable_Path := - Alire.VFS.To_Portable (+Target); - begin - return (Externals.External with - Has_Remote => False, - Remote => <>, - Relative => True, - Path_Length => Portable_Target'Length, - Rel_Path => Portable_Target); - end; - end if; - end; - end; - end New_Softlink; - - -------------- - -- Relocate -- - -------------- - - function Relocate (This : External; - From : Any_Path) return External - is - begin - if Check_Absolute_Path (This.Path) then - return This; - end if; - - declare - use Alire.OS_Lib.Operators; - New_Path : constant Portable_Path := - Alire.VFS.To_Portable (From / This.Path); - begin - return (Externals.External with - Has_Remote => This.Has_Remote, - Remote => This.Remote, - Relative => True, - Path_Length => New_Path'Length, - Rel_Path => New_Path); - end; - end Relocate; - - ------------- - -- To_TOML -- - ------------- - - overriding - function To_TOML (This : External) return TOML.TOML_Value is - Table : constant TOML_Value := Create_Table; - begin - Table.Set (Keys.Kind, - Create_String (Utils.To_Lower_Case (Softlink'Img))); - Table.Set (Keys.Remote, - Create_Boolean (This.Has_Remote)); - Table.Set (Keys.Relative, - Create_Boolean (This.Relative)); - - if This.Has_Remote then - Table.Set (Keys.Origin, - This.Remote.Origin.To_TOML); - end if; - - if This.Relative then - Table.Set (Keys.Path, - Create_String ("file:" & String (This.Rel_Path))); - else - Table.Set (Keys.Path, - Create_String ("file:" & This.Abs_Path)); - end if; - -- "file:" is there so absolute paths on Windows do not report the drive - -- letter as the scheme (file:C:\\ is correct, C:\\ is not). - - return Table; - end To_TOML; - -end Alire.Externals.Softlinks; diff --git a/src/alire/alire-externals-softlinks.ads b/src/alire/alire-externals-softlinks.ads deleted file mode 100644 index 1ab353b3..00000000 --- a/src/alire/alire-externals-softlinks.ads +++ /dev/null @@ -1,159 +0,0 @@ -with Ada.Directories; - -with Alire.Interfaces; -with Alire.Origins.Deployers; -with Alire.TOML_Adapters; -private with Alire.VFS; - -with TOML; - -package Alire.Externals.Softlinks is - - -- A do-nothing external that is used to use a dir as an in-progress crate. - -- This external provides its path to be used for GPR_INCLUDE_PATH. - - type External (<>) is - new Externals.External - and Interfaces.Tomifiable - with private; - - function New_Softlink (From : Any_Path) return External; - -- Create a softlink for a local dir. From must be absolute or relative to - -- Ada.Directories.Current. - - function New_Remote (Origin : Origins.Origin; - Path : Relative_Path) return External; - -- Create a softlink with an associated Origin source. Path is where it - -- has been/will be deployed. Path must be relative to the root using the - -- softlink. - - function Deploy (This : External) return Outcome; - -- For a Origin pin, redeploy sources if they're not at the expected - -- location. For a local pin, do nothing. - - overriding - function Detect (This : External; - Unused_Name : Crate_Name) return Containers.Release_Set - is (Containers.Release_Sets.Empty_Set); - -- Never detected, as we want these crates to work as a wildcard for any - -- version. - - function Is_Remote (This : External) return Boolean; - -- Say if this is a softlink with a Origin origin - - function Is_Valid (This : External) return Boolean; - -- Check that the pointed-to folder exists - - function Is_Broken (This : External) return Boolean - is (not This.Is_Valid); - - overriding - function Image (This : External) return String; - - overriding - function Detail (This : External; - Unused_Distro : Platforms.Distributions) - return Utils.String_Vector - is (Utils.Empty_Vector.Append ("User-provided external crate")); - - overriding - function Kind (This : External) return String is ("Symbolic link"); - - function Project_Paths (This : External) return Utils.String_Vector; - -- For now it returns the root path given by the user. We could consider - -- adding more paths at configuration time. - - function Path (This : External) return Any_Path; - - function Relocate (This : External; - From : Any_Path) return External; - -- Return the same external, but adjust its path (when relative) when seen - -- with prefix From. - - function Remote (This : External) return Origins.Origin - with Pre => This.Is_Remote; - - function From_TOML (Table : TOML_Adapters.Key_Queue) return External; - - overriding - function To_TOML (This : External) return TOML.TOML_Value; - -private - - type Optional_Remote (Used : Boolean) is record - case Used is - when True => Origin : Origins.Origin; - when False => null; - end case; - end record; - - type External (Has_Remote, Relative : Boolean; Path_Length : Positive) is - new Externals.External - and Interfaces.Tomifiable with record - Remote : Optional_Remote (Has_Remote); - case Relative is - when True => Rel_Path : Portable_Path (1 .. Path_Length); - when False => Abs_Path : Absolute_Path (1 .. Path_Length); - end case; - end record; - - ------------ - -- Deploy -- - ------------ - - function Deploy (This : External) return Outcome - is (if This.Has_Remote - then (if GNAT.OS_Lib.Is_Directory (This.Path) - then Outcome_Success - else Origins.Deployers.New_Deployer (This.Remote.Origin) - .Deploy (This.Path)) - else Outcome_Success); - - ----------- - -- Image -- - ----------- - - overriding - function Image (This : External) return String - is ("User-provided at " & This.Path); - - --------------- - -- Is_Remote -- - --------------- - - function Is_Remote (This : External) return Boolean - is (This.Has_Remote); - - -------------- - -- Is_Valid -- - -------------- - - function Is_Valid (This : External) return Boolean - is (GNAT.OS_Lib.Is_Directory (This.Path)); - - ---------- - -- Path -- - ---------- - - function Path (This : External) return Any_Path - is (if This.Relative - then VFS.To_Native (This.Rel_Path) - else This.Abs_Path); - - ------------------- - -- Project_Paths -- - ------------------- - - function Project_Paths (This : External) return Utils.String_Vector - is (Utils.To_Vector (Ada.Directories.Full_Name (This.Path))); - -- As the path may be relative, we make it absolute to avoid duplicates - -- with absolute paths reported by a Release.Project_Paths. - - ------------ - -- Origin -- - ------------ - - function Remote (This : External) return Origins.Origin - is (This.Remote.Origin); - -end Alire.Externals.Softlinks; diff --git a/src/alire/alire-externals.adb b/src/alire/alire-externals.adb index 10d0309a..efcac40e 100644 --- a/src/alire/alire-externals.adb +++ b/src/alire/alire-externals.adb @@ -3,7 +3,6 @@ with AAA.Enum_Tools; with Alire.Crates; with Alire.Externals.From_Output; with Alire.Externals.From_System; -with Alire.Externals.Softlinks; with Alire.Externals.Unindexed; with Alire.TOML_Keys; with Alire.TOML_Load; @@ -36,7 +35,6 @@ package body Alire.Externals is (case Kind is when Hint => Unindexed.External' (External with null record), - when Softlink => Softlinks.From_TOML (From), when System => From_System.From_TOML (From), when Version_Output => From_Output.From_TOML (From)); diff --git a/src/alire/alire-externals.ads b/src/alire/alire-externals.ads index 66db2d61..6993480a 100644 --- a/src/alire/alire-externals.ads +++ b/src/alire/alire-externals.ads @@ -44,10 +44,6 @@ package Alire.Externals is -- A placeholder for a knowingly-unavailable crate, that -- will hopefully be added in the future. - Softlink, - -- A directory that is used in place, with indeterminate - -- version. - System, -- A installed system package, via apt, yum, etc. diff --git a/src/alire/alire-origins.adb b/src/alire/alire-origins.adb index 6b8b3039..8e7b671f 100644 --- a/src/alire/alire-origins.adb +++ b/src/alire/alire-origins.adb @@ -341,22 +341,24 @@ package body Alire.Origins is return Reduce; end Image_Of_Hashes; + ------------------ + -- Short_Commit -- + ------------------ + + function Short_Commit (Commit : String) return String + is (if Commit'Length < 8 + then Commit + else Commit (Commit'First .. Commit'First + 7)); + --------------------- -- Short_Unique_Id -- --------------------- - function Short_Unique_Id (This : Origin) return String is - Hash : constant String := - (if This.Kind = Source_Archive - then Utils.Tail (String (This.Data.Hashes.First_Element), ':') - else This.Commit); - begin - if Hash'Length < 8 then - return Hash; - else - return Hash (Hash'First .. Hash'First + 7); - end if; - end Short_Unique_Id; + function Short_Unique_Id (This : Origin) return String + is (Short_Commit + (if This.Kind = Source_Archive + then Utils.Tail (String (This.Data.Hashes.First_Element), ':') + else This.Commit)); ------------- -- To_TOML -- diff --git a/src/alire/alire-origins.ads b/src/alire/alire-origins.ads index dd7e2898..5e91b5eb 100644 --- a/src/alire/alire-origins.ads +++ b/src/alire/alire-origins.ads @@ -99,6 +99,9 @@ package Alire.Origins is is (S'Length = Git_Commit'Length and then (for all Char of S => Char in Hexadecimal_Character)); + function Short_Commit (Commit : String) return String; + -- First characters in the commit + -- Constructors function New_External (Description : String) return Origin; diff --git a/src/alire/alire-paths.ads b/src/alire/alire-paths.ads index 6c9b33c5..857e297f 100644 --- a/src/alire/alire-paths.ads +++ b/src/alire/alire-paths.ads @@ -5,6 +5,8 @@ package Alire.Paths with Preelaborate is Crate_File_Name : constant String := "alire.toml"; -- Name of the manifest file in a regular workspace + Temp_Folder_Inside_Working_Folder : constant Relative_Path := "tmp"; + 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-pinning.adb b/src/alire/alire-pinning.adb index 9a860dca..382d242e 100644 --- a/src/alire/alire-pinning.adb +++ b/src/alire/alire-pinning.adb @@ -28,26 +28,6 @@ package body Alire.Pinning is .Pinning (Crate, Version); end Pin; - ------------ - -- Pin_To -- - ------------ - - function Pin_To (Crate : Crate_Name; - URL : String; - Dependencies : Conditional.Dependencies; - Environment : Properties.Vector; - Solution : Solutions.Solution) - return Solutions.Solution - -- Just in case it was already pinned to a version, we remove that hidden - -- restriction, and re-solve so any old constraints in the dependencies - -- caused by the old pin disappear. - is (Solver.Resolve - (Dependencies, - Environment, - Solution - .Unpinning (Crate) - .Linking (Crate, URL))); - ----------- -- Unpin -- ----------- diff --git a/src/alire/alire-pinning.ads b/src/alire/alire-pinning.ads index b74e239a..481c8b3b 100644 --- a/src/alire/alire-pinning.ads +++ b/src/alire/alire-pinning.ads @@ -19,16 +19,6 @@ package Alire.Pinning is -- must exist in the solution. Root dependencies are given, and a previous -- solution with possibly more pins. The resulting solution may be invalid. - function Pin_To (Crate : Crate_Name; - URL : String; - Dependencies : Conditional.Dependencies; - Environment : Properties.Vector; - Solution : Solutions.Solution) - return Solutions.Solution with - Pre => Solution.Depends_On (Crate) or else - raise Checked_Error with - "Cannot pin crate not in dependencies: " & (+Crate); - function Unpin (Crate : Crate_Name; Dependencies : Conditional.Dependencies; Environment : Properties.Vector; diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index ce2f4818..5fd34991 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -58,7 +58,15 @@ package body Alire.Releases is (Alire.Dependencies.Containers.List, Alire.Dependencies.Containers.Append); begin - return Enumerate (R.Dependencies.Evaluate (P)); + if P.Is_Empty then + -- Trying to evaluate a tree with empty dependencies will result + -- in spurious warnings about missing environment properties (as we + -- indeed didn't give any). Since we want to get flat dependencies + -- that do not depend on any properties, this is indeed safe to do. + return Enumerate (R.Dependencies); + else + return Enumerate (R.Dependencies.Evaluate (P)); + end if; end Flat_Dependencies; ------------------------- diff --git a/src/alire/alire-roots-optional.adb b/src/alire/alire-roots-optional.adb index 96c790f3..56bd9e78 100644 --- a/src/alire/alire-roots-optional.adb +++ b/src/alire/alire-roots-optional.adb @@ -7,6 +7,8 @@ with Alire.Root; with GNAT.OS_Lib; +with Semantic_Versioning; + package body Alire.Roots.Optional is Root_Not_Detected : constant Root := @@ -28,44 +30,58 @@ package body Alire.Roots.Optional is ----------------- function Detect_Root (Path : Any_Path) return Optional.Root is - use Directories.Operators; - Crate_File : constant Any_Path := Path / Crate_File_Name; + Crate_File : constant Any_Path := Crate_File_Name; begin - if Path /= "" then - if GNAT.OS_Lib.Is_Regular_File (Crate_File) then - begin - return This : constant Root := - Outcome_Success - (Roots.New_Root - (R => Releases.From_Manifest (Crate_File, - Manifest.Local, - Strict => True), - Path => Ada.Directories.Full_Name (Path), - Env => Alire.Root.Platform_Properties)) - do - -- Crate loaded properly, we can return a valid root here - Trace.Debug ("Valid root found at " & Path); - end return; - exception - when E : others => - Trace.Debug ("Unloadable root found at " & Path); - Log_Exception (E); - return Outcome_Failure - (Errors.Get (E), - Broken, - Report => False); - end; + if not GNAT.OS_Lib.Is_Directory (Path) then + Trace.Debug + ("No root can be detected because given path is not a directory: " + & Path); + return Root_Not_Detected; + end if; + + declare + Change_Dir : Directories.Guard (Directories.Enter (Path)) + with Unreferenced; + -- We need to enter the folder with the possible crate, so stored + -- relative paths (e.g. in pins) make sense when loaded. + begin + if Path /= "" then + if GNAT.OS_Lib.Is_Regular_File (Crate_File) then + begin + return This : constant Root := + Outcome_Success + (Roots.New_Root + (R => Releases.From_Manifest (Crate_File, + Manifest.Local, + Strict => True), + Path => Ada.Directories.Full_Name (Path), + Env => Alire.Root.Platform_Properties)) + do + -- Crate loaded properly, we can return a valid root here + Trace.Debug ("Valid root found at " & Path); + end return; + exception + when E : others => + Trace.Debug ("Unloadable root found at " & Path); + Log_Exception (E); + return Outcome_Failure + (Errors.Get (E), + Broken, + Report => False); + end; + else + Trace.Debug ("No root found at " & Path); + return Root_Not_Detected; + end if; else - Trace.Debug ("No root found at " & Path); + Trace.Debug + ("No root can be detected because given path is empty"); return Root_Not_Detected; + -- This happens when detection of session folders in parent + -- folders has been already attempted by the caller, so it + -- ends calling here with an empty path. end if; - else - Trace.Debug ("No root can be detected because given path is empty"); - return Root_Not_Detected; - -- This happens when detection of session folders in parent folders - -- has been already attempted by the caller, so it ends calling here - -- with an empty path. - end if; + end; end Detect_Root; ----------------- @@ -146,4 +162,15 @@ package body Alire.Roots.Optional is (Status => Valid, Value => This)); + -------------------------- + -- Updatable_Dependency -- + -------------------------- + + function Updatable_Dependency (This : Root) + return Dependencies.Dependency + is (Dependencies.New_Dependency + (This.Value.Release.Element.Name, + Semantic_Versioning.Updatable + (This.Value.Release.Element.Version))); + end Alire.Roots.Optional; diff --git a/src/alire/alire-roots-optional.ads b/src/alire/alire-roots-optional.ads index c324839a..861619eb 100644 --- a/src/alire/alire-roots-optional.ads +++ b/src/alire/alire-roots-optional.ads @@ -1,3 +1,5 @@ +with Alire.Dependencies; + package Alire.Roots.Optional is type States is @@ -51,6 +53,14 @@ package Alire.Roots.Optional is function Outcome_Success (This : Roots.Root) return Optional.Root; + -- UTILITIES + + function Updatable_Dependency (This : Root) + return Dependencies.Dependency + with Pre => This.Is_Valid; + -- If This.Is_Valid, get the corresponding updatable + -- dependency (e.g., ^1.2, ~0.1.2). Otherwise, return "any". + private type Root_Data (Status : States := Outside) is record diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index 56d16c5c..65815975 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -1,20 +1,17 @@ with Ada.Directories; +with Alire.Conditional; with Alire.Crate_Configuration; with Alire.Dependencies.Containers; with Alire.Directories; with Alire.Environment; -with Alire.Externals.Softlinks; with Alire.Manifest; -with Alire.Optional; -with Alire.Origins.Deployers; with Alire.OS_Lib; with Alire.Roots.Optional; with Alire.Solutions.Diffs; with Alire.User_Pins.Maps; with Alire.Utils.TTY; with Alire.Utils.User_Input; -with Alire.VCSs.Git; with GNAT.OS_Lib; @@ -22,7 +19,6 @@ with Semantic_Versioning.Extended; package body Alire.Roots is - package Adirs renames Ada.Directories; package Semver renames Semantic_Versioning; package TTY renames Utils.TTY; @@ -183,16 +179,6 @@ package body Alire.Roots is Round : Natural := 0; begin - -- Begin by retrieving any broken remote, so it is ready for actions - - for Dep of This.Solution.Links loop - if This.Solution.State (Dep.Crate).Link.Is_Remote and then - This.Solution.State (Dep.Crate).Link.Is_Broken - then - This.Solution.State (Dep.Crate).Link.Deploy.Assert; - end if; - end loop; - -- 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. @@ -291,184 +277,200 @@ package body Alire.Roots is end Deploy_Dependencies; - ---------------------- - -- Apply_Local_Pins -- - ---------------------- + ----------------------------- + -- Sync_Pins_From_Manifest -- + ----------------------------- - procedure Apply_Local_Pins (This : in out Root) is - use type Solutions.Solution; - Sol : Solutions.Solution := This.Solution; - begin - for I in Release (This).Pins.Iterate loop - declare - use all type User_Pins.Kinds; - use User_Pins.Maps.Pin_Maps; - Crate : constant Crate_Name := Key (I); - Pin : constant User_Pins.Pin := Element (I); - begin + procedure Sync_Pins_From_Manifest + (This : in out Root; + Exhaustive : Boolean; + Allowed : Containers.Crate_Name_Sets.Set := + Containers.Crate_Name_Sets.Empty_Set) + is + + Sol : Solutions.Solution := This.Solution; + Pins_Dir : constant Any_Path := This.Pins_Dir; + + -------------- + -- Add_Pins -- + -------------- - -- A pin for a non-dependency requires that we add a generic - -- dependency to the solution first. + procedure Add_Pins (This : in out Roots.Root) is + --------------------- + -- Add_Version_Pin -- + --------------------- + + procedure Add_Version_Pin (Crate : Crate_Name; Pin : User_Pins.Pin) is + use type Semver.Version; + begin if not Sol.Depends_On (Crate) then Sol := Sol.Depending_On - (Dependencies.New_Dependency (Crate, Semver.Extended.Any)); + (Dependencies.New_Dependency (Crate, Pin.Version)); end if; - case Pin.Kind is - when To_Version => - Sol := Sol.Resetting (Crate).Pinning (Crate, Pin.Version); - when To_Path => - Sol := Sol.Resetting (Crate).Linking (Crate, Pin.Path); - when To_Git => - null; -- Not considered here - end case; - end; - end loop; - - if Sol /= This.Solution then - Solutions.Diffs.Between (This.Solution, Sol).Print - (Changed_Only => True, - Level => Trace.Detail); - Trace.Detail ("Local pins updated and committed to lockfile"); - This.Set (Solution => Sol); - end if; - end Apply_Local_Pins; + if Sol.State (Crate).Is_Pinned + and then + Sol.State (Crate).Pin_Version /= Pin.Version + then + Put_Warning ("Incompatible version pins requested for crate " + & TTY.Name (Crate) + & "; fix versions or override with a link pin."); + end if; - ----------------- - -- Deploy_Pins -- - ----------------- + Sol := Sol.Resetting (Crate).Pinning (Crate, Pin.Version); + end Add_Version_Pin; - procedure Deploy_Pins (This : in out Root; - Exhaustive : Boolean; - Allowed : Containers.Crate_Name_Sets.Set := - Containers.Crate_Name_Sets.Empty_Set) is - use User_Pins.Maps.Pin_Maps; - Rel : constant Alire.Releases.Release := Release (This); - Pins : constant User_Pins.Maps.Map := Rel.Pins; - - -------------------- - -- Needs_Updating -- - -------------------- - - function Needs_Updating (Crate : Crate_Name; - Pin : User_Pins.Pin) return Boolean - is - use type Alire.Optional.String; - begin + ------------------ + -- Add_Link_Pin -- + ------------------ - -- Early reject if the crate is not among the allowed ones + procedure Add_Link_Pin (Crate : Crate_Name; + Pin : in out User_Pins.Pin) + is + begin - if not Allowed.Is_Empty and then not Allowed.Contains (Crate) then - return False; - end if; + -- Just in case this is a remote pin, deploy it - -- Regular checks if the crate is in the update set + if Exhaustive + or else + (Allowed.Is_Empty or else Allowed.Contains (Crate)) + then + Pin.Deploy (Crate => Crate, + Under => Pins_Dir, + Online => Exhaustive); + end if; - return - -- Any new pin needs downloading - not This.Solution.Links.Contains (Crate) + -- At this point, we can detect that a link is conflicting with + -- another one. - -- Manual update requested for pins without a precise commit - or else (Exhaustive and then not Pin.Commit.Has_Element) + if Sol.Depends_On (Crate) + and then Sol.State (Crate).Is_Linked + and then Sol.State (Crate).Link.Path /= Pin.Path + then + Raise_Checked_Error + ("Conflicting pin links for crate " & TTY.Name (Crate) + & ": Crate " & TTY.Name (Release (This).Name) + & " wants a link to " & TTY.URL (Pin.Path) + & ", but a previous link exists to " + & TTY.URL (Sol.State (Crate).Link.Path)); + end if; - -- Auto update for pins which weren't remote and now are - or else not This.Solution.State (Crate).Link.Is_Remote + -- TODO: test conflicting link detection for two pins - -- Auto update for pins whose commit has changed in manifest wrt - -- lockfile. - or else (Pin.Commit.Has_Element and then - Pin.Commit /= This.Solution.State (Crate) - .Link.Remote.Commit); - end Needs_Updating; + -- We have a new target root to load - begin - if (for some Pin of Pins => Pin.Is_Remote) then - Put_Info ("Checking remote pins..."); - end if; + declare + Target : constant Optional.Root := + Optional.Detect_Root (Pin.Path); + begin - for I in Pins.Iterate loop - if Pins (I).Is_Remote then - if Needs_Updating (Key (I), Pins (I)) then - - Put_Info ("Deploying pin for crate: " & TTY.Name (Key (I))); - - declare - use type Solutions.Solution; - Crate : constant Crate_Name := Key (I); - Pin : constant User_Pins.Pin := Element (I); - Result : constant Remote_Pin_Result := - This.Pinned_To_Remote - (Dependency => - Conditional.New_Dependency - (Rel.Dependency_On (Crate) - .Or_Else (Dependencies.From_String - ((+Crate) & "*"))), - URL => Pin.URL, - Commit => Pin.Commit.Or_Else (""), - Must_Depend => True); - begin - -- Pin deployed, solution can be stored accordingly - if This.Solution /= Result.Solution then - Solutions - .Diffs.Between (This.Solution, Result.Solution) - .Print (Changed_Only => True, - Level => Trace.Detail); - This.Set (Solution => Result.Solution); - Trace.Detail ("Remote pins committed to disk"); + -- Verify matching crate at the target location + + if Target.Is_Valid then + Trace.Debug + ("Crate found at pin location " & Pin.Relative_Path); + if Target.Value.Name /= Crate then + Raise_Checked_Error + ("Mismatched crates for pin linking to " + & TTY.URL (Pin.Path) & ": expected " & TTY.Name (Crate) + & " but found " + & TTY.Name (Target.Value.Name)); end if; - end; - else + else + Trace.Debug + ("No crate found at pin location " & Pin.Relative_Path); + end if; - Trace.Detail ("Skipping pre-existing pin for crate: " - & TTY.Name (Key (I))); + -- Add the best dependency we can find for the link if the user + -- hasn't given one in the manifest. - end if; - end if; - end loop; - end Deploy_Pins; + if not Sol.Depends_On (Crate) then + Sol := Sol.Depending_On + (if Target.Is_Valid + then Target.Updatable_Dependency + else Dependencies.New_Dependency + (Crate, Semantic_Versioning.Extended.Any)); + end if; - ---------------- - -- Prune_Pins -- - ---------------- + Sol := Sol + .Resetting (Crate) + .Linking (Crate, Pin); + + -- Add possible pins at the link target + + if Target.Is_Valid then + Add_Pins (Target.Value); + end if; + + end; + end Add_Link_Pin; + + Pins : constant User_Pins.Maps.Map := Release (This).Pins; + + begin + + -- Iterate over this root pins. Any pin that links to another root + -- will cause recursive pin loading. Remote pins are fetched in the + -- process, so they're available for use immediately. All link pins + -- have a proper path once this process completes. + + for I in Pins.Iterate loop + declare + use all type User_Pins.Kinds; + use User_Pins.Maps.Pin_Maps; + Crate : constant Crate_Name := Key (I); + Pin : User_Pins.Pin := Element (I); + begin + + Trace.Debug ("Crate " & TTY.Name (This.Name) + & " adds pin for crate " & TTY.Name (Crate)); + + case Pin.Kind is + when To_Version => + Add_Version_Pin (Crate, Pin); + when To_Path | To_Git => + Add_Link_Pin (Crate, Pin); + end case; + + Trace.Detail ("Crate " & TTY.Name (This.Name) + & " adds pin " & Sol.State (Crate).TTY_Image); + end; + end loop; + end Add_Pins; + + ---------------- + -- Prune_Pins -- + ---------------- + + procedure Prune_Pins is + begin + for Dep of Sol.User_Pins loop + Sol := Sol.User_Unpinning (Dep.Value.Crate); + end loop; + end Prune_Pins; - procedure Prune_Pins (This : in out Root) is use type Solutions.Solution; - Valid_Pins : constant User_Pins.Maps.Map := Release (This).Pins; - Pruned_Sol : Solutions.Solution := This.Solution; + begin - for State of This.Solution.All_Dependencies loop - if State.Is_User_Pinned and then - not Valid_Pins.Contains (State.Crate) - then - Pruned_Sol := Pruned_Sol.User_Unpinning (State.Crate); - Put_Info ("Unpinning crate " & TTY.Name (State.Crate)); - end if; - end loop; - if Pruned_Sol /= This.Solution then - Solutions.Diffs.Between (This.Solution, Pruned_Sol).Print + -- Remove any existing pins in the stored solution, to avoid conflicts + -- between old and new definitions of the same pin, and to discard + -- removed pins. + + Prune_Pins; + + -- Recursively add all pins from this workspace and other linked ones + + Add_Pins (This); + + if Sol /= This.Solution then + Solutions.Diffs.Between (This.Solution, Sol).Print (Changed_Only => True, Level => Trace.Detail); - Trace.Detail ("Pin-pruned solution committed to disk"); - This.Set (Pruned_Sol); + Trace.Detail ("Local pins updated and committed to lockfile"); + This.Set (Solution => Sol); end if; - end Prune_Pins; - - ----------------------------- - -- Sync_Pins_From_Manifest -- - ----------------------------- - - procedure Sync_Pins_From_Manifest - (This : in out Root; - Exhaustive : Boolean; - Allowed : Containers.Crate_Name_Sets.Set := - Containers.Crate_Name_Sets.Empty_Set) - is - begin - This.Deploy_Pins (Exhaustive, Allowed); - This.Apply_Local_Pins; - This.Prune_Pins; end Sync_Pins_From_Manifest; --------------- @@ -542,12 +544,12 @@ package body Alire.Roots is end loop; end loop; - -- Add paths for pinned folders + -- Add paths for raw pinned folders - for Link of This.Solution.Links loop - for Path of This.Solution.State (Link.Crate).Link.Project_Paths loop - Paths.Include (Path); -- These are absolute - end loop; + for Linked of This.Solution.Links loop + if not This.Solution.State (Linked.Crate).Has_Release then + Paths.Include (This.Solution.State (Linked.Crate).Link.Path); + end if; end loop; -- To match the output of root crate paths and Ada.Directories full path @@ -616,6 +618,13 @@ package body Alire.Roots is Release => Containers.To_Release_H (R), Cached_Solution => <>); + ---------- + -- Name -- + ---------- + + function Name (This : Root) return Crate_Name + is (This.Release.Constant_Reference.Name); + ---------- -- Path -- ---------- @@ -626,8 +635,8 @@ package body Alire.Roots is -- Release -- ------------- - function Release (This : Root) return Releases.Release is - (This.Release.Constant_Reference); + function Release (This : Root) return Releases.Release + is (This.Release.Element); ------------- -- Release -- @@ -649,7 +658,6 @@ package body Alire.Roots is Crate : Crate_Name) return Any_Path is - package Adirs renames Ada.Directories; Deps_Dir : constant Any_Path := This.Dependencies_Dir; begin if This.Release.Element.Name = Crate then @@ -657,7 +665,7 @@ package body Alire.Roots is elsif This.Solution.State (Crate).Is_Solved then return Deps_Dir / Release (This, Crate).Unique_Folder; elsif This.Solution.State (Crate).Is_Linked then - return Adirs.Full_Name (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"; end if; @@ -748,11 +756,18 @@ package body Alire.Roots is procedure Sync_From_Manifest (This : in out Root; Silent : Boolean; - Force : Boolean := False) is + Force : Boolean := False) + is Old_Solution : constant Solutions.Solution := This.Solution; begin if Force or else This.Is_Lockfile_Outdated then - Put_Info ("Detected changes in manifest, synchronizing workspace..."); + -- TODO: we may want to recursively check manifest timestamps of + -- linked crates to detect changes in these manifests and re-resolve. + -- Otherwise a manual `alr update` is needed to detect these changes. + -- This would imply to store the timestamps in our lockfile for + -- linked crates with a manifest. + + Put_Info ("Synchronizing workspace..."); This.Sync_Pins_From_Manifest (Exhaustive => False); -- Normally we do not want to re-fetch remote pins, so we request @@ -761,7 +776,6 @@ package body Alire.Roots is This.Sync_Dependencies (Old => Old_Solution, Silent => Silent); - -- 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 @@ -776,15 +790,25 @@ package body Alire.Roots is Trace.Info (""); -- Separate changes from what caused the sync end if; - if (for some Rel of This.Solution.Releases => - This.Solution.State (Rel.Name).Is_Solved and then - not GNAT.OS_Lib.Is_Directory (This.Release_Base (Rel.Name))) - or else - (for some Dep of This.Solution.Links => - This.Solution.State (Dep.Crate).Link.Is_Remote and then + -- The following checks may only succeed if the user has deleted + -- something externally, or after running `alr clean --cache`. + + -- Detect remote pins that are not at the expected location + + if (for some Dep of This.Solution.Links => This.Solution.State (Dep.Crate).Link.Is_Broken) then - Trace.Info ("Detected missing dependencies, updating workspace..."); + This.Sync_Pins_From_Manifest (Exhaustive => False); + end if; + + -- Detect dependencies that are not at the expected location + + if (for some Rel of This.Solution.Releases => + This.Solution.State (Rel.Name).Is_Solved and then + not GNAT.OS_Lib.Is_Directory (This.Release_Base (Rel.Name))) + then + Trace.Detail + ("Detected missing dependency sources, updating workspace..."); -- Some dependency is missing; redeploy. Should we clean first ??? This.Deploy_Dependencies; end if; @@ -959,178 +983,6 @@ package body Alire.Roots is end; end Sync_Dependencies; - ---------------------- - -- Pinned_To_Remote -- - ---------------------- - - function Pinned_To_Remote (This : in out Root; - Dependency : Conditional.Dependencies; - URL : String; - Commit : String; - Must_Depend : Boolean) - return Remote_Pin_Result - is - Requested_Crate : constant String := - (if Dependency.Is_Empty - then "" - else Dependency.Value.Crate.As_String); - begin - - -- Check whether are adding or modifying a dependency - - if Must_Depend and then not - (for some Dep of This.Release.Constant_Reference.Flat_Dependencies => - Dep.Crate.As_String = Requested_Crate) - then - Raise_Checked_Error - ("Cannot continue because the requested pin is not a dependency: " - & Requested_Crate); - end if; - - -- Identify the head commit/reference - - if Commit = "" or else not Origins.Is_Valid_Commit (Commit) then - declare - Ref_Commit : constant String := - VCSs.Git.Handler.Remote_Commit (URL, Ref => Commit); - begin - if Ref_Commit = "" then - Raise_Checked_Error ("Could not resolve reference to commit: " - & TTY.Emph (Commit)); - else - Put_Info ("Using commit " & TTY.Emph (Ref_Commit) - & " for reference " - & TTY.Emph (if Commit = "" then "HEAD" - else Commit)); - end if; - - return This.Pinned_To_Remote (Dependency => Dependency, - URL => URL, - Commit => Ref_Commit, - Must_Depend => Must_Depend); - end; - end if; - - -- Check out the remote - - declare - Temp : Directories.Temp_File; - Depl : constant Origins.Deployers.Deployer'Class := - Origins.Deployers.New_Deployer - (Origins.New_Git (URL, Commit)); - begin - - -- Skip checkout if link is already in the solution and with the same - -- commit. - - if Requested_Crate /= "" and then - This.Solution.Depends_On (+Requested_Crate) and then - This.Solution.Links.Contains (+Requested_Crate) and then - This.Solution.State (+Requested_Crate).Link.Remote.Commit = Commit - then - Trace.Debug ("Skipping checkout of remote link " - & TTY.Name (Requested_Crate) - & "#" - & TTY.URL (Commit)); - else - Depl.Deploy (Temp.Filename).Assert; - end if; - - -- Identify containing release, and if satisfying move it to its - -- final location in the release cache. - - declare - Linked_Root : constant Alire.Roots.Optional.Root := - Roots.Optional.Detect_Root (Temp.Filename); - Linked_Name : constant String := - (if Linked_Root.Is_Valid - then Linked_Root.Value.Release.Constant_Reference.Name_Str - else Requested_Crate); -- This may still be "" - Linked_Vers : constant String := - (if Linked_Root.Is_Valid - then Linked_Root.Value.Release.Constant_Reference - .Version.Image & "_" - else ""); - Linked_Path : constant Any_Path := - Directories.Find_Relative_Path - (Parent => Ada.Directories.Current_Directory, - Child => - This.Pins_Dir - / (Linked_Name & "_" - & Linked_Vers - & Depl.Base.Short_Unique_Id)); - begin - -- Fail if we needed to detect a crate and none found - - if Linked_Name = "" and Requested_Crate = "" then - Raise_Checked_Error - ("No crate specified and none found at remote."); - end if; - - -- Fail if we detected a crate not matching the requested one - - if Requested_Crate /= "" - and then Linked_Name /= "" - and then Requested_Crate /= Linked_Name - then - Raise_Checked_Error - ("Requested and retrieved crates do not match: " - & Requested_Crate & " /= " & Linked_Name); - end if; - - -- Fail if we are adding a crate that is already a dependency - - if not Must_Depend and then - (for some Dep - of This.Release.Constant_Reference.Flat_Dependencies => - Dep.Crate.As_String = Linked_Name) - then - Raise_Checked_Error - ("Cannot continue because crate is already a dependency: " - & Linked_Name); - end if; - - -- Everything OK, keep the release - - if not GNAT.OS_Lib.Is_Directory - (Adirs.Containing_Directory (Linked_Path)) - then - Adirs.Create_Path (Adirs.Containing_Directory (Linked_Path)); - end if; - - if not GNAT.OS_Lib.Is_Directory (Linked_Path) then - Ada.Directories.Rename (Temp.Filename, Linked_Path); - end if; - - -- Return the solution using the downloaded sources. For that, - -- we create a remote link, and use either the dependency we - -- were given (already in the manifest), or else the one found - -- at the remote. The version will be narrowed down during the - -- post-processing in `alr with`. - - declare - New_Link : constant Externals.Softlinks.External := - Externals.Softlinks.New_Remote - (Origin => Depl.Base, - Path => Linked_Path); - New_Dep : constant Conditional.Dependencies := - (if Dependency.Is_Empty - then Conditional.New_Dependency - (+Linked_Name, Semver.Extended.Any) - else Dependency); - begin - return Remote_Pin_Result' - (Crate_Length => Linked_Name'Length, - Crate => Linked_Name, - New_Dep => New_Dep, - Solution => This.Solution - .Depending_On (New_Dep.Value) - .Linking (+Linked_Name, New_Link)); - end; - end; - end; - end Pinned_To_Remote; - -------------------- -- Write_Manifest -- -------------------- diff --git a/src/alire/alire-roots.ads b/src/alire/alire-roots.ads index 4853f682..5bc20f03 100644 --- a/src/alire/alire-roots.ads +++ b/src/alire/alire-roots.ads @@ -1,6 +1,5 @@ private with AAA.Caches.Files; -with Alire.Conditional; with Alire.Containers; limited with Alire.Environment; private with Alire.Lockfiles; @@ -83,6 +82,9 @@ package Alire.Roots is procedure Export_Build_Environment (This : in out Root); -- Export the build environment (PATH, GPR_PROJECT_PATH) of the given root + function Name (This : Root) return Crate_Name; + -- Crate name of the root release + function Path (This : Root) return Absolute_Path; function Project_Paths (This : in out Root) @@ -92,6 +94,7 @@ package Alire.Roots is -- directories. function Release (This : Root) return Releases.Release; + -- Retrieve a the root release, i.e., the one described in the manifest function Release (This : in out Root; Crate : Crate_Name) @@ -190,26 +193,6 @@ package Alire.Roots is procedure Write_Manifest (This : Root); -- Generates the crate.toml manifest at the appropriate location for Root - type Remote_Pin_Result (Crate_Length : Natural) is record - Crate : String (1 .. Crate_Length); -- May be empty for a "raw" remote - New_Dep : Conditional.Dependencies; -- Requested one or else found one - Solution : Solutions.Solution; -- Includes new remote pin - end record; - - function Pinned_To_Remote (This : in out Root; - Dependency : Conditional.Dependencies; - URL : String; - Commit : String; - Must_Depend : Boolean) - return Remote_Pin_Result - with Pre => Dependency.Is_Empty or else Dependency.Is_Value; - -- Prepares a pin to a remote repo with specific commit. If - -- Dependency.Crate is not already a dependency, it will be added as - -- top-level, unless Must_Depend, in which case Checked_Error. If Commit - -- is "", the default tip commit in the remote will be used instead. If - -- Dependency.Is_Empty, a valid root must be found at the given commit. - -- If Crate /= "" and Commit contains a root, their crate name must match. - -- Files and folders derived from the root path (this obsoletes Alr.Paths): function Working_Folder (This : Root) return Absolute_Path; @@ -251,21 +234,4 @@ private Cached_Solution : Cached_Solutions.Cache; end record; - procedure Apply_Local_Pins (This : in out Root); - -- Apply version/path pins from the manifest. Remote pins are dealt with by - -- Deploy_Pins, as they are costlier and have more involved processing. - - procedure Deploy_Pins (This : in out Root; - Exhaustive : Boolean; - Allowed : Containers.Crate_Name_Sets.Set := - Containers.Crate_Name_Sets.Empty_Set); - -- Download any remote pins in the manifest. When not Exhaustive, a pin - -- that is already in the solution is not re-downloaded. This is to avoid - -- re-fetching all pins after each manifest edition. New pins are always - -- downloaded. An update requested by the user (`alr update`) will be - -- exhaustive. Allowed restricts which crates are affected - - procedure Prune_Pins (This : in out Root); - -- Remove any pins in the solution that are not in the manifest - end Alire.Roots; diff --git a/src/alire/alire-solutions-diffs.adb b/src/alire/alire-solutions-diffs.adb index d986ea41..bfb67db6 100644 --- a/src/alire/alire-solutions-diffs.adb +++ b/src/alire/alire-solutions-diffs.adb @@ -1,4 +1,5 @@ with Alire.Utils.Tables; +with Alire.User_Pins; with Alire.Utils.TTY; package body Alire.Solutions.Diffs is @@ -139,6 +140,7 @@ package body Alire.Solutions.Diffs is is ((not Has_Former or else Former.Fulfilment not in Fulfilment) and then Has_Latter and then Latter.Fulfilment in Fulfilment); + use type Alire.User_Pins.Pin; begin -- New hint if Gains_State (Hinted) then @@ -147,10 +149,10 @@ package body Alire.Solutions.Diffs is -- Changed linked dir target elsif Has_Latter and then Latter.Is_Linked and then (not Has_Former or else not Former.Is_Linked or else - Former.Link.Path /= Latter.Link.Path) + Former.Link /= Latter.Link) then Add_Change (Chg, Icon (Pinned), - "pin=" & TTY.URL (Latter.Link.Path)); + "pin=" & Latter.Link.Relative_Path); -- New unsolvable elsif Gains_State (Missed) then diff --git a/src/alire/alire-solutions.adb b/src/alire/alire-solutions.adb index c49c70e9..5e002e83 100644 --- a/src/alire/alire-solutions.adb +++ b/src/alire/alire-solutions.adb @@ -6,7 +6,6 @@ with Alire.Dependencies.Containers; with Alire.Dependencies.Diffs; with Alire.Dependencies.Graphs; with Alire.Index; -with Alire.Roots.Optional; with Alire.Root; with Alire.Solutions.Diffs; with Alire.Utils.Tables; @@ -296,52 +295,12 @@ package body Alire.Solutions is function Linking (This : Solution; Crate : Crate_Name; - Link : Externals.Softlinks.External) + Link : Dependencies.States.Softlink) return Solution - is - Linked_Root : constant Roots.Optional.Root := - Roots.Optional.Detect_Root (Link.Path); - begin - - -- Recursively find any other links - - return Result : Solution := (Solved => True, - Dependencies => - This.Dependencies.Including - (This.State (Crate).Linking (Link))) - do - if Linked_Root.Is_Valid and then Linked_Root.Value.Has_Lockfile then - declare - Linked_Solution : Solution renames Linked_Root.Value.Solution; - begin - - -- Go through any links in the linked release - - for Dep of Linked_Solution.Links loop - declare - - -- Create the new link for our own solution, composing - -- relative paths when possible. - - New_Link : constant Externals.Softlinks.External := - Linked_Solution - .State (Dep.Crate) - .Link.Relocate (From => Link.Path); - begin - - -- We may or not already depend on the transitively - -- linked release. Just in case, we add the dependency - -- before the link. - - Result := Result.Depending_On (Dep) - .Linking (Crate => Dep.Crate, - Link => New_Link); - end; - end loop; - end; - end if; - end return; - end Linking; + is (Solved => True, + Dependencies => + This.Dependencies.Including + (This.State (Crate).Linking (Link))); ------------------ -- New_Solution -- @@ -461,10 +420,10 @@ package body Alire.Solutions is & (if Detailed then " (origin: " & (if Dep.Is_Linked - then TTY.URL (Dep.Link.Path) + then Dep.Link.Relative_Path & (if Dep.Link.Is_Remote then " from " - & Dep.Link.Remote.TTY_URL_With_Commit + & Dep.Link.TTY_URL_With_Commit else "") -- no remote else Utils.To_Lower_Case (Rel.Origin.Kind'Img)) & ")" -- origin completed @@ -494,10 +453,10 @@ package body Alire.Solutions is else "") & (if Detailed and then Dep.Is_Linked then " (origin: " - & TTY.URL (Dep.Link.Path) + & Dep.Link.Relative_Path & (if Dep.Link.Is_Remote then " from " - & Dep.Link.Remote.TTY_URL_With_Commit + & Dep.Link.TTY_URL_With_Commit else "") -- no remote & ")" -- origin completed else ""), -- no details @@ -620,9 +579,9 @@ package body Alire.Solutions is if Dep.Is_Linked then Table .Append (TTY.Name (Dep.Crate)) - .Append (TTY.Version ("file:" & Dep.Link.Path)) + .Append (TTY.URL ("file:") & Dep.Link.Relative_Path) .Append (if Dep.Link.Is_Remote - then Dep.Link.Remote.TTY_URL_With_Commit + then Dep.Link.TTY_URL_With_Commit else "") .New_Row; elsif Dep.Is_Pinned then diff --git a/src/alire/alire-solutions.ads b/src/alire/alire-solutions.ads index 91d5bba6..2ce7b3ff 100644 --- a/src/alire/alire-solutions.ads +++ b/src/alire/alire-solutions.ads @@ -1,7 +1,6 @@ with Alire.Conditional; with Alire.Containers; with Alire.Dependencies.States.Maps; -with Alire.Externals.Softlinks; with Alire.Interfaces; with Alire.Properties; with Alire.Releases; @@ -118,17 +117,10 @@ package Alire.Solutions is function Linking (This : Solution; Crate : Crate_Name; - Link : Externals.Softlinks.External) + Link : Dependencies.States.Softlink) return Solution with Pre => This.Depends_On (Crate); - -- Replace the fulfilment of Crate with a "softlinked" external - - function Linking (This : Solution; - Crate : Crate_Name; - Path : Any_Path) - return Solution - with Pre => This.Depends_On (Crate); - -- As previous but giving a path for simplicity + -- Fulfill a dependency with a link pin function Missing (This : Solution; Dep : Dependencies.Dependency) @@ -491,16 +483,6 @@ private function Is_Complete (This : Solution) return Boolean is (This.Composition <= Releases); - ------------- - -- Linking -- - ------------- - - function Linking (This : Solution; - Crate : Crate_Name; - Path : Any_Path) - return Solution - is (This.Linking (Crate, Externals.Softlinks.New_Softlink (Path))); - ----------- -- Links -- ----------- diff --git a/src/alire/alire-user_pins-maps.adb b/src/alire/alire-user_pins-maps.adb index cb11dd82..cd4df7b5 100644 --- a/src/alire/alire-user_pins-maps.adb +++ b/src/alire/alire-user_pins-maps.adb @@ -19,18 +19,22 @@ package body Alire.User_Pins.Maps is & Table.Kind'Image); for Key of Table.Keys loop - if Result.Contains (+(+Key)) then - This.Checked_Error ("pin for crate " & (+Key) - & " is specified more than once"); - end if; - - -- Obtain a single pin - - Result.Insert (+(+Key), - User_Pins.From_TOML - (This.Descend - (Value => Table.Get (Key), - Context => +Key))); + declare + Crate : constant Crate_Name := +(+Key); + begin + if Result.Contains (Crate) then + This.Checked_Error ("pin for crate " & (+Crate) + & " is specified more than once"); + end if; + + -- Obtain a single pin + + Result.Insert (Crate, + User_Pins.From_TOML + (This.Descend + (Value => Table.Get (Key), + Context => +Key))); + end; end loop; end; end loop; diff --git a/src/alire/alire-user_pins.adb b/src/alire/alire-user_pins.adb index 14e4d63a..9f1bf520 100644 --- a/src/alire/alire-user_pins.adb +++ b/src/alire/alire-user_pins.adb @@ -1,16 +1,244 @@ +with Ada.Directories; + +with Alire.Directories; with Alire.Origins; +with Alire.Roots.Optional; +with Alire.Utils.TTY; +with Alire.Utils.User_Input; +with Alire.VCSs.Git; +with Alire.VFS; -with TOML; +with GNAT.OS_Lib; package body Alire.User_Pins is + package TTY renames Alire.Utils.TTY; + package Keys is - Commit : constant String := "commit"; - Path : constant String := "path"; - URL : constant String := "url"; - Version : constant String := "version"; + Commit : constant String := "commit"; + Internal : constant String := "lockfiled"; + Path : constant String := "path"; + URL : constant String := "url"; + Version : constant String := "version"; end Keys; + --------------- + -- Is_Broken -- + --------------- + + function Is_Broken (This : Pin) return Boolean + is (not Ada.Directories.Exists (Path (This)) + or else Ada.Directories.Kind (Path (This)) + not in Ada.Directories.Directory); + + ------------ + -- Deploy -- + ------------ + + procedure Deploy (This : in out Pin; + Crate : Crate_Name; + Under : Any_Path; + Online : Boolean) + is + use Ada.Strings.Unbounded; + use Directories.Operators; + + Folder : constant String := + (+Crate) + & (if This.Is_Remote and then This.Commit /= "" + then "_" & Origins.Short_Commit (+This.Commit) + else ""); + + Destination : constant String := + Ada.Directories.Full_Name (Under / Folder); + + -------------- + -- Checkout -- + -------------- + + procedure Checkout (Branch : String := ""; Commit : String := "") + with Pre => not (Branch /= "" and then Commit /= ""); + -- Pass only a commit or a branch. If none, default remote head. + + procedure Checkout (Branch : String := ""; + Commit : String := "") + is + package Adirs renames Ada.Directories; + Temp : Directories.Temp_File; + begin + + -- Check out the branch or commit + + if not + VCSs.Git.Handler.Clone + (From => URL (This) & (if Commit /= "" + then "#" & Commit + else ""), + Into => Temp.Filename, + Branch => Branch, -- May be empty for default branch + Depth => 1).Success + then + Raise_Checked_Error + ("Checkout of repository at " & TTY.URL (URL (This)) + & " failed, re-run with -vv -d for details"); + end if; + + -- Successful checkout + + if not Adirs.Exists (Adirs.Containing_Directory (Destination)) then + Adirs.Create_Path (Adirs.Containing_Directory (Destination)); + end if; + Adirs.Rename (Temp.Filename, Destination); + Temp.Keep; + end Checkout; + + ------------ + -- Update -- + ------------ + + procedure Update is + begin + Trace.Detail ("Checking out pin " & TTY.Name (Crate) & " at " + & TTY.URL (Destination)); + + -- If the fetch URL has been changed, fall back to checkout + + if VCSs.Git.Handler.Fetch_URL + (Repo => Destination, + Public => False) /= This.URL + then + Put_Info ("Switching pin " & TTY.Name (Crate) & " to origin at " + & TTY.URL (+This.URL)); + Ada.Directories.Delete_Tree (Destination); + Checkout; -- Pending branch tracking implementation + return; + end if; + + -- Finally update + + if not VCSs.Git.Handler.Update (Destination).Success then + Raise_Checked_Error + ("Update of repository at " & TTY.URL (Destination) + & " failed, re-run with -vv -d for details"); + end if; + end Update; + + begin + + -- Check when to do nothing + + if not This.Is_Remote then + return; + end if; + + This.Local_Path := +Destination; + + -- Don't check out an already existing commit pin, or a non-update + -- branch pin + + if Ada.Directories.Exists (Destination) + and then + (This.Commit /= "" or else not Online) + then + Trace.Debug ("Skipping deployment of already existing pin at " + & TTY.URL (Destination)); + return; + end if; + + -- Check out a fixed commit, a branch, or update a branch are the three + -- remaining possibilities. + + if This.Commit /= "" then + Checkout (Commit => +This.Commit); + + elsif Ada.Directories.Exists (Destination) then + Update; + + else + Checkout; + + end if; + + -- At this point, we have the sources at Destination. Last checks ensue. + + declare + Root : constant Roots.Optional.Root := + Roots.Optional.Detect_Root (Destination); + begin + + -- Check crate name mismatch + + if Root.Is_Valid and then + Crate /= Root.Value.Release.Name + then + Raise_Checked_Error + ("Requested and retrieved crates do not match: " + & TTY.Name (Crate) & " /= " + & TTY.Name (Root.Value.Release.Name)); + end if; + + -- Warn if raw project + + if not Root.Is_Valid then + Put_Warning + ("Pin for " & TTY.Name (Crate) & " does not contain an Alire " + & "manifest. It will be used as a raw GNAT project."); + end if; + + end; + + end Deploy; + + ------------------------- + -- TTY_URL_With_Commit -- + ------------------------- + + function TTY_URL_With_Commit (This : Pin) return String + is (TTY.URL (URL (This)) + & (if Commit (This).Has_Element + then "#" & TTY.Emph (Commit (This).Element.Ptr.all) + else "")); + + ---------- + -- Path -- + ---------- + + function Path (This : Pin) return Absolute_Path + is + -- Having this as an expression function causes CE2021 to return a + -- corrupted string some times. + begin + case This.Kind is + when To_Path => + return +This.Path; + when To_Git => + if +This.Local_Path /= "" then + return +This.Local_Path; + else + raise Program_Error with "Undeployed pin"; + end if; + when others => + raise Program_Error with "invalid pin kind"; + end case; + end Path; + + ------------------- + -- Relative_Path -- + ------------------- + + function Relative_Path (This : Pin; Color : Boolean := True) return String + is + Portable : constant String := + VFS.Attempt_Portable + (Directories.Find_Relative_Path_To (Path (This))); + begin + if Color then + return TTY.URL (Portable); + else + return Portable; + end if; + end Relative_Path; + --------------- -- From_TOML -- --------------- @@ -23,30 +251,100 @@ package body Alire.User_Pins is function From_Table (This : TOML_Adapters.Key_Queue) return Pin is use TOML; + + ------------------- + -- From_Lockfile -- + ------------------- + -- Special case loader for pins not described by the user, but stored + -- by us in the lockfile. These already have a path for the pin. + function From_Lockfile return Pin is + begin + This.Assert + (This.Checked_Pop (Keys.Internal, TOML_Boolean).As_Boolean, + "Boolean expected"); + + if This.Contains (Keys.URL) then + return Result : Pin := (Kind => To_Git, others => <>) do + Result.URL := + +This.Checked_Pop (Keys.URL, + TOML_String).As_String; + + Result.Local_Path := + +Utils.User_Input.To_Absolute_From_Portable + (This.Checked_Pop (Keys.Path, TOML_String).As_String); + + if This.Contains (Keys.Commit) then + Result.Commit := + +This.Checked_Pop (Keys.Commit, TOML_String).As_String; + end if; + end return; + else + return Result : Pin := (Kind => To_Path, others => <>) do + Result.Path := + +Utils.User_Input.To_Absolute_From_Portable + (This.Checked_Pop (Keys.Path, TOML_String).As_String); + end return; + end if; + end From_Lockfile; + begin - if This.Contains (Keys.Version) then + if This.Contains (Keys.Internal) then + return Result : constant Pin := From_Lockfile do + This.Report_Extra_Keys; + end return; + + elsif This.Contains (Keys.Version) then return Pin' (Kind => To_Version, Version => Semantic_Versioning.Parse (This.Checked_Pop (Keys.Version, TOML_String).As_String)); elsif This.Contains (Keys.Path) then - return Result : constant Pin := + return Result : Pin := (Kind => To_Path, - Path => +This.Checked_Pop (Keys.Path, TOML_String).As_String) + Path => <>) do - if not GNAT.OS_Lib.Is_Directory (+Result.Path) then - Raise_Checked_Error ("Pin path is not a valid directory: " - & (+Result.Path)); - end if; - This.Report_Extra_Keys; + declare + User_Path : constant String := + This.Checked_Pop (Keys.Path, + TOML_String).As_String; + begin + This.Report_Extra_Keys; + + -- Check that the path was stored in portable format or as + -- absolute path. + + if not Check_Absolute_Path (User_Path) and then + not VFS.Is_Portable (User_Path) + then + This.Recoverable_Error + ("Pin relative paths must use forward slashes " + & "to be portable: " & Utils.TTY.URL (User_Path)); + end if; + + -- Make the path absolute if not already, and store it + + Result.Path := + +Utils.User_Input.To_Absolute_From_Portable + (User_Path => User_Path, + Error_When_Relative_Native => + "Pin relative paths must use forward slashes " & + " to be portable"); + + if not GNAT.OS_Lib.Is_Directory (+Result.Path) then + This.Checked_Error ("Pin path is not a valid directory: " + & (+Result.Path)); + end if; + end; end return; elsif This.Contains (Keys.URL) then return Result : Pin := - (Kind => To_Git, - URL => +This.Checked_Pop (Keys.URL, TOML_String).As_String, - Commit => <>) + (Kind => To_Git, + URL => +This.Checked_Pop (Keys.URL, + TOML_String).As_String, + Commit => <>, + Local_Path => <>) do if This.Contains (Keys.Commit) then Result.Commit := @@ -89,4 +387,35 @@ package body Alire.User_Pins is Raise_Checked_Error ("Malformed semantic version in pin"); end From_TOML; + ------------- + -- To_TOML -- + ------------- + + function To_TOML (This : Pin) return TOML.TOML_Value is + use TOML; + Table : constant TOML_Value := Create_Table; + begin + + -- Pins going into the lockfile require all the information; we must + -- also notify the loader not to report unexpected keys + + if This.Is_Remote then + Table.Set (Keys.URL, + Create_String + (URL (This))); + + if Commit (This).Has_Element then + Table.Set (Keys.Commit, + Create_String (Commit (This).Element.Ptr.all)); + end if; + end if; + + Table.Set (Keys.Path, + Create_String (VFS.Attempt_Portable (Path (This)))); + + Table.Set (Keys.Internal, Create_Boolean (True)); + + return Table; + end To_TOML; + end Alire.User_Pins; diff --git a/src/alire/alire-user_pins.ads b/src/alire/alire-user_pins.ads index 637d2eef..d7903d82 100644 --- a/src/alire/alire-user_pins.ads +++ b/src/alire/alire-user_pins.ads @@ -3,6 +3,8 @@ with Alire.TOML_Adapters; with Semantic_Versioning; +with TOML; + package Alire.User_Pins is -- User-facing representation of pins. These are loaded from the manifest. @@ -20,6 +22,8 @@ package Alire.User_Pins is To_Path, To_Version); + subtype Kinds_With_Path is Kinds range To_Git .. To_Path; + type Pin (Kind : Kinds) is tagged private; function Is_Remote (This : Pin) return Boolean; @@ -32,8 +36,19 @@ package Alire.User_Pins is -- Local path attributes - function Path (This : Pin) return Any_Path - with Pre => This.Kind = To_Path; + function Is_Broken (This : Pin) return Boolean + with Pre => This.Kind in Kinds_With_Path; + + function Path (This : Pin) return Absolute_Path + with Pre => This.Kind in Kinds_With_Path; + -- May raise if a Git pin hasn't been yet deployed (see Deploy proc). Even + -- if paths can be given as relative, for our internal processing we can + -- simplify things by always relying on absolute paths. + + function Relative_Path (This : Pin; Color : Boolean := True) return String + with Pre => This.Kind in Kinds_With_Path; + -- Convenience to show to users. May still return an absolute path for + -- paths in another drive on Windows. May include TTY sequences. -- Remote attributes @@ -43,8 +58,27 @@ package Alire.User_Pins is function Commit (This : Pin) return Optional.String with Pre => This.Is_Remote; + function TTY_URL_With_Commit (This : Pin) return String + with Pre => This.Is_Remote; + + procedure Deploy (This : in out Pin; + Crate : Crate_Name; + Under : Any_Path; + Online : Boolean) + with Pre => This.Kind in Kinds_With_Path, + Post => Path (This) /= ""; + -- Will fetch a remote pin and fill its local path; it is a no-op + -- otherwise. Under is the umbrella folder for all pins, not the final pin + -- destination. If Online, branch pins will be checked for updates. Any pin + -- sources not at their expected final path (computed in here depending on + -- the pin kind) will be checked out anyway. + + -- Pin loading from manifest + function From_TOML (This : TOML_Adapters.Key_Queue) return Pin; -- Expects the rhs of a crate = entry. The rhs is always a table. + -- Must be called with PWD being the same as of the manifest that is being + -- loaded, so relative pins are correct. -- The TOML representation of a pin is similar to a dependency, but instead -- of a version set, we get either a precise version, or an url + commit: @@ -54,15 +88,21 @@ package Alire.User_Pins is -- foo = { path = "/path/to/folder" } -- bar = { url = "git+https://blah", [commit = "deadbeef"] } + function To_TOML (This : Pin) return TOML.TOML_Value + with Pre => This.Kind in Kinds_With_Path; + -- Used by the lockfile + private type Pin (Kind : Kinds) is tagged record case Kind is when To_Git => - URL : UString; - Commit : UString; -- Optional + URL : UString; + Commit : UString; -- Optional + Local_Path : Unbounded_Absolute_Path; + -- Empty until the pin is locally deployed when To_Path => - Path : UString; + Path : Unbounded_Absolute_Path; when To_Version => Version : Semantic_Versioning.Version; end case; @@ -83,13 +123,6 @@ private function Is_Remote (This : Pin) return Boolean is (This.Kind in To_Git); - - ---------- - -- Path -- - ---------- - - function Path (This : Pin) return Any_Path is (+This.Path); - --------- -- URL -- --------- diff --git a/src/alire/alire-utils-user_input.adb b/src/alire/alire-utils-user_input.adb index add7a6e6..1f4d84bf 100644 --- a/src/alire/alire-utils-user_input.adb +++ b/src/alire/alire-utils-user_input.adb @@ -1,3 +1,4 @@ +with Ada.Directories; with Ada.Text_IO; with Ada.Characters.Handling; @@ -6,6 +7,7 @@ with GNAT.OS_Lib; with Interfaces.C_Streams; with Alire.Utils.TTY; +with Alire.VFS; package body Alire.Utils.User_Input is @@ -322,4 +324,32 @@ package body Alire.Utils.User_Input is end loop; end Validated_Input; + ------------------------------- + -- To_Absolute_From_Portable -- + ------------------------------- + + function To_Absolute_From_Portable + (User_Path : String; + Error_When_Relative_Native : String := + "relative paths must use forward slashes to be portable") + return Absolute_Path + is + begin + if not Check_Absolute_Path (User_Path) and then + not VFS.Is_Portable (User_Path) + then + Recoverable_Error + (Error_When_Relative_Native & ": " & TTY.URL (User_Path)); + end if; + + -- Make the path absolute if not already, and store it + + return + Ada.Directories.Full_Name + (if VFS.Is_Portable (User_Path) + then VFS.To_Native (Portable_Path (User_Path)) + else User_Path); + + end To_Absolute_From_Portable; + end Alire.Utils.User_Input; diff --git a/src/alire/alire-utils-user_input.ads b/src/alire/alire-utils-user_input.ads index f225454c..667fc751 100644 --- a/src/alire/alire-utils-user_input.ads +++ b/src/alire/alire-utils-user_input.ads @@ -83,4 +83,20 @@ package Alire.Utils.User_Input is -- does not exist, we allow to continue only after user confirmation (or -- forcing). Returns whether to proceed. + ---------------- + -- VALIDATION -- + ---------------- + + function To_Absolute_From_Portable + (User_Path : String; + Error_When_Relative_Native : String := + "relative paths must use forward slashes to be portable") + return Absolute_Path; + -- Paths given by the user in the manifest have to be vetted for + -- portability. If they are absolute there is nothing to do; but if they + -- are relative they may be native or portable. Here we check if a relative + -- path is portable (which is desirable so a manifest/lockfile can work + -- across OSes) and, for internal processing, we convert it in any case + -- to a native absolute path. + end Alire.Utils.User_Input; diff --git a/src/alire/alire-vcss-git.adb b/src/alire/alire-vcss-git.adb index 4835e59d..d8bfd9d2 100644 --- a/src/alire/alire-vcss-git.adb +++ b/src/alire/alire-vcss-git.adb @@ -79,7 +79,8 @@ package body Alire.VCSs.Git is function Clone (This : VCS; From : URL; Into : Directory_Path; - Branch : String) + Branch : String; + Depth : Natural := 0) return Outcome is pragma Unreferenced (This); @@ -87,15 +88,21 @@ package body Alire.VCSs.Git is Empty_Vector & (if Log_Level < Trace.Info then "-q" - else "--progress") - & (if Branch /= "" - then Empty_Vector & "--branch" & Branch + else "--progress"); + Depth_Opts : constant String_Vector := + (if Depth /= 0 and then Commit (From) = "" + then Empty_Vector & "--depth" & Utils.Trim (Depth'Image) + & "--no-single-branch" -- but all tips else Empty_Vector); + Branch_Opts : constant String_Vector := + (if Branch /= "" + then Empty_Vector & "--branch" & Branch + else Empty_Vector); begin Trace.Detail ("Checking out [git]: " & From); Run_Git (Empty_Vector & "clone" & "--recursive" & - Extra & Repo (From) & Into); + Extra & Branch_Opts & Depth_Opts & Repo (From) & Into); if Commit (From) /= "" then declare @@ -389,8 +396,17 @@ package body Alire.VCSs.Git is function Update (This : VCS; Repo : Directory_Path) return Outcome + is (This.Update (Repo, Branch => "")); + + ------------ + -- Update -- + ------------ + + function Update (This : VCS; + Repo : Directory_Path; + Branch : String) + return Outcome is - pragma Unreferenced (This); Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; Extra : constant String_Vector := @@ -399,7 +415,35 @@ package body Alire.VCSs.Git is else Empty_Vector & "--progress"); begin - Run_Git (Empty_Vector & "pull" & Extra); + -- Switch branch if changed + + if Branch /= "" and then This.Branch (Repo) /= Branch then + + Trace.Detail ("Detected branch change needed in git update at " + & TTY.URL (Repo) & "; switching from " + & TTY.Emph (This.Branch (Repo)) & " to " + & TTY.Emph (Branch)); + + Run_Git (Empty_Vector & "fetch"); + -- In case there are new remote branches + + Run_Git (Empty_Vector + & "checkout" + & String'(This.Remote (Repo) & "/" & Branch) + & "-B" + & Branch + & Extra + & "--recurse-submodules"); + -- Force overwrite any previous local same branch. Since we just + -- fetched, the checkout should be up to date and there's no need + -- to additionally pull. + + else + + Run_Git (Empty_Vector & "pull" & Extra & "--recurse-submodules"); + -- Plain pull + + end if; return Outcome_Success; exception diff --git a/src/alire/alire-vcss-git.ads b/src/alire/alire-vcss-git.ads index 17e1f4c3..e7904a71 100644 --- a/src/alire/alire-vcss-git.ads +++ b/src/alire/alire-vcss-git.ads @@ -25,9 +25,12 @@ package Alire.VCSs.Git is function Clone (This : VCS; From : URL; Into : Directory_Path; - Branch : String) + Branch : String; + Depth : Natural := 0) return Outcome; - -- Specify a branch to check out after cloning + -- Specify a branch to check out after cloning. Branch may be "" for the + -- default remote branch. For any Depth /= 0, apply --depth . A + -- commit may be specified as From#Commit_Id not overriding function Remote_Commit (This : VCS; @@ -67,6 +70,13 @@ package Alire.VCSs.Git is Repo : Directory_Path) return Outcome; + not overriding + function Update (This : VCS; + Repo : Directory_Path; + Branch : String) + return Outcome; + -- Update and track Branch, if given. + type States is (Dirty, -- Uncommited local changes No_Remote, -- Clean, no remote configured Clean, -- Clean, up to date with remote diff --git a/src/alire/alire-vfs.adb b/src/alire/alire-vfs.adb index 79c116f5..ad830d1b 100644 --- a/src/alire/alire-vfs.adb +++ b/src/alire/alire-vfs.adb @@ -1,5 +1,24 @@ package body Alire.VFS is + ---------------------- + -- Attempt_Portable -- + ---------------------- + + function Attempt_Portable (Path : Any_Path; + From : Any_Path := Directories.Current) + return String + is + Relative : constant Any_Path := + Directories.Find_Relative_Path (Parent => From, + Child => Path); + begin + if Check_Absolute_Path (Relative) then + return Path; + else + return String (To_Portable (Relative)); + end if; + end Attempt_Portable; + -------------- -- Read_Dir -- -------------- diff --git a/src/alire/alire-vfs.ads b/src/alire/alire-vfs.ads index dcf66b95..5f219d04 100644 --- a/src/alire/alire-vfs.ads +++ b/src/alire/alire-vfs.ads @@ -1,5 +1,6 @@ with Ada.Containers.Vectors; +with Alire.Directories; private with Alire.Utils; private with GNATCOLL.OS.Constants; @@ -10,6 +11,15 @@ package Alire.VFS is -- Portable paths are relative and use forward slashes. Absolute paths -- cannot be portable. + function Is_Portable (Path : Any_Path) return Boolean; + -- Say if the path may be safely cast to a portable path + + function Attempt_Portable (Path : Any_Path; + From : Any_Path := Directories.Current) + return String; + -- If Path seen from From is relative, convert to portable, else return + -- as-is + function To_Portable (Path : Relative_Path) return Portable_Path; function To_Native (Path : Portable_Path) return Relative_Path; @@ -68,6 +78,15 @@ private use all type GNATCOLL.OS.OS_Type; + ----------------- + -- Is_Portable -- + ----------------- + + function Is_Portable (Path : Any_Path) return Boolean + is ((for all Char of Path => Char /= '\') + and then + not Check_Absolute_Path (Path)); + ----------------- -- To_Portable -- ----------------- diff --git a/src/alire/alire.ads b/src/alire/alire.ads index 1d94a02d..47ecb170 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -9,7 +9,7 @@ with Simple_Logging; package Alire with Preelaborate is - Version : constant String := "1.1.0-dev+0f603c29"; + Version : constant String := "1.1.0-dev+recpins"; -- 1.1.0-dev: begin post-1.0 changes -- 1.0.0: no changes since rc3 -- 1.0.0-rc3: added help colors PR @@ -140,6 +140,11 @@ package Alire with Preelaborate is subtype Absolute_Path is Any_Path with Dynamic_Predicate => Check_Absolute_Path (Absolute_Path); + subtype Unbounded_Absolute_Path is UString + with Dynamic_Predicate => + +Unbounded_Absolute_Path = "" or else + Check_Absolute_Path (+Unbounded_Absolute_Path); + subtype Relative_File is Any_Path; -- Filenames with relative paths diff --git a/src/alr/alr-commands-pin.adb b/src/alr/alr-commands-pin.adb index 31b62fe1..2a91151d 100644 --- a/src/alr/alr-commands-pin.adb +++ b/src/alr/alr-commands-pin.adb @@ -1,5 +1,3 @@ -with Alire.Conditional; -with Alire.Dependencies; with Alire.Releases; with Alire.Solutions.Diffs; with Alire.Pinning; @@ -202,13 +200,17 @@ package body Alr.Commands.Pin is if Cmd.Commit.all /= "" or else Alire.URI.Is_HTTP_Or_Git (Cmd.URL.all) then - New_Sol := Cmd.Root.Pinned_To_Remote - (Dependency => Alire.Conditional.New_Dependency - (Alire.Dependencies.From_String (Argument (1))), - URL => Cmd.URL.all, - Commit => Cmd.Commit.all, - Must_Depend => True) - .Solution; + null; + -- This is slated for removal in the immediate future; kept for + -- reference for the replacement implementation + + -- New_Sol := Cmd.Root.Pinned_To_Remote + -- (Dependency => Alire.Conditional.New_Dependency + -- (Alire.Dependencies.From_String (Argument (1))), + -- URL => Cmd.URL.all, + -- Commit => Cmd.Commit.all, + -- Must_Depend => True) + -- .Solution; else -- Pin to dir @@ -220,12 +222,15 @@ package body Alr.Commands.Pin is Cmd.Requires_Full_Index; -- Next statement recomputes a solution - New_Sol := Alire.Pinning.Pin_To - (+Argument (1), - Cmd.URL.all, - Cmd.Root.Release.Dependencies, - Platform.Properties, - Old_Sol); + -- This is slated for removal in the immediate future; kept for + -- reference for the replacement implementation + + -- New_Sol := Alire.Pinning.Pin_To + -- (+Argument (1), + -- Cmd.URL.all, + -- Cmd.Root.Release.Dependencies, + -- Platform.Properties, + -- Old_Sol); end if; diff --git a/src/alr/alr-commands-withing.adb b/src/alr/alr-commands-withing.adb index d8ddce65..3ae29756 100644 --- a/src/alr/alr-commands-withing.adb +++ b/src/alr/alr-commands-withing.adb @@ -71,47 +71,6 @@ package body Alr.Commands.Withing is Requested.Versions); end Add; - --------------------- - -- Add_Remote_Link -- - --------------------- - - procedure Add_Remote_Link (Cmd : in out Command; - Dep : String) - is - use Alire; - Old_Deps : constant Conditional.Dependencies := - Cmd.Root.Release.Dependencies; - New_Dep : constant Alire.Conditional.Dependencies := - (if Dep = "" - then Alire.Conditional.No_Dependencies - else Alire.Conditional.New_Dependency - (Alire.Dependencies.From_String (Dep))); - New_Solution : constant Roots.Remote_Pin_Result := - Cmd.Root.Pinned_To_Remote - (Dependency => New_Dep, - URL => Cmd.URL.all, - Commit => Cmd.Commit.all, - Must_Depend => False); - use type Conditional.Dependencies; - begin - - -- Report crate detection at target destination - - User_Input.Report_Pinned_Crate_Detection (+New_Solution.Crate, - New_Solution.Solution); - - -- If we made here there were no errors adding the dependency - -- and storing the softlink. We can proceed to confirming the - -- replacement. - - Replace_Current (Cmd, - Old_Deps => Old_Deps, - New_Deps => Old_Deps and New_Solution.New_Dep, - Old_Solution => New_Solution.Solution); - -- We use the New_Solution with the softlink as previous solution, so - -- the pinned directory is used by the solver. - end Add_Remote_Link; - ------------------ -- Add_Softlink -- ------------------ @@ -119,6 +78,7 @@ package body Alr.Commands.Withing is procedure Add_Softlink (Cmd : in out Command; Dep_Spec : String; Path : String) is + pragma Unreferenced (Path); New_Dep : constant Alire.Dependencies.Dependency := Alire.Dependencies.From_String (Dep_Spec); begin @@ -137,11 +97,14 @@ package body Alr.Commands.Withing is Old_Deps : constant Conditional.Dependencies := Cmd.Root.Release.Dependencies; Old_Solution : constant Solutions.Solution := Cmd.Root.Solution; - New_Solution : constant Solutions.Solution := - Old_Solution - .Depending_On (New_Dep) - .Linking (Crate => New_Dep.Crate, - Path => Path); + New_Solution : constant Solutions.Solution := Old_Solution; + -- The following is slated for refactoring in the follow-up PR. Kept + -- momentarily for reference. + -- Old_Solution + -- .Depending_On (New_Dep) + -- .Linking (Crate => New_Dep.Crate, + -- Path => Path); + -- TODO: remove this dead code in PR fixing alr with begin -- Prevent double-add @@ -575,10 +538,13 @@ package body Alr.Commands.Withing is -- Pin to remote repo - Add_Remote_Link (Cmd, - Dep => (if Num_Arguments = 1 - then Argument (1) - else "")); + null; + + -- Slated for immediate removal; kept momentarily for reference + -- Add_Remote_Link (Cmd, + -- Dep => (if Num_Arguments = 1 + -- then Argument (1) + -- else "")); else diff --git a/src/alr/alr-commands.adb b/src/alr/alr-commands.adb index fe27ddd1..6fd2696e 100644 --- a/src/alr/alr-commands.adb +++ b/src/alr/alr-commands.adb @@ -540,21 +540,6 @@ package body Alr.Commands is Sync : Boolean := True) is use Alire; - ------------------------------ - -- Notify_Of_Initialization -- - ------------------------------ - - procedure Notify_Of_Initialization is - -- Tell the user we are automatically computing the first solution - -- for the workspace. We don't want to say this when no Sync, as a - -- manually requested update is coming. - begin - if Sync then - Trace.Info - ("No dependency solution found, updating workspace..."); - end if; - end Notify_Of_Initialization; - Unchecked : Alire.Roots.Optional.Root renames Cmd.Optional_Root; Manual_Only : constant Boolean := @@ -612,9 +597,6 @@ package body Alr.Commands is Cmd.Requires_Full_Index (Strict => False); Checked.Sync_From_Manifest (Silent => True); return; - else - Notify_Of_Initialization; - -- And fall through end if; else @@ -635,9 +617,6 @@ package body Alr.Commands is Ada.Directories.Delete_File (Checked.Lock_File); when Lockfiles.Missing => - -- Notify the user. This may happen e.g. after first cloning. - Notify_Of_Initialization; - -- For the record, with the full path Trace.Debug ("Workspace has no lockfile at " & Checked.Lock_File); diff --git a/testsuite/drivers/alr.py b/testsuite/drivers/alr.py index 379c097e..66375996 100644 --- a/testsuite/drivers/alr.py +++ b/testsuite/drivers/alr.py @@ -212,10 +212,11 @@ def alr_manifest(): return "alire.toml" -def alr_unpin(crate, manual=True, fail_if_missing=True): +def alr_unpin(crate, manual=True, fail_if_missing=True, update=True): """ Unpin a crate, if pinned, or no-op otherwise. Will edit the manifest or use the command-line, according to manual. Must be run in a crate root. + If update, run `alr pin` to force computation of new solution """ if manual: @@ -239,7 +240,9 @@ def alr_unpin(crate, manual=True, fail_if_missing=True): # Make the lockfile "older" (otherwise timestamp is identical) os.utime("alire.lock", (0, 0)) - run_alr("pin") # Ensure changes don't affect next command output + + if update: + run_alr("pin") # Ensure changes don't affect next command output elif fail_if_missing: raise RuntimeError (f"Could not unpin crate {crate} in lines:\n" + str(orig)) @@ -248,10 +251,12 @@ def alr_unpin(crate, manual=True, fail_if_missing=True): raise NotImplementedError("Unimplemented") -def alr_pin(crate, version="", path="", url="", commit="", manual=True): +def alr_pin(crate, version="", path="", url="", commit="", + manual=True, update=True): """ Pin a crate, either manually or using the command-line interface. Use only one of version, path, url. Must be run in a crate root. + When update, run `alr pin` so the new solution is computed. """ if manual: @@ -260,11 +265,11 @@ def alr_pin(crate, version="", path="", url="", commit="", manual=True): if version != "": pin_line = f'{crate} = {{ version = "{version}" }}' elif path != "": - pin_line = f'{crate} = {{ path = "{path}" }}' + pin_line = f"{crate} = {{ path = '{path}' }}" # literal so \ works elif url != "" and commit != "": - pin_line = f'{crate} = {{ url = "{path}", commit = "{commit}" }}' + pin_line = f"{crate} = {{ url = '{url}', commit = '{commit}' }}" elif url != "": - pin_line = f'{crate} = {{ url = "{path}" }}' + pin_line = f"{crate} = {{ url = '{url}' }}" else: raise ValueError("Specify either version, path or url") @@ -274,7 +279,8 @@ def alr_pin(crate, version="", path="", url="", commit="", manual=True): # Make the lockfile "older" (otherwise timestamp is identical) os.utime("alire.lock", (0, 0)) - run_alr("pin") # so the changes in the manifest are applied + if update: + run_alr("pin") # so the changes in the manifest are applied else: raise NotImplementedError("Unimplemented") diff --git a/testsuite/drivers/helpers.py b/testsuite/drivers/helpers.py index feeb9f62..314c671a 100644 --- a/testsuite/drivers/helpers.py +++ b/testsuite/drivers/helpers.py @@ -6,6 +6,7 @@ from subprocess import run from zipfile import ZipFile import os +import platform # Return the entries (sorted) under a given folder, both folders and files @@ -50,7 +51,11 @@ def check_line_in(filename, line): break else: assert False, 'Could not find {} in {}:\n{}'.format( - repr(line), filename, content_of (filename)) + repr(line), filename, content_of(filename)) + + +def on_windows(): + return platform.system() == "Windows" def path_separator(): diff --git a/testsuite/tests/pin/bad-path/test.py b/testsuite/tests/pin/bad-path/test.py new file mode 100644 index 00000000..2194f9f2 --- /dev/null +++ b/testsuite/tests/pin/bad-path/test.py @@ -0,0 +1,16 @@ +""" +Verify that pinning a bad path is rejected +""" + +from drivers.alr import run_alr, alr_pin, init_local_crate +from drivers.asserts import assert_eq, assert_match + +init_local_crate() +alr_pin("badcrate", path="../bad/path", update=False) + +# Now the update should detect the bad path +p = run_alr("update", complain_on_error=False) +assert_match(".*Pin path is not a valid directory:.*", + p.out) + +print('SUCCESS') diff --git a/testsuite/tests/pin/bad-path/test.yaml b/testsuite/tests/pin/bad-path/test.yaml new file mode 100644 index 00000000..872fc127 --- /dev/null +++ b/testsuite/tests/pin/bad-path/test.yaml @@ -0,0 +1,3 @@ +driver: python-script +indexes: + basic_index: {} diff --git a/testsuite/tests/pin/change-type/test.py b/testsuite/tests/pin/change-type/test.py index 957f2811..3ba44b28 100644 --- a/testsuite/tests/pin/change-type/test.py +++ b/testsuite/tests/pin/change-type/test.py @@ -33,11 +33,9 @@ alr_pin('libhello', path='../crates/libhello_1.0.0') # Check that it shows as such in the solution p = run_alr('show', '--solve') -s = re.escape(dir_separator()) # platform-dependent assert_match('.*Dependencies \(external\):.*' 'libhello\^1 \(direct,linked' - ',pin=..' + s + # relative link should be preserved - 'crates' + s + 'libhello_1.0.0\).*', + ',pin=../crates/libhello_1.0.0\).*', p.out, flags=re.S) # Repin to a version and check again diff --git a/testsuite/tests/pin/pin-dir/test.py b/testsuite/tests/pin/pin-dir/test.py index 39103b27..10fbb682 100644 --- a/testsuite/tests/pin/pin-dir/test.py +++ b/testsuite/tests/pin/pin-dir/test.py @@ -29,11 +29,9 @@ run_alr('build') p = run_alr('with', '--solve') # For this match we don't know where the test is temporarily put, so we skip # over some parts of the output -s = re.escape(dir_separator()) # platform-dependent assert_match('.*Dependencies \(external\):.*' 'libhello\^1.0.0 \(direct,linked' - ',pin=..' + s + # check that relative path is preserved - 'crates' + s + 'libhello_1.0.0\).*', + ',pin=../crates/libhello_1.0.0\).*', # relative, always fwd slash p.out, flags=re.S) # Check that unpinning the dependency works and now the dependency is show diff --git a/testsuite/tests/pin/portable-path/test.py b/testsuite/tests/pin/portable-path/test.py new file mode 100644 index 00000000..c609f5e5 --- /dev/null +++ b/testsuite/tests/pin/portable-path/test.py @@ -0,0 +1,40 @@ +""" +Verify that, in windows, an absolute path is accepted but a relative one is +preferred to be given in portable format (forward slashes) +""" + +from drivers.alr import run_alr, alr_pin, init_local_crate +from drivers.asserts import assert_eq, assert_match +from drivers.helpers import on_windows + +import os + +# Dependency to be pinned with absolute path +init_local_crate(name="dep_absolute") +path_absolute = os.getcwd() +os.chdir("..") + +# Dependency to be pinned with portable relative path +init_local_crate(name="dep_portable", enter=False) + +# Dependency to be pinned with bad relative path +init_local_crate(name="dep_not_portable", enter=False) + +# Dependent main crate +init_local_crate() + +# Should not cause error +alr_pin("dep_absolute", path=path_absolute) + +# Should not cause error +alr_pin("dep_portable", path="../dep_portable") + +# Now the update should detect the bad path. This check is only useful on Win +if on_windows(): + alr_pin("dep_not_portable", path=r"..\dep_not_portable", update=False) + p = run_alr("update", complain_on_error=False) + assert_match(".*Pin relative paths must use " + "forward slashes to be portable.*", + p.out) + +print('SUCCESS') diff --git a/testsuite/tests/pin/portable-path/test.yaml b/testsuite/tests/pin/portable-path/test.yaml new file mode 100644 index 00000000..872fc127 --- /dev/null +++ b/testsuite/tests/pin/portable-path/test.yaml @@ -0,0 +1,3 @@ +driver: python-script +indexes: + basic_index: {} diff --git a/testsuite/tests/pin/recursive_local/test.py b/testsuite/tests/pin/recursive_local/test.py new file mode 100644 index 00000000..21a7018a --- /dev/null +++ b/testsuite/tests/pin/recursive_local/test.py @@ -0,0 +1,31 @@ +""" +Verify that recursive pins work for local paths +""" + +from drivers.alr import run_alr, alr_pin, init_local_crate +from drivers.asserts import assert_eq, assert_match + +import os + +# We are going to setup xxx --> yyy --> zzz, where xxx and zzz live at the +# same level, and yyy is at ./nest/yyy + +init_local_crate(name="zzz", enter=False) + +os.mkdir("nest") +os.chdir("nest") +init_local_crate(name="yyy") +alr_pin("zzz", path="../../zzz") + +os.chdir("..") +os.chdir("..") +init_local_crate() +alr_pin("yyy", path="../nest/yyy") + +# Should work properly +p = run_alr("pin") +assert_eq('yyy file:../nest/yyy \n' + 'zzz file:../zzz \n', + p.out) + +print('SUCCESS') diff --git a/testsuite/tests/pin/recursive_local/test.yaml b/testsuite/tests/pin/recursive_local/test.yaml new file mode 100644 index 00000000..872fc127 --- /dev/null +++ b/testsuite/tests/pin/recursive_local/test.yaml @@ -0,0 +1,3 @@ +driver: python-script +indexes: + basic_index: {} diff --git a/testsuite/tests/pin/recursive_remote/test.py b/testsuite/tests/pin/recursive_remote/test.py new file mode 100644 index 00000000..c09a1121 --- /dev/null +++ b/testsuite/tests/pin/recursive_remote/test.py @@ -0,0 +1,48 @@ +""" +Verify that recursive pins work for remote urls (simulated as local git remotes +using absolute paths) +""" + +from drivers.alr import run_alr, alr_pin, init_local_crate +from drivers.asserts import assert_eq, assert_match +from drivers.helpers import init_git_repo, dir_separator + +import re +import os + +# We are going to setup xxx --> yyy --> zzz, where xxx and zzz live at the +# same level, and yyy is at ./nest/yyy. Both yyy and zzz will be git +# repositories, so we refer to them by their absolute path (as if they were +# remote URLs) + +# zzz crate/repo +init_local_crate(name="zzz", enter=False) +path_zzz = os.path.join(os.getcwd(), "zzz") +init_git_repo(path_zzz) + +# yyy crate/repo +os.mkdir("nest") +os.chdir("nest") +init_local_crate(name="yyy") +alr_pin("zzz", url=path_zzz) +os.chdir("..") +path_yyy = os.path.join(os.getcwd(), "yyy") +init_git_repo(path_yyy) + +# xxx crate +os.chdir("..") +init_local_crate() +alr_pin("yyy", url=path_yyy) + +# Should work properly +p = run_alr("pin") + +# Absolute path to simulate a remote URL is platform dependent: +s = dir_separator() +assert_match(re.escape('yyy file:alire/cache/pins/yyy ') + # local rel path + '.*' + re.escape(f'{s}nest{s}yyy\n') + # remote abs url + re.escape('zzz file:alire/cache/pins/zzz ') + # local rel path + '.*' + re.escape(f'{s}zzz \n'), # remote abs url + p.out) + +print('SUCCESS') diff --git a/testsuite/tests/pin/recursive_remote/test.yaml b/testsuite/tests/pin/recursive_remote/test.yaml new file mode 100644 index 00000000..872fc127 --- /dev/null +++ b/testsuite/tests/pin/recursive_remote/test.yaml @@ -0,0 +1,3 @@ +driver: python-script +indexes: + basic_index: {} diff --git a/testsuite/tests/update/manual-once/test.py b/testsuite/tests/update/manual-once/test.py index 370710eb..50bb5fc8 100644 --- a/testsuite/tests/update/manual-once/test.py +++ b/testsuite/tests/update/manual-once/test.py @@ -21,7 +21,7 @@ def prepare_crate(name): info = os.stat("alire.toml") os.utime("alire.lock", (info.st_atime, info.st_mtime - 1)) -warning_text = "Detected changes in manifest, synchronizing workspace" +warning_text = "Synchronizing workspace" # Test when directly doing an update. Should report no changes. prepare_crate("test1") -- 2.39.5