diff --git a/src/alire/alire-properties-tests.adb b/src/alire/alire-properties-tests.adb index 8f4f3847d..07b8c950a 100644 --- a/src/alire/alire-properties-tests.adb +++ b/src/alire/alire-properties-tests.adb @@ -139,10 +139,17 @@ package body Alire.Properties.Tests is if Local.Pop (TOML_Keys.Test_Id, Val) then if Val.Kind /= TOML_String - or else Id_Set.Contains (Val.As_String) + or else Id_Set.Contains (Val.As_String) then Local.Checked_Error ("id must be a non-empty unique string"); end if; + if (for some C of Val.As_String => + C not in 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') + then + Local.Checked_Error + ("id must only have characters in range 'a'..'z' |" + & " 'A'..'Z' | '0'..'9' | '_' | '-'."); + end if; Id_Set.Insert (Val.As_String); Res.Id := Val.As_Unbounded_String; end if; diff --git a/src/alire/alire-properties-tests.ads b/src/alire/alire-properties-tests.ads index d4104ffa4..a7809870f 100644 --- a/src/alire/alire-properties-tests.ads +++ b/src/alire/alire-properties-tests.ads @@ -45,6 +45,8 @@ is function Id (S : Settings) return String; + function Short_Image (S : Settings) return String; + function Default return Settings; private @@ -58,24 +60,28 @@ private overriding function Image (S : Settings) return String - is (" test runner" - & (if Id (S) = "" then "" else (" '" & Id (S) & "'")) - & ": " - & (case S.Runner.Kind is - when Alire_Runner => "alire", - when External => "`" & S.Runner.Command.Flatten & "`") + is ("Test runner " + & S.Short_Image & ", directory: " & Directory (S) - & (if S.Runner.Kind = Alire_Runner then (", jobs:" & S.Jobs'Image) + & (if S.Runner.Kind = Alire_Runner + then (", jobs:" & S.Jobs'Image) else "")); + function Short_Image (S : Settings) return String + is ((if Id (S) = "" then "" else "'" & Id (S) & "'") + & ": " + & (case S.Runner.Kind is + when Alire_Runner => "alire", + when External => "`" & S.Runner.Command.Flatten & "`")); + overriding function To_Yaml (S : Settings) return String is ("runner: " & Alire.Utils.YAML.YAML_Stringify (case S.Runner.Kind is when Alire_Runner => "alire", - when External => S.Runner.Command.Flatten) + when External => S.Runner.Command.Flatten) & New_Line & "directory: " & Alire.Utils.YAML.YAML_Stringify (Directory (S)) diff --git a/src/alire/alire-test_runner.adb b/src/alire/alire-test_runner.adb index edb0e7f5e..8e605690c 100644 --- a/src/alire/alire-test_runner.adb +++ b/src/alire/alire-test_runner.adb @@ -263,63 +263,6 @@ package body Alire.Test_Runner is Ada.Containers.Indefinite_Vectors (Positive, Portable_Path); subtype Portable_Path_Vector is Portable_Path_Vectors.Vector; - --------------------- - -- Create_Gpr_List -- - --------------------- - - procedure Create_Gpr_List (Root : Roots.Root; List : Portable_Path_Vector) - -- Create a gpr file containing a list of the test files - -- (named `Test_Files`). - is - - -------------------- - -- Load_Or_Create -- - -------------------- - - function Load_Or_Create (Path : Any_Path) return Text_Files.File is - -- Load the file at the specified path, or create an empty file. - begin - if not Exists (Path) then - Touch (Path, True); - end if; - return Text_Files.Load (Path, Backup => False); - end Load_Or_Create; - - File_Path : constant Absolute_Path := - Root.Path - / Paths.Default_Config_Folder - / (Root.Name.As_String & "_list_config.gpr"); - File : Text_Files.File := Load_Or_Create (File_Path); - Lines : access AAA.Strings.Vector renames File.Lines; - First : Boolean := True; - - Indent : constant String := " "; - - Root_Name : constant String := - AAA.Strings.To_Mixed_Case (Root.Name.As_String); - begin - Lines.Clear; - -- The File object keeps track of the previous content, - -- and avoids overwriting if it's identical. - - Lines.Append_Line ("abstract project " & Root_Name & "_List_Config is"); - Lines.Append_Line (Indent & "Test_Files := ("); - - for Name of List loop - Lines.Append_Line (Indent & Indent); - if First then - Lines.Append_To_Last_Line (" "); - First := False; - else - Lines.Append_To_Last_Line (","); - end if; - Lines.Append_To_Last_Line ("""" & VFS.Simple_Name (Name) & """"); - end loop; - - Lines.Append_Line (Indent & ");"); - Lines.Append_Line ("end " & Root_Name & "_List_Config;"); - end Create_Gpr_List; - ------------------- -- Run_All_Tests -- ------------------- @@ -486,28 +429,17 @@ package body Alire.Test_Runner is end loop; end Run_All_Tests; - --------- - -- Run -- - --------- + ------------------- + -- Get_File_List -- + ------------------- - function Run - (Root : in out Roots.Root; - Filter : AAA.Strings.Vector := AAA.Strings.Empty_Vector; - Jobs : Natural := 0) return Integer + function Get_File_List + (Root : Roots.Root; Filter : AAA.Strings.Vector) + return Portable_Path_Vector is - use all type AAA.Strings.Vector; - - Job_Count : constant Positive := - (if Jobs = 0 - then Positive (System.Multiprocessors.Number_Of_CPUs) - else Jobs); - Path : constant Absolute_Path := Root.Path; - - Crate_Prefix : constant String := Root_Prefix (Root); - Original_Switch_Q : constant Boolean := Alire_Early_Elaboration.Switch_Q; + Crate_Prefix : constant String := Root_Prefix (Root); Test_List : Portable_Path_Vector; - -------------------- -- Matches_Filter -- -------------------- @@ -551,12 +483,32 @@ package body Alire.Test_Runner is Test_List.Append (Name); end if; end Append; - begin - Den.Walk.Find (This => Path / "src", Action => Append'Access); + Den.Walk.Find (This => Root.Path / "src", Action => Append'Access); + return Test_List; + end Get_File_List; - Create_Gpr_List (Root, Test_List); + --------- + -- Run -- + --------- + + function Run + (Root : in out Roots.Root; + Filter : AAA.Strings.Vector := AAA.Strings.Empty_Vector; + Jobs : Natural := 0) return Integer + is + Job_Count : constant Positive := + (if Jobs = 0 + then Positive (System.Multiprocessors.Number_Of_CPUs) + else Jobs); + Original_Switch_Q : constant Boolean := Alire_Early_Elaboration.Switch_Q; + + Test_List : constant Portable_Path_Vector := + Get_File_List (Root, Filter); + + Src_To_Build : AAA.Strings.Vector := AAA.Strings.Empty_Vector; + begin -- Ensure a void solution on first test run if not Root.Has_Lockfile then Root.Update @@ -570,7 +522,11 @@ package body Alire.Test_Runner is Alire_Early_Elaboration.Switch_Q := True; end if; - if Roots.Build (Root, AAA.Strings.Empty_Vector) then + for Test of Test_List loop + Src_To_Build.Append ("src/" & VFS.Simple_Name (Test)); + end loop; + + if Roots.Build (Root, Src_To_Build) then Alire_Early_Elaboration.Switch_Q := Original_Switch_Q; -- restore original value of `-q` switch @@ -584,4 +540,52 @@ package body Alire.Test_Runner is return 1; end if; end Run; + + --------------- + -- Show_List -- + --------------- + + procedure Show_List + (Root : Roots.Root; + Filter : AAA.Strings.Vector := AAA.Strings.Empty_Vector) + is + Crate_Prefix : constant String := Root_Prefix (Root); + Path : constant Absolute_Path := Root.Path; + Test_List : constant Portable_Path_Vector := + Get_File_List (Root, Filter); + begin + if Tables.Structured_Output then + declare + Builder : LML.Output.Builder'Class := + LML.Output.Factory.Get (Tables.Structured_Output_Format); + begin + Builder.Begin_Map; + Builder.Insert (LML.Decode (TOML_Keys.Test_Report_Cases)); + Builder.Begin_Map; + for Test of Test_List loop + Builder.Insert (LML.Decode (Display_Name (Test, Crate_Prefix))); + Builder.Begin_Map; + Builder.Insert (LML.Decode (TOML_Keys.Test_Report_Path)); + Builder.Append + (LML.Scalars.New_Text + (LML.Decode (Path / "src" / String (Test)))); + Builder.End_Map; + end loop; + Builder.End_Map; + Builder.End_Map; + + Trace.Always (LML.Encode (Builder.To_Text)); + end; + else + Put_Info ("Matching tests:"); + for Test of Test_List loop + Trace.Info + (" " + & Display_Name (Test, Crate_Prefix) + & (if Alire_Early_Elaboration.Switch_V + then " (" & (Path / "src" / String (Test)) & ")" + else "")); + end loop; + end if; + end Show_List; end Alire.Test_Runner; diff --git a/src/alire/alire-test_runner.ads b/src/alire/alire-test_runner.ads index ba2b55d1f..5ae0c114e 100644 --- a/src/alire/alire-test_runner.ads +++ b/src/alire/alire-test_runner.ads @@ -11,4 +11,10 @@ package Alire.Test_Runner is -- Run all .adb files in the `src` folder of the given root as -- separate tests. Return the number of failing tests. + procedure Show_List + (Root : Roots.Root; + Filter : AAA.Strings.Vector := AAA.Strings.Empty_Vector); + -- Print a list of matching tests without running them. Respects structured + -- output. + end Alire.Test_Runner; diff --git a/src/alire/alire-toml_keys.ads b/src/alire/alire-toml_keys.ads index 72945212b..6973dc2d5 100644 --- a/src/alire/alire-toml_keys.ads +++ b/src/alire/alire-toml_keys.ads @@ -68,6 +68,7 @@ package Alire.TOML_Keys with Preelaborate is Test_Report_Reason : constant String := "reason"; Test_Report_Output : constant String := "output"; Test_Report_Duration : constant String := "duration"; + Test_Report_Path : constant String := "path"; Test_Report_Summary : constant String := "summary"; Test_Report_Total : constant String := "total"; Test_Report_Failures : constant String := "failures"; diff --git a/src/alr/alr-commands-test.adb b/src/alr/alr-commands-test.adb index 6fbbbb4b1..1a171332c 100644 --- a/src/alr/alr-commands-test.adb +++ b/src/alr/alr-commands-test.adb @@ -29,10 +29,9 @@ package body Alr.Commands.Test is (Root.Environment, (Alire.Properties.Actions.Test => True, others => False)) .Is_Empty - and then not Alire.Roots.Build - (Root, - AAA.Strings.Empty_Vector, - Saved_Profiles => False) + and then + not Alire.Roots.Build + (Root, AAA.Strings.Empty_Vector, Saved_Profiles => False) then Success := 1; else @@ -100,6 +99,8 @@ package body Alr.Commands.Test is Cmd.Requires_Workspace; if Cmd.Legacy then + Cmd.Forbids_Structured_Output + ("Cannot use structured output with legacy actions"); Execute_Legacy (Cmd.Root); return; end if; @@ -118,6 +119,8 @@ package body Alr.Commands.Test is if All_Settings.Is_Empty then Trace.Warning ("no test runner defined, running legacy actions"); + Cmd.Forbids_Structured_Output + ("Cannot use structured output with legacy actions"); Execute_Legacy (Cmd.Root); return; end if; @@ -146,22 +149,38 @@ package body Alr.Commands.Test is end; end if; - if All_Settings.Length > 1 - and then not (Args.Is_Empty and then Cmd.Jobs = -1) - then - Trace.Warning - ("arguments cannot be forwarded to test runners when several " - & "exist."); + if All_Settings.Length > 1 then + if Cmd.List then + Trace.Error + ("The --list flag cannot be used for multiple runners. Select" + & " a single test runner with --id. Available runners:"); + for E of All_Settings loop + Trace.Always ("- " & Settings (E).Short_Image); + end loop; + Reportaise_Command_Failed (""); + end if; + if not (Args.Is_Empty and then Cmd.Jobs = -1) then + Trace.Warning + ("arguments cannot be forwarded to test runners when multiple" + & " exist."); + end if; end if; if All_Settings.Length = 1 and then Settings (All_Settings.First_Element).Runner.Kind = External - and then Cmd.Jobs >= 0 then - Trace.Warning - ("the --jobs flag is not forwarded to external commands. If you " - & "intended to pass it to an external test runner, put it after " - & """--"" in the command line."); + if Cmd.Jobs >= 0 then + Trace.Warning + ("the --jobs flag is not forwarded to external commands. If you" + & " intended to pass it to an external test runner, put it" + & " after ""--"" in the command line."); + end if; + if Cmd.List then + Trace.Warning + ("the --list flag is not forwarded to external commands. If you" + & " intended to pass it to an external test runner, put it" + & " after ""--"" in the command line."); + end if; end if; for Test_Setting of All_Settings loop @@ -186,7 +205,7 @@ package body Alr.Commands.Test is (Cmd.Root.Path / S.Directory); begin if All_Settings.Length > 1 then - Alire.Put_Info ("running test with" & S.Image); + Alire.Put_Info ("running test with " & S.Image); end if; case S.Runner.Kind is @@ -200,6 +219,12 @@ package body Alr.Commands.Test is & ")"); end if; + if Cmd.List then + Alire.Test_Runner.Show_List + (Test_Root.Value, Get_Args); + OS_Lib.Bailout; + end if; + Failures := Alire.Test_Runner.Run (Test_Root.Value, @@ -225,7 +250,7 @@ package body Alr.Commands.Test is end if; end; else - Trace.Error ("while running" & (Settings (Test_Setting).Image)); + Trace.Error ("while running " & (Settings (Test_Setting).Image)); Reportaise_Command_Failed ("directory '" & (Cmd.Root.Path / Settings (Test_Setting).Directory) @@ -246,15 +271,19 @@ package body Alr.Commands.Test is ("Run the test runner as defined in the manifest.") .Append ("") .Append - ("The builtin test runner takes an extra --jobs parameter, " - & "that defines the maximum number of tests to run in " - & "parallel.") + ("The built-in test runner takes an extra --jobs parameter, that" + & " defines the maximum number of tests to run in parallel.") + .Append ("") + .Append + ("Extra arguments are passed to the runner as-is; in the case of" + & " the built-in runner, a basic filtering mechanism only" + & " compiles and runs the tests whose names contain one of the" + & " arguments.") .Append ("") .Append - ("Extra arguments are passed to the runner as-is; " - & "in the case of the builtin runner, a basic filtering mechanism" - & " only compiles and runs the tests whose names contain one of" - & " the arguments.")); + ("When using a built-in runner, one can pass `--list` to get" + & " ahead of time a list of tests (optionally matching the" + & " command line filter).")); -------------------- -- Setup_Switches -- @@ -294,6 +323,14 @@ package body Alr.Commands.Test is CLIC.TTY.Error ("Deprecated") & ". Force executing the legacy test actions", Value => True); + + Define_Switch + (Config, + Cmd.List'Access, + "", + "--list", + "Show a list of matching tests without running them", + Value => True); end Setup_Switches; end Alr.Commands.Test; diff --git a/src/alr/alr-commands-test.ads b/src/alr/alr-commands-test.ads index 8b17b8da8..1032372f2 100644 --- a/src/alr/alr-commands-test.ads +++ b/src/alr/alr-commands-test.ads @@ -35,9 +35,10 @@ package Alr.Commands.Test is private type Command is new Commands.Command with record - Jobs : aliased Integer := 0; - By_Id : aliased GNAT.Strings.String_Access; + Jobs : aliased Integer := 0; + By_Id : aliased GNAT.Strings.String_Access; Legacy : aliased Boolean := False; + List : aliased Boolean := False; end record; end Alr.Commands.Test; diff --git a/templates/crate_test/tests/crate_test_tests.gpr b/templates/crate_test/tests/crate_test_tests.gpr index 2234cf816..5b67b5f9f 100644 --- a/templates/crate_test/tests/crate_test_tests.gpr +++ b/templates/crate_test/tests/crate_test_tests.gpr @@ -1,12 +1,11 @@ with "config/@_NAME_@_tests_config.gpr"; -with "config/@_NAME_@_tests_list_config.gpr"; project @_CAPITALIZE:NAME_@_Tests is for Source_Dirs use ("src/**", "common/", "config/"); for Object_Dir use "obj/" & @_CAPITALIZE:NAME_@_Tests_Config.Build_Profile; for Create_Missing_Dirs use "True"; for Exec_Dir use "bin"; - for Main use @_CAPITALIZE:NAME_@_Tests_List_Config.Test_Files; + for Main use (); package Compiler is for Default_Switches ("Ada") use