------------------------------------------------------------------------------ -- -- -- GNATTEST COMPONENTS -- -- -- -- G N A T T E S T . E N V I R O N M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011-2019, AdaCore -- -- -- -- GNATTEST is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNATTEST is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- -- Public License for more details. You should have received a copy of the -- -- GNU General Public License distributed with GNAT; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02110-1301, USA., -- -- -- -- GNATTEST is maintained by AdaCore (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Text_IO; use Ada.Text_IO; with Ada.Containers; use Ada.Containers; with Asis.Ada_Environments; use Asis.Ada_Environments; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Environment_Variables; use Ada.Environment_Variables; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with System.Multiprocessors; with ASIS_UL.Common; with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options; with ASIS_UL.Debug; use ASIS_UL.Debug; with ASIS_UL.Output; use ASIS_UL.Output; with ASIS_UL.Projects; with GNATtest.Options; use GNATtest.Options; with GNATtest.Common; use GNATtest.Common; with GNATtest.Skeleton.Source_Table; use GNATtest.Skeleton.Source_Table; with GNATtest.Harness.Source_Table; use GNATtest.Harness.Source_Table; with GNATCOLL.Projects; use GNATCOLL.Projects; with GNATCOLL.Projects.Aux; with GNATCOLL.VFS; use GNATCOLL.VFS; with GNATCOLL.Traces; use GNATCOLL.Traces; package body GNATtest.Environment is Me : constant Trace_Handle := Create ("Environment", Default => Off); Parameter_Error : exception; -- Is raised if the initialization is impossible or fails down because of -- any reason Output_M : Output_Mode := Default_Output_Mode; Output_M_Set : Boolean := False; Default_Skeletons_Set : Boolean := False; Show_Passed_Tests_Set : Boolean := False; Add_Exit_Status_Set : Boolean := False; Inheritance_Check_Set : Boolean := False; U_Set, R_Set : Boolean := False; Recursiveness_Set : Boolean := False; Run_Dir : String_Access; -- Directory from which the tool was called. Env : Project_Environment_Access; Root : Project_Type; Recursive_Sources : Boolean := True; Object_Dir : String_Access; Files_List : String_Access := null; Excluded_Files_List : String_Access := null; -- Temporary source file name storage. After determining in which mode -- the tool works sources are to be transfered to corresponding source -- table. use List_Of_Strings; Source_Buffer : List_Of_Strings.List; Ext_Var_Buffer : List_Of_Strings.List; SB_Cur : List_Of_Strings.Cursor; -- Flags for default output dirs being set explicitly. Stub_Dir_Set : Boolean := False; Tests_Dir_Set : Boolean := False; Harness_Dir_Set : Boolean := False; Closure_Subdirs_To_Clean : List_Of_Strings.List; -- With on-the-fly closure computation we switch to object subdirs, -- that are in turn created for each project in the project tree. -- Although they bring no harm, they may be confusing for the user, -- so we store a list of those to clean them up at the end. ----------------------- -- Local subprograms -- ----------------------- function Is_Comment (S : String) return Boolean is (S'Length >= 2 and then S (S'First .. S'First + 1) = "--"); procedure Scan_Parameters; -- Scans the command-line parameters and sets the metrics to compute and -- sources to process. procedure Check_Parameters; -- Checks that parameter settings are compatible fo generation mode. -- Raises Parameter_Error and generates the diagnostic message -- if the check fails. procedure Check_Aggregation_Parameters; -- Checks that parameter settings are compatible for aggregation mode. -- Raises Parameter_Error and generates the diagnostic message -- if the check fails. procedure Create_Temp_Dir (Obj_Dir : String := ""); -- Creates the temporary directory and stores its name in Temp_Dir. procedure Brief_Help; -- Prints out the brief help. procedure Check_Subdir; -- Checks if there are no intersections between target and source dirs. If -- so, tries to create all target subdirs. procedure Check_Separate_Root; -- Checks if there are no intersections between target and source dirs. If -- so, tries to create a directori hierarchy similar to one of the tested -- sources. procedure Check_Direct; -- Checks if there are no intersections between target and source dirs. If -- so, tries to create target dir. procedure Check_Stub; -- Checks if there are no intersections between stub and source dirs and -- between stub and test dirs. procedure Process_Exclusion_Lists; -- Process lists of units fo stub exclusion. function Is_Externally_Built (File : Virtual_File) return Boolean; -- Checks if the given source file belongs to an externally build library. function Non_Null_Intersection (Left : File_Array_Access; Right : File_Array_Access) return Boolean; -- Returns True if two file arrays have at least one common file. function All_Source_Locations return File_Array_Access; -- Returns an array of all directories that may have source files. -- In case of project option, returns the list of recursively collected -- source dirs, otherwise collects the list from argument source files. procedure Get_Naming_Info (Source_Project_Tree : GNATCOLL.Projects.Project_Tree); -- Gathers all naming info and creates a file with corresponding pragmas. procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array); -- Treats all the source dirs from project as -I option parameters. -- Also sets the value of Source_Dirs_Conflict flag. procedure Register_Gnattest_Specific_Attributes; procedure Get_Gnattest_Specific_Attributes (Source_Project_Tree : GNATCOLL.Projects.Project_Tree); function Has_Command_Line_Support return Boolean; -- Checks whether current run-time library has command line support or not. ------------------------------ -- Update_Path_With_Project -- ------------------------------ procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array) is begin for F in Dirs'Range loop Store_I_Option (Dirs (F).Display_Full_Name); end loop; end Update_Path_With_Project; -------------------------- -- All_Source_Locations -- -------------------------- function All_Source_Locations return File_Array_Access is Source_Dirs : File_Array_Access := new File_Array'(Empty_File_Array); Tmp : String_Access; begin if Source_Prj.all /= ("") then -- If we're here, than the project has been successfully loaded. Append (Source_Dirs, Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True)); else GNATtest.Skeleton.Source_Table.Reset_Location_Iterator; loop Tmp := new String'(Normalize_Pathname (Name => GNATtest.Skeleton.Source_Table.Next_Source_Location, Case_Sensitive => False)); exit when Tmp.all = ""; Append (Source_Dirs, GNATCOLL.VFS.Create (+Tmp.all)); end loop; end if; return Source_Dirs; end All_Source_Locations; ---------------- -- Brief_Help -- ---------------- procedure Brief_Help is begin Put_Line ("Usage: gnattest -Pprj [opts] {filename} [-cargs switches]"); Put_Line (" - generates the unit testing framework"); New_Line; Put_Line (" or gnattest test_drivers.list [opts]"); Put_Line (" - executes tests and aggregates the results"); New_Line; Put_Line (" --version Display version and exit"); Put_Line (" --help Display usage and exit"); New_Line; Put_Line ("Framework generation mode options:"); New_Line; Put_Line (" -Pprj Name of the project for which to generate " & "the testing framework"); Put_Line (" {filename} " & "Only generate testing framework for these source files;"); Put_Line (" if omitted, consider all project sources"); New_Line; Put_Line (" --strict " & "Return error exit code if there are compilation errors"); Put_Line (" -q Quiet mode"); Put_Line (" -v Verbose mode"); Put_Line (" -r " & "Consider recursively all sources from all projects"); Put_Line (" -U main " & "Process the closure of units rooted at unit main"); New_Line; Put_Line (" --additional-tests=prj " & "Treat sources from project prj as additional"); Put_Line (" " & "manual tests to add to the test suite"); Put_Line (" --harness-only " & "Treat argument sources as tests to add to the suite"); New_Line; Put_Line (" --separate-drivers[=unit|test] " & "Generate a separate test driver for each"); Put_Line (" unit or test, " & "unit being the default"); Put_Line (" --stub " & "Generate testing framework that uses stubs"); New_Line; Put_Line (" --exclude-from-stubbing=file - " & "list of sources whose bodies should not"); Put_Line (" be stubbed"); Put_Line (" --exclude-from-stubbing:unit=file - " & "list of sources whose bodies should not "); Put_Line (" be stubbed when" & " testing unit"); New_Line; Put_Line (" --harness-dir=dirname Output dir for test harness"); Put_Line (" --tests-dir=dirname Test files are put in dirname"); Put_Line (" --subdirs=dirname " & "Test files are put in subdirs dirname of source dirs"); Put_Line (" --tests-root=dirname " & "Test files are put in the same directory hierarchy"); Put_Line (" as sources but rooted at dirname"); Put_Line (" --stubs-dir=dirname " & "Stub files are put in subdirs of dirname"); New_Line; Put_Line (" --validate-type-extensions " & "Run all tests from all parents to check LSP"); Put_Line (" --inheritance-check " & "Run inherited tests for descendants"); Put_Line (" --no-inheritance-check " & "Do not run inherited tests for descendants"); Put_Line (" --test-case-only " & "Create tests only when Test_Case is specified"); Put_Line (" --skeleton-default=(pass|fail) " & "Default behavior of unimplemented tests"); Put_Line (" --passed-tests=(show|hide) " & "Default output of passed tests"); Put_Line (" --exit-status=(on|off) " & "Default usage of the exit status"); Put_Line (" --omit-sloc " & "Don't record subprogram sloc in test package"); Put_Line (" --no-command-line " & "Don't add command line support to test driver"); Put_Line (""); Put_Line (" --test-duration " & "Show timing for each test"); New_Line; New_Line; Put_Line ("Tests execution mode options:"); New_Line; Put_Line (" --passed-tests=(show|hide) " & "Default output of passed tests"); Put_Line (" --queues=n, -jn " & "Run n tests in parallel (default n=1)"); Put_Line (" --copy-environment=dir " & "copy contents of dir to temp dirs where test"); Put_Line (" drivers are spawned"); Put_Line (" --subdirs=dirname " & "look for test drivers in subdirs"); end Brief_Help; ---------------------------------- -- Check_Aggregation_Parameters -- ---------------------------------- procedure Check_Aggregation_Parameters is Tmp : String_Access; begin if Source_Buffer.Is_Empty then Report_Err ("test driver list not specified"); raise Parameter_Error; end if; if Source_Buffer.Length > Count_Type (1) then Report_Std ("warning: (gnattest) multiple argument files specified," & " only first is processed"); end if; Arg_File_Name := new String'(Source_Buffer.First_Element); if Arg_File_Name.all /= "" then if not Is_Regular_File (Arg_File_Name.all) then if Is_Regular_File (Arg_File_Name.all & ".list") then Tmp := new String'(Arg_File_Name.all & ".list"); Free (Arg_File_Name); Arg_File_Name := Tmp; Tmp := null; else Report_Err ("gnattest: test driver list " & Arg_File_Name.all & " does not exist"); raise Parameter_Error; end if; end if; else Report_Err ("test driver list not specified"); raise Parameter_Error; end if; Tmp := new String'(Normalize_Pathname (Name => Arg_File_Name.all, Case_Sensitive => False)); Free (Arg_File_Name); Arg_File_Name := new String'(Tmp.all); Free (Tmp); -- Dealing with environment dir to copy if Environment_Dir /= null then Tmp := new String'(Normalize_Pathname (Name => Environment_Dir.all, Case_Sensitive => False)); Free (Environment_Dir); Environment_Dir := new String'(Tmp.all); Free (Tmp); if not Is_Directory (Environment_Dir.all) then Report_Err ("gnattest: environment dir " & Environment_Dir.all & " does not exist"); raise Parameter_Error; end if; end if; Run_Dir := new String' (Normalize_Pathname (Name => Get_Current_Dir, Case_Sensitive => False)); Create_Temp_Dir; Change_Dir (Temp_Dir.all); end Check_Aggregation_Parameters; ---------------------- -- Check_Parameters -- ---------------------- procedure Check_Parameters is Tmp : String_Access; -- Project support: Files : File_Array_Access; V_F : Virtual_File; procedure Add_AUnit_Paths; -- Creates a dummy project file importing aunit, then trying to load it. -- If the attempt fails that means that AUnit is not on default project -- path. -- Sets Options.No_Comand_Line depending of default value of -- AUnit_Shared.Runtime. procedure Initialize_Environment; procedure Set_Gnattest_Generated_Present (Source_Project_Tree : GNATCOLL.Projects.Project_Tree); -- Checks if gnattest_generated.ads is already among sources. procedure Set_Ext_Values; -- Sets values of external variables passed to gnattest by -X options. -- Overwrites the value of Options.No_Comand_Line if RUNTIME is among -- scenario variables declared in the project or passed to the tool. procedure Set_Inherited_Switches (Source_Project_Tree : GNATCOLL.Projects.Project_Tree); procedure Set_Asis_Mode (Source_Project_Tree : GNATCOLL.Projects.Project_Tree); procedure Supress_Output (Msg : String); --------------------- -- Add_AUnit_Paths -- --------------------- procedure Add_AUnit_Paths is Output_File : File_Type; SPT : GNATCOLL.Projects.Project_Tree; Local_Env : Project_Environment_Access; Config_Success : Boolean := True; procedure Misconfiguration (S : String); procedure Misconfiguration (S : String) is begin if Index (S, "no languages defined for this project") /= 0 then Report_Err ("gnattest: configuration error"); Config_Success := False; else Report_Err (S); end if; end Misconfiguration; begin GNATCOLL.Traces.Parse_Config_File; Initialize (Local_Env); if RTS_Attribute_Val = null then Local_Env.Set_Target_And_Runtime (Target.all, GNATtest.Options.RTS_Path.all); else Local_Env.Set_Target_And_Runtime (Target.all, RTS_Attribute_Val.all); end if; Set_Automatic_Config_File (Local_Env.all); Create (Output_File, Out_File, Temp_Dir.all & Directory_Separator & "default.gpr"); Put_Line (Output_File, "with ""aunit"";"); Put_Line (Output_File, "project default is"); Put_Line (Output_File, "end default;"); Close (Output_File); SPT.Load (GNATCOLL.VFS.Create (+(Temp_Dir.all & Directory_Separator & "default.gpr")), Local_Env, Errors => Misconfiguration'Unrestricted_Access, Report_Missing_Dirs => False); if not Config_Success then raise Fatal_Error; end if; Update_Path_With_Project (SPT.Root_Project.Source_Dirs (Recursive => True)); Aux.Delete_All_Temp_Files (SPT.Root_Project); SPT.Unload; exception when GNATCOLL.Projects.Invalid_Project => Report_Err ("gnattest: aunit not installed"); raise Parameter_Error; end Add_AUnit_Paths; procedure Set_Ext_Values is Var_Name, Var_Val : String_Access; GPR_TOOL_Set : Boolean := False; begin SB_Cur := Ext_Var_Buffer.First; loop exit when SB_Cur = List_Of_Strings.No_Element; declare S : constant String := List_Of_Strings.Element (SB_Cur); F_Idx : constant Integer := S'First; L_Idx : constant Integer := S'Last; begin for I in S'Range loop if S (I) = '=' then Var_Name := new String'(S (F_Idx .. I - 1)); Var_Val := new String'(S (I + 1 .. L_Idx)); end if; end loop; if Var_Name = null then Report_Std ("-X" & S & " is an illegal option"); raise Parameter_Error; end if; end; Env.Change_Environment (Var_Name.all, Var_Val.all); if Var_Name.all = "GPR_TOOL" then GPR_TOOL_Set := True; end if; List_Of_Strings.Next (SB_Cur); Free (Var_Name); Free (Var_Val); end loop; if not GPR_TOOL_Set and then not Ada.Environment_Variables.Exists ("GPR_TOOL") then Env.Change_Environment ("GPR_TOOL", "gnattest"); end if; end Set_Ext_Values; procedure Supress_Output (Msg : String) is begin if Quiet then return; end if; if Index (Msg, "warning") /= 0 and then Index (Msg, "directory") /= 0 and then Index (Msg, "not found") /= 0 then return; end if; if Index (Msg, "no languages defined for this project") /= 0 then return; end if; Report_Err (Msg); end Supress_Output; procedure Set_Gnattest_Generated_Present (Source_Project_Tree : GNATCOLL.Projects.Project_Tree) is Files : File_Array_Access; begin Files := Source_Project_Tree.Root_Project.Source_Files (Recursive => True); for F in Files'Range loop if not Is_Externally_Built (Files (F)) then if Files (F).Display_Base_Name = "gnattest_generated.ads" then Gnattest_Generated_Present := True; exit; end if; end if; end loop; end Set_Gnattest_Generated_Present; procedure Set_Asis_Mode (Source_Project_Tree : GNATCOLL.Projects.Project_Tree) is Switches : String_List_Access; Proj : constant Project_Type := Source_Project_Tree.Root_Project; begin if Has_Attribute (Proj, Compiler_Default_Switches_Attribute) then Switches := Attribute_Value (Proj, Compiler_Default_Switches_Attribute, "ada"); end if; if Switches = null then return; end if; for I in Switches'Range loop if Switches (I).all = "-gnat95" then ASIS_UL.Compiler_Options.Store_Option ("-gnat95"); end if; if Switches (I).all = "-gnat2005" or else Switches (I).all = "-gnat05" then ASIS_UL.Compiler_Options.Store_Option ("-gnat05"); end if; if Switches (I).all = "-gnat12" or else Switches (I).all = "-gnat2012" then ASIS_UL.Compiler_Options.Store_Option ("-gnat12"); end if; if Index (Switches (I).all, "-gnateD") /= 0 then ASIS_UL.Compiler_Options.Store_Option (Switches (I).all); end if; end loop; end Set_Asis_Mode; procedure Set_Inherited_Switches (Source_Project_Tree : GNATCOLL.Projects.Project_Tree) is Target_Switches : constant String_List := (new String'("-gnatE"), new String'("-gnat12"), new String'("-gnat2012")); Switches : String_List_Access; Proj : constant Project_Type := Source_Project_Tree.Root_Project; begin if Has_Attribute (Proj, Compiler_Default_Switches_Attribute) then Switches := Attribute_Value (Proj, Compiler_Default_Switches_Attribute, "ada"); end if; if Switches = null then return; end if; for I in Switches'Range loop for J in Target_Switches'Range loop if Switches (I).all = Target_Switches (J).all then Inherited_Switches.Append (Switches (I).all); end if; end loop; end loop; end Set_Inherited_Switches; procedure Initialize_Environment is Firts_Idx : constant Natural := ASIS_UL.Common.Tool_Name'First; Last_Idx : constant Natural := Index (ASIS_UL.Common.Tool_Name.all, "-", Ada.Strings.Backward); begin if Target.all = "" then Free (Target); Target := new String' (ASIS_UL.Common.Tool_Name (Firts_Idx .. Last_Idx - 1)); end if; ASIS_UL.Common.Target := Target; Initialize (Env); Env.Set_Target_And_Runtime (Target.all, GNATtest.Options.RTS_Path.all); Set_Automatic_Config_File (Env.all); end Initialize_Environment; begin Register_Gnattest_Specific_Attributes; Initialize_Environment; Set_Ext_Values; declare procedure Errors (S : String); procedure Errors (S : String) is begin if Index (S, " not a regular file") /= 0 then Report_Err ("gnattest: project file " & Source_Prj.all & " does not exist"); elsif Index (S, "is illegal for typed string") /= 0 then Error (S); raise Parameter_Error; else Report_Err (S); end if; end Errors; begin Source_Project_Tree.Load (GNATCOLL.VFS.Create (+Source_Prj.all), Env, Packages_To_Check => new String_List'(1 => new String'("gnattest")), Recompute_View => False, Errors => Errors'Unrestricted_Access); exception when Invalid_Project => raise Parameter_Error; end; Free (Source_Prj); Source_Prj := new String' (Source_Project_Tree.Root_Project.Project_Path.Display_Full_Name); if Is_Aggregate_Project (Source_Project_Tree.Root_Project) then Report_Err ("gnattest: aggregate projects are not supported"); raise Parameter_Error; end if; Source_Project_Tree.Recompute_View (Errors => Supress_Output'Unrestricted_Access); if Target.all = "" then declare Target_From_Project : constant String := Source_Project_Tree.Root_Project.Get_Target (Default_To_Host => False); begin if Target_From_Project /= "" then Free (Target); Target := new String'(Target_From_Project); end if; end; end if; Run_Dir := new String' (Normalize_Pathname (Name => Get_Current_Dir, Case_Sensitive => False)); Create_Temp_Dir (Source_Project_Tree.Root_Project.Object_Dir.Display_Full_Name); if GNATtest.Options.RTS_Path.all /= "" or else Attribute_Value (Source_Project_Tree.Root_Project, Runtime_Attribute, "ada") /= "" then if Env.Predefined_Object_Path = Empty_File_Array then if GNATtest.Options.RTS_Path.all /= "" then Report_Err ("object path not found for runtime " & GNATtest.Options.RTS_Path.all); else Report_Err ("object path not found for runtime " & Attribute_Value (Source_Project_Tree.Root_Project, Runtime_Attribute, "ada")); end if; raise Fatal_Error; end if; declare Files : constant GNATCOLL.VFS.File_Array := Env.Predefined_Object_Path; Obj_Path : constant String := Files (Files'First).Display_Full_Name; Idx : Integer; begin Idx := Index (Obj_Path, Directory_Separator & "adalib"); if Idx = 0 then Report_Err ("cannot locate runtime at " & Obj_Path); raise Fatal_Error; else ASIS_UL.Compiler_Options.Store_Option ("--RTS=" & Obj_Path (Obj_Path'First .. Idx - 1)); if GNATtest.Options.RTS_Path.all = "" then -- We might as well update it. Free (GNATtest.Options.RTS_Path); GNATtest.Options.RTS_Path := new String' (Obj_Path (Obj_Path'First .. Idx - 1)); RTS_Attribute_Val := new String' (Attribute_Value (Source_Project_Tree.Root_Project, Runtime_Attribute, "ada")); end if; end if; end; end if; Root := Source_Project_Tree.Root_Project; Update_Path_With_Project (Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True)); Set_Gnattest_Generated_Present (Source_Project_Tree); Get_Gnattest_Specific_Attributes (Source_Project_Tree); -- Gather the list of sources to exclude from processing. if Excluded_Files_List /= null then declare F : File_Type; S : String_Access; F_Path : constant String := Normalize_Pathname (Name => Excluded_Files_List.all, Case_Sensitive => False); begin if not Is_Regular_File (F_Path) then Report_Err ("gnattest: cannot find " & F_Path); raise Parameter_Error; end if; Open (F, In_File, F_Path); while not End_Of_File (F) loop S := new String'(Get_Line (F)); if not Is_Comment (S.all) then Excluded_Files.Include (Trim (Base_Name (S.all), Both)); end if; Free (S); end loop; Close (F); end; end if; -- Processing -files argument if Files_List /= null then declare F : File_Type; F_Path : constant String := Normalize_Pathname (Name => Files_List.all, Case_Sensitive => False); begin if not Is_Regular_File (F_Path) then Report_Err ("gnattest: cannot find " & F_Path); raise Parameter_Error; end if; Open (F, In_File, F_Path); while not End_Of_File (F) loop Source_Buffer.Append (Get_Line (F)); end loop; Close (F); end; end if; if Harness_Only and then U_Set and then not Source_Buffer.Is_Empty then Report_Err ("options --harness-only and -U are incompatible"); raise Parameter_Error; end if; -- --additional-tests and --harness-only are not yet supported in -- --separate-drivers mode. -- --stub and --harness-only make no sense at the same time. -- --additional-tests is not (yet?) supported in --stub mode. if Stub_Mode_ON then if Harness_Only then Report_Err ("options --harness-only and --stub are incompatible"); raise Parameter_Error; end if; if Additional_Tests_Prj /= null then Report_Err ("options --additional-tests and --stub are incompatible"); raise Parameter_Error; end if; -- We also need to change default dirs is they have not been -- changed explicitly. if not Tests_Dir_Set then Free (Test_Dir_Name); Test_Dir_Name := new String' ("gnattest_stub" & Directory_Separator & "tests"); end if; if not Stub_Dir_Set then Free (Stub_Dir_Name); Stub_Dir_Name := new String' ("gnattest_stub" & Directory_Separator & "stubs"); end if; if not Harness_Dir_Set then Free (Harness_Dir); Harness_Dir := new String' ("gnattest_stub" & Directory_Separator & "harness"); end if; end if; if Separate_Drivers then if Harness_Only then Report_Err ("options --harness-only and --separate-drivers " & "are incompatible"); raise Parameter_Error; end if; if Additional_Tests_Prj /= null then Report_Err ("options --additional-tests and --separate-drivers " & "are incompatible"); raise Parameter_Error; end if; end if; Add_AUnit_Paths; -- Checking if argument project has IDE package specified. declare S : constant Attribute_Pkg_String := Build (Ide_Package, ""); begin if Has_Attribute (Source_Project_Tree.Root_Project, S) then IDE_Package_Present := True; else IDE_Package_Present := False; end if; end; -- Checking if argument project has Make package specified. declare S : constant Attribute_Pkg_String := Build ("make", ""); begin if Has_Attribute (Source_Project_Tree.Root_Project, S) then Make_Package_Present := True; else Make_Package_Present := False; end if; end; if Stub_Mode_ON then GNATtest.Skeleton.Source_Table.Initialize_Project_Table; end if; Object_Dir := new String' (Source_Project_Tree.Root_Project.Object_Dir.Display_Full_Name); if Output_M = Separate_Root then if Separate_Root_Dir.all = Harness_Dir.all then Report_Err ("gnattest: harness dir and separate root" & " dir should not be the same"); raise Parameter_Error; end if; end if; No_Command_Line := not Has_Command_Line_Support; -- need to check if given file is a source file of argument project Files := new File_Array' (Source_Project_Tree.Root_Project.Source_Dirs (True)); SB_Cur := Source_Buffer.First; loop exit when SB_Cur = List_Of_Strings.No_Element; V_F := Locate_Regular_File (+(Base_Name (List_Of_Strings.Element (SB_Cur))), Files.all); if V_F = No_File then Report_Err (Base_Name (List_Of_Strings.Element (SB_Cur)) & " is not part of " & Base_Name (Source_Prj.all) & " or its dependencies"); raise Parameter_Error; elsif not Excluded_Files.Contains (List_Of_Strings.Element (SB_Cur)) then -- In case there are different sources with same base name and -- one of the hides the other we need to take the proper one. V_F := Source_Project_Tree.Create (+List_Of_Strings.Element (SB_Cur)); if Is_Externally_Built (V_F) then Report_Err (Base_Name (List_Of_Strings.Element (SB_Cur)) & " is part of externally built project " & Project (Source_Project_Tree.Info (V_F)).Name & "; skipping"); else if U_Set then Main_Units.Include (V_F.Display_Full_Name); else if Harness_Only then GNATtest.Harness.Source_Table.Add_Source_To_Process (V_F.Display_Full_Name); else GNATtest.Skeleton.Source_Table.Add_Source_To_Process (V_F.Display_Full_Name); end if; end if; end if; else Excluded_Files.Exclude (List_Of_Strings.Element (SB_Cur)); end if; List_Of_Strings.Next (SB_Cur); end loop; Source_Buffer.Clear; -- Processing harness dir specification if not Is_Absolute_Path (GNATCOLL.VFS.Create (+Harness_Dir.all)) then Tmp := new String'(Object_Dir.all & Harness_Dir.all); Free (Harness_Dir); Harness_Dir := Tmp; Tmp := null; end if; if Is_Regular_File (Harness_Dir.all) then Report_Err ("gnattest: cannot create harness directory"); raise Parameter_Error; elsif not Is_Directory (Harness_Dir.all) then declare Dir : File_Array_Access; begin Append (Dir, GNATCOLL.VFS.Create (+Harness_Dir.all)); Create_Dirs (Dir); exception when Directory_Error => Report_Err ("gnattest: cannot create harness directory"); raise Parameter_Error; end; end if; Tmp := new String'(Normalize_Pathname (Name => Harness_Dir.all, Case_Sensitive => False)); Free (Harness_Dir); Harness_Dir := new String'(Tmp.all & Directory_Separator); Free (Tmp); Change_Dir (Temp_Dir.all); Set_Inherited_Switches (Source_Project_Tree); Set_Asis_Mode (Source_Project_Tree); if Harness_Only then -- Filling up harness source table. if GNATtest.Harness.Source_Table.SF_Table_Empty then if Source_Prj.all = "" then Report_Err ("No input source file set"); raise Parameter_Error; else Files := Source_Project_Tree.Root_Project.Source_Files (Recursive => False); -- If Files is still empty, that means that the given -- project does not have any source files. if Files'Length = 0 then Report_Err (Source_Prj.all & " doesn't contain source files"); raise Parameter_Error; end if; for F in Files'Range loop if not Is_Externally_Built (Files (F)) and then not Excluded_Files.Contains (Files (F).Display_Base_Name) then declare F_Info : constant File_Info := Source_Project_Tree.Info (Files (F)); begin if To_Lower (F_Info.Language) = "ada" and then F_Info.Unit_Part = Unit_Spec then GNATtest.Harness.Source_Table.Add_Source_To_Process (Files (F).Display_Full_Name); end if; end; elsif Excluded_Files.Contains (Files (F).Display_Base_Name) then Excluded_Files.Exclude (Files (F).Display_Base_Name); end if; end loop; -- If SF_Table is still empty, that means that the given -- project does not have any testable source files. if GNATtest.Harness.Source_Table.SF_Table_Empty then Report_Err (Source_Prj.all & " doesn't contain testable source files"); raise Parameter_Error; end if; end if; end if; else -- Filling up skeletons source table OR mains (if any). -- First we need to check if project has any Mains. -- need to check if there were argument sources! if GNATtest.Skeleton.Source_Table.SF_Table_Empty and then not U_Set and then not R_Set and then Recursive_Sources and then Root.Has_Attribute (Main_Attribute) and then Attribute_Value (Root, Main_Attribute) /= null then declare Mains : constant String_List := Attribute_Value (Root, Main_Attribute).all; V_F : Virtual_File; begin for Main of Mains loop V_F := Source_Project_Tree.Create (+Main.all); Main_Units.Include (V_F.Display_Full_Name); end loop; end; end if; if GNATtest.Skeleton.Source_Table.SF_Table_Empty and then Main_Units.Is_Empty then declare P : Project_Type := Source_Project_Tree.Root_Project; begin Files := P.Source_Files (Recursive => Recursive_Sources); if not Recursive_Sources then -- We need to add all sources from extended projects. loop P := Extended_Project (P); exit when P = No_Project; Append (Files, P.Source_Files.all); end loop; end if; end; -- If Files is still empty, that means that the given -- project does not have any source files. if Files'Length = 0 then Report_Err (Source_Prj.all & " doesn't contain source files"); raise Parameter_Error; end if; for F in Files'Range loop if not Is_Externally_Built (Files (F)) and then not Excluded_Files.Contains (Files (F).Display_Base_Name) then declare F_Info : constant File_Info := Source_Project_Tree.Info (Files (F)); begin if To_Lower (F_Info.Language) = "ada" and then F_Info.Unit_Part = Unit_Spec then GNATtest.Skeleton.Source_Table.Add_Source_To_Process (Files (F).Display_Full_Name); end if; end; elsif Excluded_Files.Contains (Files (F).Display_Base_Name) then Excluded_Files.Exclude (Files (F).Display_Base_Name); end if; end loop; -- If SF_Table is still empty, that means that the given -- project does not have any testable source files. if GNATtest.Skeleton.Source_Table.SF_Table_Empty then Report_Err (Source_Prj.all & " doesn't contain testable source files"); raise Parameter_Error; end if; end if; if Stub_Mode_ON or else not Main_Units.Is_Empty then Files := Source_Project_Tree.Root_Project.Source_Files (Recursive => True); for F in Files'Range loop if To_Lower (Source_Project_Tree.Info (Files (F)).Language) /= "ada" or else Is_Externally_Built (Files (F)) then goto Next_File; end if; case Source_Project_Tree.Info (Files (F)).Unit_Part is when Unit_Body => declare P : Project_Type := Source_Project_Tree.Info (Files (F)).Project; begin -- The name of the project here will be used to create -- stub projects. Those extend original projects, so -- is a source belongs to an extended project we need -- the extending on here instead, so that we do not -- end up with different extensions of same project. while Extending_Project (P) /= No_Project loop P := Extending_Project (P); end loop; GNATtest.Skeleton.Source_Table.Add_Body_To_Process (Files (F).Display_Full_Name, P.Name, Source_Project_Tree.Info (Files (F)).Unit_Name); end; when Unit_Spec => GNATtest.Skeleton.Source_Table.Add_Body_Reference (Files (F).Display_Full_Name); when others => null; end case; <> end loop; end if; case Output_M is when Subdir => Check_Subdir; when Separate_Root => Check_Separate_Root; when Direct => Check_Direct; end case; if Stub_Mode_ON then Check_Stub; Process_Exclusion_Lists; end if; if not Main_Units.Is_Empty then -- We need to replace the project file with a dummy "extends all" -- wrapper. declare R : constant Project_Type := Source_Project_Tree.Root_Project; Dummy_Proj_File_Name : constant String := Temp_Dir.all & Directory_Separator & "gnattest_closure.gpr"; Rel_Path : constant String := +Relative_Path (R.Project_Path, Create (+Temp_Dir.all)); F : File_Type; begin Trace (Me, "Creating closure project wrapper " & Dummy_Proj_File_Name); Ada.Text_IO.Create (F, Out_File, Dummy_Proj_File_Name); Put_Line (F, "project gnattest_closure extends all """ & Rel_Path & """ is"); Put_Line (F, "end gnattest_closure;"); Close (F); GNATCOLL.Projects.Aux.Delete_All_Temp_Files (Source_Project_Tree.Root_Project); Source_Project_Tree.Unload; Env.Set_Object_Subdir (+Closure_Subdir_Name); Source_Project_Tree.Load (Create (+Dummy_Proj_File_Name), Env); exception when others => Report_Err ("gnattest: cannot create temp closure project"); raise Fatal_Error; end; end if; end if; Get_Naming_Info (Source_Project_Tree); if Additional_Tests_Prj /= null then Change_Dir (Run_Dir.all); Tmp := new String'(Normalize_Pathname (Name => Additional_Tests_Prj.all, Case_Sensitive => False)); Free (Additional_Tests_Prj); Additional_Tests_Prj := new String'(Tmp.all); Free (Tmp); Change_Dir (Temp_Dir.all); if not Is_Regular_File (Additional_Tests_Prj.all) then if Is_Regular_File (Additional_Tests_Prj.all & ".gpr") then Tmp := new String'(Additional_Tests_Prj.all & ".gpr"); Free (Additional_Tests_Prj); Additional_Tests_Prj := Tmp; Tmp := null; else Report_Err ("gnattest: project file " & Additional_Tests_Prj.all & " does not exist"); raise Parameter_Error; end if; end if; declare Add_Map : constant String := (Normalize_Pathname (Name => Dir_Name (Additional_Tests_Prj.all) & "gnattest_map.xml", Case_Sensitive => False)); begin if Is_Regular_File (Add_Map) then Additional_Tests_Map := new String'(Add_Map); end if; end; declare SPT : Project_Tree; begin SPT.Load (GNATCOLL.VFS.Create (+Additional_Tests_Prj.all), Env); Update_Path_With_Project (SPT.Root_Project.Source_Dirs (Recursive => True)); Set_Gnattest_Generated_Present (SPT); Files := SPT.Root_Project.Source_Files (Recursive => False); for F in Files'Range loop if not Is_Externally_Built (Files (F)) then if SPT.Info (Files (F)).Unit_Part = Unit_Spec then GNATtest.Harness.Source_Table.Add_Source_To_Process (Files (F).Display_Full_Name); end if; end if; end loop; GNATCOLL.Projects.Aux.Delete_All_Temp_Files (SPT.Root_Project); SPT.Unload; end; end if; if not Harness_Only then Store_I_Option (Harness_Dir.all & Directory_Separator & "common"); end if; if Main_Units.Is_Empty then Report_Exclusions_Not_Found; end if; -- Disregard the fact that Process_cargs_Section calls Set_Arg_List and -- Process_ADA_PRJ_INCLUDE_FILE already, whithout their explicit call -- compiltaion dependancies for sources from imported projects are not -- resolved. -- Thay cannot be replaced with Process_cargs_Section here. Process_ADA_PRJ_INCLUDE_FILE; Store_I_Options; Set_Arg_List; declare type Dummy_Project_Type is new ASIS_UL.Projects.Arg_Project_Type with null record; procedure Print_Tool_Usage (My_Project : Dummy_Project_Type) is null; Dummy_Project : Dummy_Project_Type; begin Set_Tree_Creator (Dummy_Project); end; if not Main_Units.Is_Empty then declare VF : GNATCOLL.VFS.Virtual_File; Success : Boolean; begin for Main_Unit of Main_Units loop VF := Source_Project_Tree.Create (+Main_Unit); case Source_Project_Tree.Info (VF).Unit_Part is when Unit_Spec => null; when Unit_Body => Trace (Me, "We need a special tree creation call"); Change_Dir (Temp_Dir.all & Directory_Separator & Closure_Subdir_Name); Create_ALI (Main_Unit, Success); if not Success then Report_Err ("gnattest (error): " & "cannot calculate closure"); raise Fatal_Error; end if; Change_Dir (Temp_Dir.all); when others => Report_Err ("gnattest (error): " & "cannot calculate closure for a separate"); end case; end loop; end; declare Iter : Project_Iterator := Start (Source_Project_Tree.Root_Project, Recursive => True, Direct_Only => False, Include_Extended => True); function Is_Temp_Subdir (VF : Virtual_File) return Boolean is (Index (VF.Display_Full_Name, Closure_Subdir_Name) /= 0); -- To be sure that we are not deleting anything not temporary. begin while Current (Iter) /= No_Project loop if Is_Temp_Subdir (Current (Iter).Object_Dir) then Closure_Subdirs_To_Clean.Append (Current (Iter).Object_Dir.Display_Full_Name); end if; if Is_Temp_Subdir (Current (Iter).Executables_Directory) then Closure_Subdirs_To_Clean.Append (Current (Iter).Executables_Directory.Display_Full_Name); end if; if Is_Temp_Subdir (Current (Iter).Library_Directory) then Closure_Subdirs_To_Clean.Append (Current (Iter).Library_Directory.Display_Full_Name); end if; Next (Iter); end loop; end; Update_Closure; end if; end Check_Parameters; ------------------ -- Check_Direct -- ------------------ procedure Check_Direct is Tmp : String_Access; TD_Name : constant Virtual_File := GNATCOLL.VFS.Create (+Test_Dir_Name.all); Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array); Harness_Dir_Ar : constant File_Array_Access := new File_Array'(1 => Create (+(Harness_Dir.all))); Obj_Dir : String_Access; Project : Project_Type; Iterator : Project_Iterator := Start (Source_Project_Tree.Root_Project); begin if TD_Name.Is_Absolute_Path then Append (Future_Dirs, GNATCOLL.VFS.Create (+Test_Dir_Name.all)); else loop Project := Current (Iterator); exit when Project = No_Project; Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name); Tmp := new String'(Obj_Dir.all & Test_Dir_Name.all); Append (Future_Dirs, GNATCOLL.VFS.Create (+Tmp.all)); Free (Tmp); Free (Obj_Dir); Next (Iterator); end loop; end if; if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and sources"); raise Parameter_Error; end if; if Non_Null_Intersection (Future_Dirs, Harness_Dir_Ar) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and infrastructure"); raise Parameter_Error; end if; Set_Direct_Output; end Check_Direct; ---------------- -- Check_Stub -- ---------------- procedure Check_Stub is Tmp : String_Access; SD_Name : constant Virtual_File := GNATCOLL.VFS.Create (+Stub_Dir_Name.all); Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array); Obj_Dir : String_Access; Project : Project_Type; Iterator : Project_Iterator := Start (Source_Project_Tree.Root_Project); begin -- look for collisions with source dirs if SD_Name.Is_Absolute_Path then Append (Future_Dirs, GNATCOLL.VFS.Create (+Test_Dir_Name.all)); else loop Project := Current (Iterator); exit when Project = No_Project; Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name); Tmp := new String'(Obj_Dir.all & Stub_Dir_Name.all); Append (Future_Dirs, GNATCOLL.VFS.Create (+Tmp.all)); Free (Tmp); Free (Obj_Dir); Next (Iterator); end loop; end if; if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then Report_Err ("gnattest: invalid stub directory, cannot mix up " & "stubs and source files"); raise Parameter_Error; end if; Set_Direct_Stub_Output; -- Once stub dirs are set we can compare them with test dirs per source. Skeleton.Source_Table.Reset_Source_Iterator; Tmp := new String'(Skeleton.Source_Table.Next_Source_Name); while Tmp.all /= "" loop if Skeleton.Source_Table.Get_Source_Output_Dir (Tmp.all) = Skeleton.Source_Table.Get_Source_Stub_Dir (Tmp.all) then Report_Err ("gnattest: invalid stub directory, cannot mix up " & "stubs and tests"); raise Parameter_Error; end if; Free (Tmp); Tmp := new String'(Skeleton.Source_Table.Next_Source_Name); end loop; Skeleton.Source_Table.Reset_Source_Iterator; end Check_Stub; ------------------------- -- Check_Separate_Root -- ------------------------- procedure Check_Separate_Root is RD_Name : constant Virtual_File := GNATCOLL.VFS.Create (+Separate_Root_Dir.all); Tmp, Buff : String_Access; Maximin_Root : String_Access; Root_Length : Integer; Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array); -- List of dirs to be generated. The list is checked for intersections -- with source dirs before any new directories are created. Harness_Dir_Ar : constant File_Array_Access := new File_Array'(1 => Create (+(Harness_Dir.all))); Files : File_Array_Access; Project : Project_Type; Iterator : Project_Iterator := Start_Reversed (Source_Project_Tree.Root_Project, Recursive => Recursive_Sources); Ext_Bld : constant Attribute_Pkg_String := Build ("", "externally_built"); Obj_Dir : String_Access; Local_Separate_Root_Dir : String_Access; function Common_Root (Left : String; Right : String) return String; -- Returns the coincident beginning of both paths or an empty string. ------------------- -- Common_Root -- ------------------- function Common_Root (Left : String; Right : String) return String is Idxl : Integer := Left'First; Idxr : Integer := Right'First; Last_Dir_Sep_Index : Integer := Idxl - 1; -- We need to check for the following: -- ...somepath/dir/ -- ...somepath/directory/ begin if Left = "" or Right = "" then return ""; end if; loop if Left (Idxl) = Directory_Separator and then Right (Idxr) = Directory_Separator then Last_Dir_Sep_Index := Idxl; end if; if Left (Idxl) /= Right (Idxr) then return Left (Left'First .. Last_Dir_Sep_Index); end if; exit when Idxl = Left'Last or Idxr = Right'Last; Idxl := Idxl + 1; Idxr := Idxr + 1; end loop; return Left (Left'First .. Idxl); end Common_Root; begin if RD_Name.Is_Absolute_Path then GNATtest.Skeleton.Source_Table.Reset_Location_Iterator; Tmp := new String' (GNATtest.Skeleton.Source_Table.Next_Source_Location); Maximin_Root := new String'(Tmp.all); loop Tmp := new String' (GNATtest.Skeleton.Source_Table.Next_Source_Location); exit when Tmp.all = ""; Buff := new String'(Common_Root (Tmp.all, Maximin_Root.all)); if Buff.all = "" then Report_Err ("gnattest: sources have different root dirs, " & "cannot apply separate root output"); raise Parameter_Error; end if; Free (Maximin_Root); Maximin_Root := new String'(Buff.all); Free (Buff); Free (Tmp); end loop; Root_Length := Maximin_Root.all'Length; Separate_Root_Dir := new String' (Normalize_Pathname (Name => Separate_Root_Dir.all, Case_Sensitive => False)); GNATtest.Skeleton.Source_Table.Reset_Location_Iterator; loop Tmp := new String' (GNATtest.Skeleton.Source_Table.Next_Source_Location); exit when Tmp.all = ""; Append (Future_Dirs, GNATCOLL.VFS.Create (+(Separate_Root_Dir.all & Directory_Separator & Tmp.all (Root_Length + 1 .. Tmp.all'Last)))); Free (Tmp); end loop; if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and sources"); raise Parameter_Error; end if; if Non_Null_Intersection (Future_Dirs, Harness_Dir_Ar) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and infrastructure"); raise Parameter_Error; end if; Set_Separate_Root (Maximin_Root.all); else loop Project := Current (Iterator); exit when Project = No_Project; declare Dirs : constant File_Array := Project.Source_Dirs (False); Common_Root_Dir : String_Access; begin if Dirs'Length > 0 then Common_Root_Dir := new String' (Dirs (Dirs'First).Display_Full_Name); for J in Dirs'Range loop Tmp := new String'(Dirs (J).Display_Full_Name); Buff := new String' (Common_Root (Tmp.all, Common_Root_Dir.all)); if Buff.all = "" then Report_Err ("gnattest: sources have different root dirs, " & "cannot apply separate root output"); raise Parameter_Error; end if; Free (Common_Root_Dir); Common_Root_Dir := new String'(Buff.all); Free (Buff); Free (Tmp); end loop; for J in Dirs'Range loop if Dirs (J).Display_Full_Name = Common_Root_Dir.all then Maximin_Root := Common_Root_Dir; exit; end if; end loop; end if; end; Files := Project.Source_Files; if Files'Length > 0 then if Maximin_Root = null then Maximin_Root := new String' (Files (Files'First).Display_Dir_Name); end if; for F in Files'Range loop Tmp := new String'(Files (F).Display_Dir_Name); Buff := new String'(Common_Root (Tmp.all, Maximin_Root.all)); if Buff.all = "" then Report_Err ("gnattest: sources have different root dirs, " & "cannot apply separate root output"); raise Parameter_Error; end if; Free (Maximin_Root); Maximin_Root := new String'(Buff.all); Free (Buff); Free (Tmp); end loop; Root_Length := Maximin_Root.all'Length; Obj_Dir := new String'(Project.Object_Dir.Display_Full_Name); Local_Separate_Root_Dir := new String' (Normalize_Pathname (Name => Obj_Dir.all & Separate_Root_Dir.all, Case_Sensitive => False)); for F in Files'Range loop if Source_Project_Tree.Info (Files (F)).Unit_Part = Unit_Spec then Tmp := new String'(Files (F).Display_Dir_Name); Append (Future_Dirs, GNATCOLL.VFS.Create (+(Local_Separate_Root_Dir.all & Directory_Separator & Tmp.all (Root_Length + 1 .. Tmp.all'Last)))); Set_Output_Dir (Files (F).Display_Full_Name, Local_Separate_Root_Dir.all & Directory_Separator & Tmp.all (Root_Length + 1 .. Tmp.all'Last)); end if; end loop; end if; -- Externally built projects should be skipped. loop Next (Iterator); if Current (Iterator) = No_Project or else (not Has_Attribute (Current (Iterator), Ext_Bld)) or else To_Lower (Attribute_Value (Current (Iterator), Ext_Bld)) /= "true" then exit; end if; end loop; end loop; if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and sources"); raise Parameter_Error; end if; if Non_Null_Intersection (Future_Dirs, Harness_Dir_Ar) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and infrastructure"); raise Parameter_Error; end if; end if; end Check_Separate_Root; ------------------ -- Check_Subdir -- ------------------ procedure Check_Subdir is Tmp : String_Access; Future_Dirs : File_Array_Access := new File_Array'(Empty_File_Array); -- List of dirs to be generated. The list is checked for intersections -- with source dirs before any new directories are created. Harness_Dir_Ar : constant File_Array_Access := new File_Array'(1 => Create (+(Harness_Dir.all))); begin GNATtest.Skeleton.Source_Table.Reset_Location_Iterator; loop Tmp := new String' (GNATtest.Skeleton.Source_Table.Next_Source_Location); exit when Tmp.all = ""; Append (Future_Dirs, GNATCOLL.VFS.Create (+(Tmp.all & Directory_Separator & Test_Subdir_Name.all))); end loop; if Non_Null_Intersection (Future_Dirs, All_Source_Locations) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and sources"); raise Parameter_Error; end if; if Non_Null_Intersection (Future_Dirs, Harness_Dir_Ar) then Report_Err ("gnattest: invalid output directory, cannot mix up " & "tests and infrastructure"); raise Parameter_Error; end if; Set_Subdir_Output; end Check_Subdir; -------------- -- Clean_Up -- -------------- procedure Clean_Up is begin if GNATtest_Mode = Generation and then Source_Project_Tree.Status /= Empty then GNATCOLL.Projects.Aux.Delete_All_Temp_Files (Source_Project_Tree.Root_Project); Source_Project_Tree.Unload; Free (Env); end if; Context_Clean_Up; -- Cleaning up temporary dir if Temp_Dir /= null then Change_Dir (Run_Dir.all); begin Remove_Dir (Temp_Dir.all, Recursive => True); exception when Directory_Error => Free (Temp_Dir); -- to avoid cycling Report_Err ("gnattest: cannot remove temporary directory"); raise Fatal_Error; end; Free (Temp_Dir); end if; -- Cleaning up closure subdirs (if any) if not Closure_Subdirs_To_Clean.Is_Empty then declare Cur : List_Of_Strings.Cursor := Closure_Subdirs_To_Clean.First; begin while Cur /= No_Element loop if Is_Directory (List_Of_Strings.Element (Cur)) then begin Remove_Dir (List_Of_Strings.Element (Cur), Recursive => True); exception when Directory_Error => Report_Std ("gnattest (warning): " & "cannot delete temp closure dir " & List_Of_Strings.Element (Cur)); end; end if; Next (Cur); end loop; end; end if; end Clean_Up; ---------------------- -- Context_Clean_Up -- ---------------------- procedure Context_Clean_Up is begin if Is_Open (The_Context) then Close (The_Context); end if; if Has_Associations (The_Context) then Dissociate (The_Context); end if; end Context_Clean_Up; --------------------- -- Create_Temp_Dir -- --------------------- procedure Create_Temp_Dir (Obj_Dir : String := "") is FD : File_Descriptor; Temp_Name : Temp_File_Name; Success : Boolean; CD : constant String := Normalize_Pathname (Name => Get_Current_Dir, Case_Sensitive => False); begin -- Here we use exactly the same approach as in gnatelim -- ??? We create the temp dir by first creating the temp file, then -- closing and deleting it, then creating a dir with the same name. -- This is not atomary as another program can sneak in between file -- deletion and dir creation and snatch this name for itself. This is -- quite unlikely and anyway we don't have any other system-independent -- way at the moment if Obj_Dir /= "" then declare F : File_Array_Access; begin Append (F, Dir (GNATCOLL.VFS.Create (+(Obj_Dir)))); Create_Dirs (F); end; Change_Dir (Obj_Dir); end if; Create_Temp_File (FD, Temp_Name); Close (FD); Delete_File (Temp_Name, Success); if not Success then Report_Err ("gnattest: cannot delete the temporary file that was " & "just created"); raise Fatal_Error; end if; Make_Dir (Temp_Name); Temp_Dir := new String' (Obj_Dir & Temp_Name (Temp_Name'First .. Temp_Name'Last - 1)); Change_Dir (CD); exception when Directory_Error => Report_Err ("gnattest: cannot create the temporary directory"); raise Fatal_Error; end Create_Temp_Dir; -------------------------------------- -- Get_Gnattest_Specific_Attributes -- -------------------------------------- procedure Get_Gnattest_Specific_Attributes (Source_Project_Tree : GNATCOLL.Projects.Project_Tree) is Proj : constant Project_Type := Source_Project_Tree.Root_Project; GT_Package : constant String := "gnattest"; begin declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "harness_dir"); begin if Attribute_Value (Proj, Attr) /= "" then if not Harness_Set_By_Switch then Harness_Dir := new String'(Attribute_Value (Proj, Attr)); Harness_Dir_Set := True; end if; end if; end; if not Output_M_Set then declare Attr1 : constant Attribute_Pkg_String := Build (GT_Package, "subdir"); Attr2 : constant Attribute_Pkg_String := Build (GT_Package, "tests_root"); Attr3 : constant Attribute_Pkg_String := Build (GT_Package, "tests_dir"); Output_Attr_Counter : Natural := 0; begin if Attribute_Value (Proj, Attr1) /= "" then Output_Attr_Counter := Output_Attr_Counter + 1; end if; if Attribute_Value (Proj, Attr2) /= "" then Output_Attr_Counter := Output_Attr_Counter + 1; end if; if Attribute_Value (Proj, Attr3) /= "" then Output_Attr_Counter := Output_Attr_Counter + 1; end if; if Output_Attr_Counter > 1 then Report_Err ("invalid project file: " & "more than one output mode specified"); raise Fatal_Error; end if; if Attribute_Value (Proj, Attr1) /= "" then Output_M := Subdir; Test_Subdir_Name := new String'(Attribute_Value (Proj, Attr1)); Tests_Dir_Set := True; end if; if Attribute_Value (Proj, Attr2) /= "" then Output_M := Separate_Root; Separate_Root_Dir := new String'(Attribute_Value (Proj, Attr2)); Tests_Dir_Set := True; end if; if Attribute_Value (Proj, Attr3) /= "" then Output_M := Direct; Test_Dir_Name := new String'(Attribute_Value (Proj, Attr3)); Tests_Dir_Set := True; end if; end; end if; if Additional_Tests_Prj = null then declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "additional_tests"); begin if Attribute_Value (Proj, Attr) /= "" then Additional_Tests_Prj := new String' (Attribute_Value (Proj, Attr)); end if; end; end if; if not Default_Skeletons_Set then declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "skeletons_default"); begin if Attribute_Value (Proj, Attr) /= "" then if Attribute_Value (Proj, Attr) = "pass" then Skeletons_Fail := False; elsif Attribute_Value (Proj, Attr) = "fail" then Skeletons_Fail := True; else Report_Err ("gnattest: skeletons_default " & "should be either fail or pass"); raise Parameter_Error; end if; end if; end; end if; if not Stub_Dir_Set then declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "stubs_dir"); begin if Attribute_Value (Proj, Attr) /= "" then Stub_Dir_Name := new String'(Attribute_Value (Proj, Attr)); Stub_Dir_Set := True; end if; end; end if; declare Attr : constant Attribute_Pkg_List := Build (GT_Package, "gnattest_switches"); GT_Switches : String_List_Access; begin if Has_Attribute (Proj, Attr) then GT_Switches := Attribute_Value (Proj, Attr); for I in GT_Switches'Range loop if not Recursiveness_Set then if GT_Switches (I).all in "-r" | "-U" then Recursive_Sources := True; end if; if GT_Switches (I).all in "--no-subprojects" then Recursive_Sources := False; end if; end if; if GT_Switches (I).all = "-q" then Quiet := True; end if; if GT_Switches (I).all = "--validate-type-extensions" then Substitution_Suite := True; end if; if GT_Switches (I).all = "--harness-only" then Harness_Only := True; end if; if GT_Switches (I).all = "-v" then if not Verbose then Verbose := True; Print_Version_Info (2011); end if; end if; if GT_Switches (I).all = "--omit-sloc" then Omit_Sloc := True; end if; if GT_Switches (I).all = "--test-duration" then Omit_Sloc := True; end if; if not Show_Passed_Tests_Set then if GT_Switches (I).all = "--passed-tests=show" then Show_Passed_Tests := True; end if; if GT_Switches (I).all = "--passed-tests=hide" then Show_Passed_Tests := False; end if; end if; if not Add_Exit_Status_Set then if GT_Switches (I).all = "--exit_status=on" then Add_Exit_Status := True; end if; if GT_Switches (I).all = "--passed-tests=off" then Add_Exit_Status := False; end if; end if; if not Separate_Drivers_Set_By_Switch then if GT_Switches (I).all = "--separate-drivers" or else GT_Switches (I).all = "--separate-drivers=unit" then Separate_Drivers := True; Driver_Per_Unit := True; end if; if GT_Switches (I).all = "--separate-drivers=test" then Separate_Drivers := False; Driver_Per_Unit := False; end if; end if; if not Inheritance_Check_Set then if GT_Switches (I).all = "--inheritance-check" then Inheritance_To_Suite := True; end if; if GT_Switches (I).all = "--no-inheritance-check" then Inheritance_To_Suite := False; end if; end if; if GT_Switches (I).all = "--test-case-only" then Test_Case_Only := True; end if; if GT_Switches (I).all = "--strict" then Strict_Execution := True; end if; if Excluded_Files_List = null and then Index (GT_Switches (I).all, "--ignore=") /= 0 then declare Idx_L : constant Natural := GT_Switches (I).all'Last; Idx : constant Natural := Index (GT_Switches (I).all, "=") + 1; begin Excluded_Files_List := new String'(GT_Switches (I).all (Idx .. Idx_L)); end; end if; end loop; end if; end; if Default_Stub_Exclusion_List_File = null then declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "default_stub_exclusion_list"); begin if Attribute_Value (Proj, Attr) /= "" then Default_Stub_Exclusion_List_File := new String' (Attribute_Value (Proj, Attr)); end if; end; end if; declare Attr : constant Attribute_Pkg_String := Build (GT_Package, "stub_exclusion_list"); Indexes : constant String_List := Attribute_Indexes (Proj, Attr); begin for I in Indexes'Range loop if not Stub_Exclusion_List_Files.Contains (Indexes (I).all) then Stub_Exclusion_List_Files.Include (Indexes (I).all, Attribute_Value (Proj, Attr, Indexes (I).all)); end if; end loop; end; end Get_Gnattest_Specific_Attributes; --------------------- -- Get_Naming_Info -- --------------------- procedure Get_Naming_Info (Source_Project_Tree : GNATCOLL.Projects.Project_Tree) is Mapping_Name : constant String := GNATCOLL.Projects.Aux.Create_Ada_Mapping_File (Source_Project_Tree.Root_Project); Config_Name : constant String := GNATCOLL.Projects.Aux.Create_Config_Pragmas_File (Source_Project_Tree.Root_Project); begin Store_Option ("-gnatem=" & Mapping_Name); Store_Option ("-gnatec=" & Config_Name); end Get_Naming_Info; ------------------------- -- Is_Externally_Built -- ------------------------- function Is_Externally_Built (File : Virtual_File) return Boolean is F_Info : constant File_Info := Info (Source_Project_Tree, File); Proj : constant Project_Type := Project (F_Info); Attr : constant Attribute_Pkg_String := Build ("", "externally_built"); begin if Has_Attribute (Proj, Attr) then if To_Lower (Attribute_Value (Proj, Attr)) = "true" then return True; end if; end if; return False; end Is_Externally_Built; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Parse_Config_File; Scan_Parameters; case GNATtest_Mode is when Generation => Check_Parameters; when Aggregation => Check_Aggregation_Parameters; end case; exception when Parameter_Error => -- The diagnosis is already generated raise Fatal_Error; when others => Report_Err ("gnattest: initialization failed"); -- Exception info will be generated in main driver raise; end Initialize; --------------------------- -- Non_Null_Intersection -- --------------------------- function Non_Null_Intersection (Left : File_Array_Access; Right : File_Array_Access) return Boolean is begin for J in Left'Range loop declare Left_Str : constant String := Normalize_Pathname (Name => Left.all (J).Display_Full_Name, Case_Sensitive => False); begin for K in Right'Range loop if Left_Str = Normalize_Pathname (Name => Right.all (K).Display_Full_Name, Case_Sensitive => False) then Report_Std ("gnattest: source dir " & Left_Str & " is also an output dir"); return True; end if; end loop; end; end loop; return False; end Non_Null_Intersection; ----------------------------- -- Process_Exclusion_Lists -- ----------------------------- procedure Process_Exclusion_Lists is F : File_Type; S : String_Access; use String_To_String_Map; Cur : String_To_String_Map.Cursor := Stub_Exclusion_List_Files.First; begin Change_Dir (Run_Dir.all); if Default_Stub_Exclusion_List_File /= null then declare F_Path : constant String := Normalize_Pathname (Name => Default_Stub_Exclusion_List_File.all, Case_Sensitive => False); begin if not Is_Regular_File (F_Path) then Report_Err ("gnattest: cannot find " & F_Path); raise Parameter_Error; end if; Open (F, In_File, F_Path); while not End_Of_File (F) loop S := new String'(Get_Line (F)); if not Is_Comment (S.all) then Store_Default_Excluded_Stub (S.all); end if; Free (S); end loop; Close (F); end; end if; while Cur /= String_To_String_Map.No_Element loop declare Unit : constant String := Key (Cur); F_Path : constant String := Normalize_Pathname (Name => Element (Cur), Case_Sensitive => False); begin if not Is_Regular_File (F_Path) then Report_Err ("gnattest: cannot find " & F_Path); raise Parameter_Error; end if; Open (F, In_File, F_Path); while not End_Of_File (F) loop S := new String'(Get_Line (F)); if not Is_Comment (S.all) then Store_Excluded_Stub (Unit, S.all); end if; Free (S); end loop; Close (F); end; Next (Cur); end loop; Change_Dir (Temp_Dir.all); end Process_Exclusion_Lists; ------------------------------------------- -- Register_Gnattest_Specific_Attributes -- ------------------------------------------- procedure Register_Gnattest_Specific_Attributes is Dummy : String_Access; begin Dummy := new String' (Register_New_Attribute (Name => "harness_dir", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "subdir", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "tests_root", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "tests_dir", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "additional_tests", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "skeletons_default", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "gnattest_switches", Pkg => "gnattest", Is_List => True)); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "default_stub_exclusion_list", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "stub_exclusion_list", Pkg => "gnattest", Indexed => True)); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); Dummy := new String' (Register_New_Attribute (Name => "stubs_dir", Pkg => "gnattest")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); -- Not really a gnattest specific attribute, but we still need to -- inherit makefile attribute in test driver. Dummy := new String' (Register_New_Attribute (Name => "makefile", Pkg => "make")); if Dummy.all /= "" then Report_Err ("gnattest: cannot parse project file"); Report_Err (Dummy.all); raise Fatal_Error; end if; Free (Dummy); end Register_Gnattest_Specific_Attributes; --------------------- -- Scan_Parameters -- --------------------- procedure Scan_Parameters is Multiple_Output : Boolean := False; Possible_Switches : constant String := "h d? P: q -tests-root= " & "-help -version " & "-separates " & "-no-separates " & "-transition " & "-subdir= -subdirs= r v X? U " & "-harness-only " & "-stub " & "-separate-drivers? " & "-skeleton-default= " & "-passed-tests= " & "-exit-status= " & "-omit-sloc " & "-test-duration " & "-validate-type-extensions " & "-inheritance-check " & "-no-inheritance-check " & "-additional-tests= " & "-harness-dir= " & "-tests-dir= " & "-stubs-dir= " & "-queues= j? " & "-RTS= -target= " & "-no-command-line " & "-exclude-from-stubbing? " & "files= " & "-ignore= " & "-reporter= " & "-test-case-only " & "-strict " & "-copy-environment= " & "-no-subprojects"; Ignore_Arg : String_Access := new String'(""); function Get_GNATtest_Mode return GNATtest_Modes; procedure Report_Switch (S : String; Expected_Mode : GNATtest_Modes); procedure Report_Multiple_Output (Second_Output_Mode : Output_Mode); procedure Process_Stub_Exclusion (S : String); function Get_GNATtest_Mode return GNATtest_Modes is Anything : Boolean := False; Opt_Counter : Natural := 0; V_Set : Boolean := False; begin Initialize_Option_Scan (Stop_At_First_Non_Switch => False, Section_Delimiters => "cargs"); loop case GNAT.Command_Line.Getopt (Possible_Switches) is when ASCII.NUL => exit; when 'P' => return Generation; when 'v' => Anything := True; V_Set := True; when others => Opt_Counter := Opt_Counter + 1; Anything := True; end case; end loop; Free (Ignore_Arg); Ignore_Arg := new String'(Get_Argument); if not Anything and then Ignore_Arg.all = "" then Brief_Help; raise Parameter_Error; end if; if File_Extension (Ignore_Arg.all) = ".gpr" then Source_Prj := new String'(Ignore_Arg.all); return Generation; end if; if File_Extension (Ignore_Arg.all) in ".adb" | ".ads" then Report_Err ("gnattest: project file not specified"); raise Parameter_Error; end if; if V_Set and then Ignore_Arg.all = "" and then Opt_Counter = 0 then Print_Version_Info (2011); OS_Exit (0); end if; return Aggregation; end Get_GNATtest_Mode; procedure Process_Stub_Exclusion (S : String) is Idx : Natural; Valid_Format : constant Boolean := S'Length > 1 and then ((S (S'First) = '=') or else (S (S'First) = ':' and then Index (S, "=") > S'First + 1)); begin if not Valid_Format then Report_Err ("wrong parameter for --exclude-from-stubbing: " & S); raise Parameter_Error; end if; if S (S'First) = '=' then Default_Stub_Exclusion_List_File := new String' (S (S'First + 1 .. S'Last)); elsif S (S'First) = ':' then Idx := Index (S, "="); Stub_Exclusion_List_Files.Include (S (S'First + 1 .. Idx - 1), S (Idx + 1 .. S'Last)); else Report_Err ("wrong parameter for --exclude-from-stubbing: " & S); raise Parameter_Error; end if; end Process_Stub_Exclusion; procedure Report_Switch (S : String; Expected_Mode : GNATtest_Modes) is begin if Expected_Mode /= GNATtest_Mode then case GNATtest_Mode is when Generation => Report_Std ("warning: (gnattest) -" & S & " switch is not relevant in generation mode"); when Aggregation => Report_Std ("warning: (gnattest) -" & S & " switch is not relevant in aggregation mode"); end case; end if; end Report_Switch; procedure Report_Multiple_Output (Second_Output_Mode : Output_Mode) is function Mode_Image (M : Output_Mode) return String is (case M is when Separate_Root => "--tests-root", when Subdir => "--subdir", when Direct => "--tests-dir"); begin Report_Err ("gnattest: multiple output modes are not allowed"); if Second_Output_Mode = Output_M then Report_Err ("gnattest: option " & Mode_Image (Output_M) & " specified more than once"); else Report_Err ("gnattest: options " & Mode_Image (Output_M) & " and " & Mode_Image (Second_Output_Mode) & " are mutually exclusive"); end if; end Report_Multiple_Output; begin GNATtest_Mode := Get_GNATtest_Mode; Initialize_Option_Scan (Stop_At_First_Non_Switch => False, Section_Delimiters => "cargs"); loop case GNAT.Command_Line.Getopt (Possible_Switches) is when ASCII.NUL => exit; when 'U' => Recursive_Sources := True; U_Set := True; Recursiveness_Set := True; Report_Switch (Full_Switch, Generation); when 'd' => if Full_Switch = "d" then Set_Debug_Options (Parameter); end if; when 'f' => if Full_Switch = "files" then Files_List := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; when 'j' => declare N : Natural; begin N := Positive'Value (Parameter); if N = 0 then Queues_Number := Positive (System.Multiprocessors.Number_Of_CPUs); else Queues_Number := N; end if; exception when Constraint_Error => Report_Err ("wrong parameter for -j, " & "should be a natural number"); raise Parameter_Error; end; Report_Switch (Full_Switch, Aggregation); when 'P' => Source_Prj := new String'(Parameter); when 'q' => Quiet := True; when 'v' => Verbose := True; Print_Version_Info (2011); when 'r' => Recursive_Sources := True; Report_Switch (Full_Switch, Generation); Recursiveness_Set := True; R_Set := True; when '-' => if Full_Switch = "-additional-tests" then Additional_Tests_Prj := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-passed-tests" then if Parameter = "hide" then Show_Passed_Tests := False; Show_Passed_Tests_Set := True; elsif Parameter = "show" then Show_Passed_Tests := True; Show_Passed_Tests_Set := True; else Report_Err ("gnattest: --passed-tests " & "should be either show or hide"); raise Parameter_Error; end if; end if; if Full_Switch = "-skeleton-default" then if Parameter = "pass" then Skeletons_Fail := False; Default_Skeletons_Set := True; elsif Parameter = "fail" then Skeletons_Fail := True; Default_Skeletons_Set := True; else Report_Err ("gnattest: --skeleton-default " & "should be either fail or pass"); raise Parameter_Error; end if; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-exit-status" then if Parameter = "on" then Add_Exit_Status := True; Add_Exit_Status_Set := True; elsif Parameter = "off" then Add_Exit_Status := True; Add_Exit_Status_Set := True; else Report_Err ("gnattest: --exit-code " & "should be either on or off"); raise Parameter_Error; end if; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-tests-root" then if not Multiple_Output then Output_M := Separate_Root; Output_M_Set := True; Separate_Root_Dir := new String'(Parameter); Multiple_Output := True; else Report_Multiple_Output (Separate_Root); raise Parameter_Error; end if; Report_Switch (Full_Switch, Generation); Tests_Dir_Set := True; end if; if Full_Switch in "-subdir" | "-subdirs" then if GNATtest_Mode = Generation then if not Multiple_Output then Output_M := Subdir; Output_M_Set := True; Test_Subdir_Name := new String'(Parameter); Multiple_Output := True; else Report_Multiple_Output (Subdir); raise Parameter_Error; end if; Tests_Dir_Set := True; else Free (Aggregate_Subdir_Name); Aggregate_Subdir_Name := new String'(Parameter); end if; end if; if Full_Switch = "-tests-dir" then if not Multiple_Output then Output_M := Direct; Output_M_Set := True; Test_Dir_Name := new String'(Parameter); Multiple_Output := True; else Report_Multiple_Output (Direct); raise Parameter_Error; end if; Report_Switch (Full_Switch, Generation); Tests_Dir_Set := True; end if; if Full_Switch = "-stubs-dir" then Stub_Dir_Name := new String'(Parameter); Report_Switch (Full_Switch, Generation); Stub_Dir_Set := True; end if; if Full_Switch = "-validate-type-extensions" then Substitution_Suite := True; Report_Switch (Full_Switch, Generation); if Stub_Mode_ON then Report_Std ("warning: --validate-type-extensions has no effect " & "in --stub mode"); end if; end if; if Full_Switch = "-inheritance-check" then Inheritance_To_Suite := True; Inheritance_Check_Set := True; Report_Switch (Full_Switch, Generation); if Stub_Mode_ON then Report_Std ("warning: --inheritance-check has no effect " & "in --stub mode"); end if; end if; if Full_Switch = "-no-inheritance-check" then Inheritance_To_Suite := False; Inheritance_Check_Set := True; Report_Switch (Full_Switch, Generation); if Stub_Mode_ON then Report_Std ("warning: --no-inheritance-check has no effect " & "in --stub mode"); end if; end if; if Full_Switch = "-omit-sloc" then Omit_Sloc := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-test-duration" then Show_Test_Duration := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-harness-dir" then Harness_Dir := new String'(Parameter); Harness_Set_By_Switch := True; Report_Switch (Full_Switch, Generation); Harness_Dir_Set := True; end if; if Full_Switch = "-harness-only" then Harness_Only := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-separates" then Generate_Separates := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-no-separates" then Generate_Separates := False; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-transition" then Transition := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-stub" then Stub_Mode_ON := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-separate-drivers" then Separate_Drivers_Set_By_Switch := True; declare S : constant String := Parameter; begin Separate_Drivers := True; if S = "" or else S = "=unit" then Driver_Per_Unit := True; elsif S = "=test" then Driver_Per_Unit := False; else Report_Err ("wrong parameter for --separate-drivers"); raise Parameter_Error; end if; end; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-version" then Print_Tool_Version (2011); OS_Exit (0); end if; if Full_Switch = "-help" then Brief_Help; raise Parameter_Error; end if; if Full_Switch = "-queues" then declare N : constant Natural := Positive'Value (Parameter); begin if N = 0 then Queues_Number := Positive (System.Multiprocessors.Number_Of_CPUs); else Queues_Number := N; end if; exception when Constraint_Error => Report_Err ("wrong parameter for --queues, " & "should be a natural number"); raise Parameter_Error; end; Report_Switch (Full_Switch, Aggregation); end if; if Full_Switch = "-RTS" then Free (GNATtest.Options.RTS_Path); GNATtest.Options.RTS_Path := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-target" then Free (GNATtest.Options.Target); GNATtest.Options.Target := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-no-command-line" then No_Command_Line_Externally_Set := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-test-case-only" then Test_Case_Only := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-exclude-from-stubbing" then Process_Stub_Exclusion (Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-ignore" then Excluded_Files_List := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-reporter" then Free (Reporter_Name); Reporter_Name := new String'(Parameter); Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-strict" then Strict_Execution := True; Report_Switch (Full_Switch, Generation); end if; if Full_Switch = "-copy-environment" then Environment_Dir := new String'(Parameter); Report_Switch (Full_Switch, Aggregation); end if; if Full_Switch = "-no-subprojects" then Recursive_Sources := False; Report_Switch (Full_Switch, Generation); Recursiveness_Set := False; end if; when 'X' => Ext_Var_Buffer.Append (Parameter); when others => raise Parameter_Error; end case; end loop; loop declare Temp : constant String := Get_Argument; begin if Temp = "" then exit; end if; if Temp /= Ignore_Arg.all or else GNATtest_Mode = Aggregation then Source_Buffer.Append (Temp); end if; end; end loop; Process_cargs_Section; exception when GNAT.Command_Line.Invalid_Switch => Report_Err ("gnattest: invalid switch : " & Full_Switch); Report_Err ("Try `gnattest --help` for more information."); raise Parameter_Error; when GNAT.Command_Line.Invalid_Parameter => Report_Err ("gnattest: missing parameter for: -" & Full_Switch); Report_Err ("Try `gnattest --help` for more information."); raise Parameter_Error; end Scan_Parameters; ------------------------------ -- Has_Command_Line_Support -- ------------------------------ function Has_Command_Line_Support return Boolean is Files : constant GNATCOLL.VFS.File_Array := Predefined_Source_Files (Env); begin if No_Command_Line_Externally_Set then return False; end if; for I in Files'Range loop if Files (I).Display_Base_Name = "a-comlin.ads" then return True; end if; end loop; return False; end Has_Command_Line_Support; end GNATtest.Environment;