-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  Copyright (C) 2014, 2015, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;

with Bfd.Symbols;
with Bfd.Files;
with Bfd.Constants;

with Util.Refs;

with MAT.Types;
with MAT.Consoles;
with MAT.Memory;
package MAT.Symbols.Targets is

   --  The <tt>Region_Symbols</tt> holds the symbol table associated with the program or
   --  a shared library loaded by the program.  The <tt>Region</tt> indicates
   --  the text segment address of the program or the loaded library.
   type Region_Symbols is new Util.Refs.Ref_Entity with record
      Region     : MAT.Memory.Region_Info;
      Offset     : MAT.Types.Target_Addr;
      File       : Bfd.Files.File_Type;
      Symbols    : Bfd.Symbols.Symbol_Table;
   end record;
   type Region_Symbols_Access is access all Region_Symbols;

   --  Load the symbol table for the associated region.
   procedure Open (Symbols     : in out Region_Symbols;
                   Path        : in String;
                   Search_Path : in String);

   package Region_Symbols_Refs is
     new Util.Refs.References (Region_Symbols, Region_Symbols_Access);

   subtype Region_Symbols_Ref is Region_Symbols_Refs.Ref;

   type Symbol_Info is limited record
      File    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Line    : Natural;
      Symbols : Region_Symbols_Ref;
   end record;

   --  The <tt>Symbols_Maps</tt> keeps a sorted list of symbol tables indexed
   --  by their mapping address.
   use type Region_Symbols_Refs.Ref;
   use type MAT.Types.Target_Addr;
   package Symbols_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Region_Symbols_Ref);

   subtype Symbols_Map is Symbols_Maps.Map;
   subtype Symbols_Cursor is Symbols_Maps.Cursor;

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      Path        : Ada.Strings.Unbounded.Unbounded_String;
      Search_Path : Ada.Strings.Unbounded.Unbounded_String;
      Symbols     : Bfd.Symbols.Symbol_Table;
      Libraries   : Symbols_Maps.Map;
      Demangle    : Bfd.Demangle_Flags := Bfd.Constants.DMGL_AUTO;
      Console     : MAT.Consoles.Console_Access;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Load the symbols associated with a shared library described by the memory region.
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Region      : in MAT.Memory.Region_Info;
                           Offset_Addr : in MAT.Types.Target_Addr);

   --  Load the symbols associated with all the shared libraries described by
   --  the memory region map.
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Regions     : in MAT.Memory.Region_Info_Map);

   --  Demangle the symbol.
   procedure Demangle (Symbols : in Target_Symbols;
                       Symbol  : in out Symbol_Info);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Symbol  : out Symbol_Info);

   --  Find the symbol in the symbol table and return the start and end address.
   procedure Find_Symbol_Range (Symbols : in Target_Symbols;
                                Name    : in String;
                                From    : out MAT.Types.Target_Addr;
                                To      : out MAT.Types.Target_Addr);

   --  Find the symbol region in the symbol table which contains the given address
   --  and return the start and end address.
   procedure Find_Symbol_Range (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                From    : out MAT.Types.Target_Addr;
                                To      : out MAT.Types.Target_Addr);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

   subtype Target_Symbols_Ref is Target_Symbols_Refs.Ref;

end MAT.Symbols.Targets;

-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  Copyright (C) 2014, 2015, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;

with Bfd.Symbols;
with Bfd.Files;
with Bfd.Constants;

with Util.Refs;

with MAT.Types;
with MAT.Consoles;
with MAT.Memory;
package MAT.Symbols.Targets is

   --  The <tt>Region_Symbols</tt> holds the symbol table associated with the program or
   --  a shared library loaded by the program.  The <tt>Region</tt> indicates
   --  the text segment address of the program or the loaded library.
   type Region_Symbols is new Util.Refs.Ref_Entity with record
      Region     : MAT.Memory.Region_Info;
      Offset     : MAT.Types.Target_Addr;
      File       : Bfd.Files.File_Type;
      Symbols    : Bfd.Symbols.Symbol_Table;
   end record;
   type Region_Symbols_Access is access all Region_Symbols;

   --  Load the symbol table for the associated region.
   procedure Open (Symbols     : in out Region_Symbols;
                   Path        : in String;
                   Search_Path : in String);

   package Region_Symbols_Refs is
     new Util.Refs.References (Region_Symbols, Region_Symbols_Access);

   subtype Region_Symbols_Ref is Region_Symbols_Refs.Ref;

   type Symbol_Info is limited record
      File    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Line    : Natural;
      Symbols : Region_Symbols_Ref;
   end record;

   --  The <tt>Symbols_Maps</tt> keeps a sorted list of symbol tables indexed
   --  by their mapping address.
   use type Region_Symbols_Refs.Ref;
   use type MAT.Types.Target_Addr;
   package Symbols_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Region_Symbols_Ref);

   subtype Symbols_Map is Symbols_Maps.Map;
   subtype Symbols_Cursor is Symbols_Maps.Cursor;

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      Path         : Ada.Strings.Unbounded.Unbounded_String;
      Search_Path  : Ada.Strings.Unbounded.Unbounded_String;
      Symbols      : Bfd.Symbols.Symbol_Table;
      Libraries    : Symbols_Maps.Map;
      Demangle     : Bfd.Demangle_Flags := Bfd.Constants.DMGL_AUTO;
      Use_Demangle : Boolean := True;
      Console      : MAT.Consoles.Console_Access;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Load the symbols associated with a shared library described by the memory region.
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Region      : in MAT.Memory.Region_Info;
                           Offset_Addr : in MAT.Types.Target_Addr);

   --  Load the symbols associated with all the shared libraries described by
   --  the memory region map.
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Regions     : in MAT.Memory.Region_Info_Map);

   --  Demangle the symbol.
   procedure Demangle (Symbols : in Target_Symbols;
                       Symbol  : in out Symbol_Info);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Symbol  : out Symbol_Info);

   --  Find the symbol in the symbol table and return the start and end address.
   procedure Find_Symbol_Range (Symbols : in Target_Symbols;
                                Name    : in String;
                                From    : out MAT.Types.Target_Addr;
                                To      : out MAT.Types.Target_Addr);

   --  Find the symbol region in the symbol table which contains the given address
   --  and return the start and end address.
   procedure Find_Symbol_Range (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                From    : out MAT.Types.Target_Addr;
                                To      : out MAT.Types.Target_Addr);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

   subtype Target_Symbols_Ref is Target_Symbols_Refs.Ref;

end MAT.Symbols.Targets;

Add Use_Demangle flag to enable/disable demangling


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Parameters;
with Pilot;
with Unix;

procedure Ravenadm is

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;

   type mandate_type is (unset, help, dev, build, build_everything, force, test,
                         status, status_everything, configure, locate, purge, changeopts,
                         checkports, portsnap, repository);
   type dev_mandate  is (unset, dump, makefile, distinfo, buildsheet, template, genindex);

   procedure scan_first_command_word;
   function scan_dev_command_word return dev_mandate;
   function get_arg (arg_number : Positive) return String;

   mandate    : mandate_type := unset;
   low_rights : Boolean := False;

   procedure scan_first_command_word
   is
      first  : constant String := CLI.Argument (1);
   begin
      if first = "help" then
         mandate := help;
      elsif first = "dev" then
         mandate := dev;
      elsif first = "build" then
         mandate := build;
      elsif first = "build-everything" then
         mandate := build_everything;
      elsif first = "force" then
         mandate := force;
      elsif first = "test" then
         mandate := test;
      elsif first = "status" then
         mandate := status;
      elsif first = "status-everything" then
         mandate := status_everything;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "locate" then
         mandate := locate;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "set-options" then
         mandate := changeopts;
      elsif first = "check-ports" then
         mandate := checkports;
      elsif first = "update-ports" then
         mandate := portsnap;
      elsif first = "generate-repository" then
         mandate := repository;
      end if;
   end scan_first_command_word;

   function scan_dev_command_word return dev_mandate
   is
      --  Check argument count before calling
      second : constant String := CLI.Argument (2);
   begin
      if second = "dump" then
         return dump;
      elsif second = "makefile" then
         return makefile;
      elsif second = "distinfo" then
         return distinfo;
      elsif second = "buildsheet" then
         return buildsheet;
      elsif second = "template" then
         return template;
      elsif second = "generate-index" then
         return genindex;
      else
         return unset;
      end if;
   end scan_dev_command_word;

   function get_arg (arg_number : Positive) return String is
   begin
      if CLI.Argument_Count >= arg_number then
         return CLI.Argument (arg_number);
      else
         return "";
      end if;
   end get_arg;

begin

   if CLI.Argument_Count = 0 then
      Pilot.display_usage;
      return;
   end if;

   scan_first_command_word;

   if mandate = unset then
      Pilot.react_to_unknown_first_level_command (CLI.Argument (1));
      return;
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block start
   --------------------------------------------------------------------------------------------

   if Pilot.already_running then
      return;
   end if;

   if not Parameters.load_configuration then
      return;
   end if;

   case mandate is
      when build | build_everything | test | status | status_everything =>
         --  All commands involving replicant slaves
         if Pilot.launch_clash_detected then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | test =>
         if Parameters.configuration.avec_ncurses and then
           not Pilot.TERM_defined_in_environment
         then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when configure | help => null;
      when portsnap =>
         if not Parameters.all_paths_valid (skip_mk_check => True) then
            return;
         end if;
      when others =>
         if not Parameters.all_paths_valid (skip_mk_check => False) then
            return;
         end if;
   end case;

   case mandate is
      when help | locate => null;
         low_rights := True;
      when others =>
         if Pilot.insufficient_privileges then
            return;
         end if;
   end case;

   if Pilot.previous_run_mounts_detected and then
     not Pilot.old_mounts_successfully_removed
   then
      return;
   end if;

   if Pilot.previous_realfs_work_detected and then
     not Pilot.old_realfs_work_successfully_removed
   then
      return;
   end if;

   if Pilot.ravenexec_missing then
      return;
   end if;

   case mandate is
      when build | force | test | changeopts =>
         if not Pilot.store_origins (start_from => 2) then
            return;
         end if;
      when status =>
         if CLI.Argument_Count > 1 then
            if not Pilot.store_origins (start_from => 2) then
               return;
            end if;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | force | test | status | status_everything =>
         if not Pilot.slave_platform_determined then
            return;
         end if;
      when others => null;
   end case;

   if not low_rights then
      Pilot.create_pidfile;
      Unix.ignore_background_tty;
   end if;

   if mandate /= configure then
      Unix.cone_of_silence (deploy => True);
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block end
   --------------------------------------------------------------------------------------------

   case mandate is

      when status =>
         --------------------------------
         --  status command
         --------------------------------
         if CLI.Argument_Count > 1 then
            if Pilot.install_compiler_packages and then
              Pilot.scan_stack_of_single_ports (always_build => False) and then
              Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
            then
               Pilot.display_results_of_dry_run;
            end if;
         else
            null;  -- reserved for upgrade_system_everything maybe
         end if;

      when status_everything =>
         --------------------------------
         --  status_everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
         then
            Pilot.display_results_of_dry_run;
         end if;

      when build =>
         --------------------------------
         --  build command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when build_everything =>
         --------------------------------
         --  build-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when force =>
         --------------------------------
         --  force command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when dev =>
         --------------------------------
         --  dev command
         --------------------------------
         if CLI.Argument_Count > 1 then
            declare
               dev_subcmd : dev_mandate := scan_dev_command_word;
            begin
               case dev_subcmd is
                  when unset =>
                     Pilot.react_to_unknown_second_level_command (CLI.Argument (1),
                                                                  CLI.Argument (2));
                  when dump =>
                     Pilot.dump_ravensource (get_arg (3));
                  when distinfo =>
                     Pilot.generate_distinfo;
                  when buildsheet =>
                     Pilot.generate_buildsheet (get_arg (3), get_arg (4));
                  when makefile =>
                     Pilot.generate_makefile (get_arg (3), get_arg (4));
                  when template =>
                     Pilot.print_spec_template (get_arg (3));
                  when genindex =>
                     Pilot.generate_ports_index;
               end case;
            end;
         else
            Pilot.react_to_unknown_second_level_command (CLI.Argument (1), "");
         end if;

      when help =>
         --------------------------------
         --  help command
         --------------------------------
         null;  --  tbw

      when test =>
         --------------------------------
         --  test command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => True) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            if Pilot.interact_with_single_builder then
               Pilot.bulk_run_then_interact_with_final_port;
            else
               Pilot.perform_bulk_run (testmode => True);
            end if;
         end if;

      when configure =>
         --------------------------------
         --  configure
         --------------------------------
         Pilot.launch_configure_menu;

      when locate =>
         --------------------------------
         --  locate
         --------------------------------
         Pilot.locate (get_arg (2));

      when purge =>
         --------------------------------
         --  purge-distfiles
         --------------------------------
         Pilot.purge_distfiles;

      when changeopts =>
         --------------------------------
         --  set-options
         --------------------------------
         Pilot.change_options;

      when checkports =>
         --------------------------------
         --  check-ports
         --------------------------------
         Pilot.check_ravenports_version;

      when portsnap =>
         --------------------------------
         --  update-ports
         --------------------------------
         Pilot.update_to_latest_ravenports;

      when repository =>
         --------------------------------
         --  generate-repository
         --------------------------------
         Pilot.generate_repository;

      when unset => null;

   end case;

   Unix.cone_of_silence (deploy => False);

   if not low_rights then
      Pilot.destroy_pidfile;
   end if;

end Ravenadm;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Parameters;
with Pilot;
with Unix;

procedure Ravenadm is

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;

   type mandate_type is (unset, help, dev, build, build_everything, force, test, test_everything,
                         status, status_everything, configure, locate, purge, changeopts,
                         checkports, portsnap, repository);
   type dev_mandate  is (unset, dump, makefile, distinfo, buildsheet, template, genindex);

   procedure scan_first_command_word;
   function scan_dev_command_word return dev_mandate;
   function get_arg (arg_number : Positive) return String;

   mandate    : mandate_type := unset;
   low_rights : Boolean := False;

   procedure scan_first_command_word
   is
      first  : constant String := CLI.Argument (1);
   begin
      if first = "help" then
         mandate := help;
      elsif first = "dev" then
         mandate := dev;
      elsif first = "build" then
         mandate := build;
      elsif first = "build-everything" then
         mandate := build_everything;
      elsif first = "force" then
         mandate := force;
      elsif first = "test" then
         mandate := test;
      elsif first = "test-everything" then
         mandate := test_everything;
      elsif first = "status" then
         mandate := status;
      elsif first = "status-everything" then
         mandate := status_everything;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "locate" then
         mandate := locate;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "set-options" then
         mandate := changeopts;
      elsif first = "check-ports" then
         mandate := checkports;
      elsif first = "update-ports" then
         mandate := portsnap;
      elsif first = "generate-repository" then
         mandate := repository;
      end if;
   end scan_first_command_word;

   function scan_dev_command_word return dev_mandate
   is
      --  Check argument count before calling
      second : constant String := CLI.Argument (2);
   begin
      if second = "dump" then
         return dump;
      elsif second = "makefile" then
         return makefile;
      elsif second = "distinfo" then
         return distinfo;
      elsif second = "buildsheet" then
         return buildsheet;
      elsif second = "template" then
         return template;
      elsif second = "generate-index" then
         return genindex;
      else
         return unset;
      end if;
   end scan_dev_command_word;

   function get_arg (arg_number : Positive) return String is
   begin
      if CLI.Argument_Count >= arg_number then
         return CLI.Argument (arg_number);
      else
         return "";
      end if;
   end get_arg;

begin

   if CLI.Argument_Count = 0 then
      Pilot.display_usage;
      return;
   end if;

   scan_first_command_word;

   if mandate = unset then
      Pilot.react_to_unknown_first_level_command (CLI.Argument (1));
      return;
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block start
   --------------------------------------------------------------------------------------------

   if Pilot.already_running then
      return;
   end if;

   if not Parameters.load_configuration then
      return;
   end if;

   case mandate is
      when build | build_everything | test | status | status_everything =>
         --  All commands involving replicant slaves
         if Pilot.launch_clash_detected then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | test =>
         if Parameters.configuration.avec_ncurses and then
           not Pilot.TERM_defined_in_environment
         then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when configure | help => null;
      when portsnap =>
         if not Parameters.all_paths_valid (skip_mk_check => True) then
            return;
         end if;
      when others =>
         if not Parameters.all_paths_valid (skip_mk_check => False) then
            return;
         end if;
   end case;

   case mandate is
      when help | locate => null;
         low_rights := True;
      when others =>
         if Pilot.insufficient_privileges then
            return;
         end if;
   end case;

   if Pilot.previous_run_mounts_detected and then
     not Pilot.old_mounts_successfully_removed
   then
      return;
   end if;

   if Pilot.previous_realfs_work_detected and then
     not Pilot.old_realfs_work_successfully_removed
   then
      return;
   end if;

   if Pilot.ravenexec_missing then
      return;
   end if;

   case mandate is
      when build | force | test | changeopts =>
         if not Pilot.store_origins (start_from => 2) then
            return;
         end if;
      when status =>
         if CLI.Argument_Count > 1 then
            if not Pilot.store_origins (start_from => 2) then
               return;
            end if;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | force | test | status | status_everything =>
         if not Pilot.slave_platform_determined then
            return;
         end if;
      when others => null;
   end case;

   if not low_rights then
      Pilot.create_pidfile;
      Unix.ignore_background_tty;
   end if;

   if mandate /= configure then
      Unix.cone_of_silence (deploy => True);
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block end
   --------------------------------------------------------------------------------------------

   case mandate is

      when status =>
         --------------------------------
         --  status command
         --------------------------------
         if CLI.Argument_Count > 1 then
            if Pilot.install_compiler_packages and then
              Pilot.scan_stack_of_single_ports (always_build => False) and then
              Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
            then
               Pilot.display_results_of_dry_run;
            end if;
         else
            null;  -- reserved for upgrade_system_everything maybe
         end if;

      when status_everything =>
         --------------------------------
         --  status_everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
         then
            Pilot.display_results_of_dry_run;
         end if;

      when build =>
         --------------------------------
         --  build command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when build_everything =>
         --------------------------------
         --  build-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when test_everything =>
         --------------------------------
         --  test-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => True);
         end if;

      when force =>
         --------------------------------
         --  force command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when dev =>
         --------------------------------
         --  dev command
         --------------------------------
         if CLI.Argument_Count > 1 then
            declare
               dev_subcmd : dev_mandate := scan_dev_command_word;
            begin
               case dev_subcmd is
                  when unset =>
                     Pilot.react_to_unknown_second_level_command (CLI.Argument (1),
                                                                  CLI.Argument (2));
                  when dump =>
                     Pilot.dump_ravensource (get_arg (3));
                  when distinfo =>
                     Pilot.generate_distinfo;
                  when buildsheet =>
                     Pilot.generate_buildsheet (get_arg (3), get_arg (4));
                  when makefile =>
                     Pilot.generate_makefile (get_arg (3), get_arg (4));
                  when template =>
                     Pilot.print_spec_template (get_arg (3));
                  when genindex =>
                     Pilot.generate_ports_index;
               end case;
            end;
         else
            Pilot.react_to_unknown_second_level_command (CLI.Argument (1), "");
         end if;

      when help =>
         --------------------------------
         --  help command
         --------------------------------
         null;  --  tbw

      when test =>
         --------------------------------
         --  test command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => True) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            if Pilot.interact_with_single_builder then
               Pilot.bulk_run_then_interact_with_final_port;
            else
               Pilot.perform_bulk_run (testmode => True);
            end if;
         end if;

      when configure =>
         --------------------------------
         --  configure
         --------------------------------
         Pilot.launch_configure_menu;

      when locate =>
         --------------------------------
         --  locate
         --------------------------------
         Pilot.locate (get_arg (2));

      when purge =>
         --------------------------------
         --  purge-distfiles
         --------------------------------
         Pilot.purge_distfiles;

      when changeopts =>
         --------------------------------
         --  set-options
         --------------------------------
         Pilot.change_options;

      when checkports =>
         --------------------------------
         --  check-ports
         --------------------------------
         Pilot.check_ravenports_version;

      when portsnap =>
         --------------------------------
         --  update-ports
         --------------------------------
         Pilot.update_to_latest_ravenports;

      when repository =>
         --------------------------------
         --  generate-repository
         --------------------------------
         Pilot.generate_repository;

      when unset => null;

   end case;

   Unix.cone_of_silence (deploy => False);

   if not low_rights then
      Pilot.destroy_pidfile;
   end if;

end Ravenadm;

Add "test-everything" command

Add "test-everything" command


-----------------------------------------------------------------------
--  Faces Context Tests - Unit tests for ASF.Contexts.Faces
--  Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;

with Util.Test_Caller;

with ASF.Applications.Messages.Factory;
with ASF.Contexts.Flash;
with ASF.Contexts.Faces.Mockup;
package body ASF.Contexts.Faces.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Contexts.Faces");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Add_Message",
                       Test_Add_Message'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Max_Severity",
                       Test_Max_Severity'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Message",
                       Test_Get_Messages'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Queue_Exception",
                       Test_Queue_Exception'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Flash",
                       Test_Flash_Context'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Attribute",
                       Test_Get_Attribute'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Bean",
                       Test_Get_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Helpers.Beans.Get_Bean",
                       Test_Get_Bean_Helper'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Mockup",
                       Test_Mockup_Faces_Context'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Messages.Factory.Add_Message",
                       Test_Add_Localized_Message'Access);
   end Add_Tests;

   --  ------------------------------
   --  Setup the faces context for the unit test.
   --  ------------------------------
   procedure Setup (T       : in out Test;
                    Context : in out Faces_Context) is
   begin
      T.Form          := new ASF.Applications.Tests.Form_Bean;
      Context.Set_ELContext (T.ELContext.all'Access);

      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("dumbledore"),
                                EL.Objects.To_Object (String '("albus")));

      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("potter"),
                                EL.Objects.To_Object (String '("harry")));
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("hogwarts"),
                                EL.Objects.To_Object (T.Form.all'Access,
                                                      EL.Objects.STATIC));
   end Setup;

   --  ------------------------------
   --  Cleanup the test instance.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (ASF.Applications.Tests.Form_Bean'Class,
                                        ASF.Applications.Tests.Form_Bean_Access);
   begin
      ASF.Tests.EL_Test (T).Tear_Down;
      Free (T.Form);
   end Tear_Down;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Get_Attribute (T : in out Test) is
      Ctx   : Faces_Context;
      Name  : EL.Objects.Object;
   begin
      T.Setup (Ctx);

      Name := Ctx.Get_Attribute ("dumbledore");
      T.Assert (not EL.Objects.Is_Null (Name), "Null attribute returned");
      Util.Tests.Assert_Equals (T, "albus", EL.Objects.To_String (Name), "Invalid attribute");

      Name := Ctx.Get_Attribute ("potter");
      T.Assert (not EL.Objects.Is_Null (Name), "Null attribute returned");
      Util.Tests.Assert_Equals (T, "harry", EL.Objects.To_String (Name), "Invalid attribute");

      Name := Ctx.Get_Attribute ("voldemort");
      T.Assert (EL.Objects.Is_Null (Name), "Oops... is there any horcrux left?");

   end Test_Get_Attribute;

   --  ------------------------------
   --  Test getting a bean object from the faces context.
   --  ------------------------------
   procedure Test_Get_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Ctx   : Faces_Context;
      Bean  : Util.Beans.Basic.Readonly_Bean_Access;
   begin
      T.Setup (Ctx);

      Bean := Ctx.Get_Bean ("dumbledore");
      T.Assert (Bean = null, "Dumbledore should not be a bean");

      Bean := Ctx.Get_Bean ("hogwarts");
      T.Assert (Bean /= null, "hogwarts should be a bean");
   end Test_Get_Bean;

   --  ------------------------------
   --  Test getting a bean object from the faces context and doing a conversion.
   --  ------------------------------
   procedure Test_Get_Bean_Helper (T : in out Test) is
      use type ASF.Applications.Tests.Form_Bean_Access;

      Ctx   : aliased Faces_Context;
      Bean  : ASF.Applications.Tests.Form_Bean_Access;
   begin
      T.Setup (Ctx);

      Bean := Get_Form_Bean ("hogwarts");
      T.Assert (Bean = null, "A bean was found while the faces context does not exist!");

      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, null);
      Bean := Get_Form_Bean ("hogwarts");
      T.Assert (Bean /= null, "hogwarts should be a bean");

      Bean := Get_Form_Bean ("dumbledore");
      T.Assert (Bean = null, "Dumbledore should not be a bean");

      ASF.Contexts.Faces.Restore (null);
   end Test_Get_Bean_Helper;

   --  ------------------------------
   --  Test the faces message queue.
   --  ------------------------------
   procedure Test_Add_Message (T : in out Test) is
      Ctx : Faces_Context;
   begin
      Ctx.Add_Message (Client_Id => "", Message => "msg1");
      Ctx.Add_Message (Client_Id => "", Message => "msg1");
      Ctx.Add_Message (Client_Id => "", Message => "msg2");
      Ctx.Add_Message (Client_Id => "", Message => "msg3");
      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => INFO);
      Ctx.Add_Message (Client_Id => "warn", Message => "msg3", Severity => WARN);
      Ctx.Add_Message (Client_Id => "error", Message => "msg3", Severity => ERROR);
      Ctx.Add_Message (Client_Id => "fatal", Message => "msg3", Severity => FATAL);
      T.Assert (Ctx.Get_Maximum_Severity = FATAL, "Add message failed");
   end Test_Add_Message;

   --  ------------------------------
   --  Test the application message factory for the creation of localized messages.
   --  ------------------------------
   procedure Test_Add_Localized_Message (T : in out Test) is
      App         : aliased Applications.Main.Application;
      App_Factory : Applications.Main.Application_Factory;
      Ctx         : aliased Faces_Context;
      Conf        : Applications.Config;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      App.Initialize (Conf, App_Factory);
      Set_Current (Ctx'Unchecked_Access, App'Unchecked_Access);
      ASF.Applications.Messages.Factory.Add_Message (Ctx, "asf.validators.length.maximum",
                                                     "23");
      --  ASF.Applications.Messages.Factory.Add_Message (Ctx, "asf.exceptions.unexpected.extended",
      --                                               "Fake-exception", "Fake-message");
      T.Assert (Ctx.Get_Maximum_Severity = ERROR, "Add message failed");
   end Test_Add_Localized_Message;

   procedure Test_Max_Severity (T : in out Test) is
      Ctx : Faces_Context;
   begin
      T.Assert (Ctx.Get_Maximum_Severity = NONE, "Invalid max severity with no message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => INFO);
      T.Assert (Ctx.Get_Maximum_Severity = INFO, "Invalid max severity with info message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => WARN);
      T.Assert (Ctx.Get_Maximum_Severity = WARN, "Invalid max severity with warn message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => FATAL);
      T.Assert (Ctx.Get_Maximum_Severity = FATAL, "Invalid max severity with warn message");
   end Test_Max_Severity;

   procedure Test_Get_Messages (T : in out Test) is
      Ctx : Faces_Context;
   begin
      --  Iterator on an empty message list.
      declare
         Iter : constant Vectors.Cursor := Ctx.Get_Messages (Client_Id => "");
      begin
         T.Assert (not Vectors.Has_Element (Iter), "Iterator should indicate no message");
      end;

      Ctx.Add_Message (Client_Id => "info", Message => "msg1", Severity => INFO);
      declare
         Iter : constant Vectors.Cursor := Ctx.Get_Messages (Client_Id => "info");
         M    : Message;
      begin
         T.Assert (Vectors.Has_Element (Iter), "Iterator should indicate a message");

         M := Vectors.Element (Iter);
         Assert_Equals (T, "msg1", Get_Summary (M), "Invalid message");
         Assert_Equals (T, "msg1", Get_Detail (M), "Invalid details");
         T.Assert (INFO = Get_Severity (M), "Invalid severity");
      end;
   end Test_Get_Messages;

   --  ------------------------------
   --  Test adding some exception in the faces context.
   --  ------------------------------
   procedure Test_Queue_Exception (T : in out Test) is
      procedure Raise_Exception (Depth : in Natural;
                                 Excep : in Natural);
      procedure Check_Exception (Event   : in Events.Exceptions.Exception_Event'Class;
                                 Remove  : out Boolean;
                                 Context : in out Faces_Context'Class);

      Ctx : Faces_Context;
      Cnt : Natural := 0;

      procedure Raise_Exception (Depth : in Natural;
                                 Excep : in Natural) is
      begin
         if Depth > 0 then
            Raise_Exception (Depth - 1, Excep);
         end if;
         case Excep is
            when 1 =>
               raise Constraint_Error with "except code 1";

            when 2 =>
               raise Ada.IO_Exceptions.Name_Error;

            when others =>
               raise Program_Error with "Testing program error";
         end case;
      end Raise_Exception;

      procedure Check_Exception (Event   : in Events.Exceptions.Exception_Event'Class;
                                 Remove  : out Boolean;
                                 Context : in out Faces_Context'Class) is
         pragma Unreferenced (Context, Event);
      begin
         Cnt    := Cnt + 1;
         Remove := False;
      end Check_Exception;

   begin
      --  Create some exceptions and queue them.
      for I in 1 .. 3 loop
         begin
            Raise_Exception (3, I);
         exception
            when E : others =>
               Ctx.Queue_Exception (E);
         end;
      end loop;

      Ctx.Iterate_Exception (Check_Exception'Access);
      Util.Tests.Assert_Equals (T, 3, Cnt, "3 exception should have been queued");
   end Test_Queue_Exception;

   --  ------------------------------
   --  Test the flash instance.
   --  ------------------------------
   procedure Test_Flash_Context (T : in out Test) is
      use type ASF.Contexts.Faces.Flash_Context_Access;

      Ctx   : Faces_Context;
      Flash : aliased ASF.Contexts.Flash.Flash_Context;
   begin
      Ctx.Set_Flash (Flash'Unchecked_Access);

      T.Assert (Ctx.Get_Flash /= null, "Null flash context returned");
   end Test_Flash_Context;

   --  ------------------------------
   --  Test the mockup faces context.
   --  ------------------------------
   procedure Test_Mockup_Faces_Context (T : in out Test) is
      use type ASF.Requests.Request_Access;
      use type ASF.Responses.Response_Access;
      use type EL.Contexts.ELContext_Access;
   begin
      ASF.Applications.Tests.Initialize_Test_Application;
      declare
         Ctx   : Mockup.Mockup_Faces_Context;
      begin
         Ctx.Set_Method ("GET");
         Ctx.Set_Path_Info ("something.html");
         T.Assert (Current /= null, "There is no current faces context (mockup failed)");

         T.Assert (Current.Get_Request /= null, "There is no current request");
         T.Assert (Current.Get_Response /= null, "There is no current response");
         T.Assert (Current.Get_Application /= null, "There is no current application");
         T.Assert (Current.Get_ELContext /= null, "There is no current ELcontext");
      end;
      T.Assert (Current = null, "There is a current faces context but it shoudl be null");
   end Test_Mockup_Faces_Context;

end ASF.Contexts.Faces.Tests;

-----------------------------------------------------------------------
--  Faces Context Tests - Unit tests for ASF.Contexts.Faces
--  Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;

with Util.Test_Caller;

with ASF.Applications.Main;
with ASF.Applications.Messages.Factory;
with ASF.Contexts.Flash;
with ASF.Contexts.Faces.Mockup;
package body ASF.Contexts.Faces.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Contexts.Faces");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Add_Message",
                       Test_Add_Message'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Max_Severity",
                       Test_Max_Severity'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Message",
                       Test_Get_Messages'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Queue_Exception",
                       Test_Queue_Exception'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Flash",
                       Test_Flash_Context'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Attribute",
                       Test_Get_Attribute'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Get_Bean",
                       Test_Get_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Helpers.Beans.Get_Bean",
                       Test_Get_Bean_Helper'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Faces.Mockup",
                       Test_Mockup_Faces_Context'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Messages.Factory.Add_Message",
                       Test_Add_Localized_Message'Access);
   end Add_Tests;

   --  ------------------------------
   --  Setup the faces context for the unit test.
   --  ------------------------------
   procedure Setup (T       : in out Test;
                    Context : in out Faces_Context) is
   begin
      T.Form          := new ASF.Applications.Tests.Form_Bean;
      Context.Set_ELContext (T.ELContext.all'Access);

      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("dumbledore"),
                                EL.Objects.To_Object (String '("albus")));

      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("potter"),
                                EL.Objects.To_Object (String '("harry")));
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("hogwarts"),
                                EL.Objects.To_Object (T.Form.all'Access,
                                                      EL.Objects.STATIC));
   end Setup;

   --  ------------------------------
   --  Cleanup the test instance.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (ASF.Applications.Tests.Form_Bean'Class,
                                        ASF.Applications.Tests.Form_Bean_Access);
   begin
      ASF.Tests.EL_Test (T).Tear_Down;
      Free (T.Form);
   end Tear_Down;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Get_Attribute (T : in out Test) is
      Ctx   : Faces_Context;
      Name  : EL.Objects.Object;
   begin
      T.Setup (Ctx);

      Name := Ctx.Get_Attribute ("dumbledore");
      T.Assert (not EL.Objects.Is_Null (Name), "Null attribute returned");
      Util.Tests.Assert_Equals (T, "albus", EL.Objects.To_String (Name), "Invalid attribute");

      Name := Ctx.Get_Attribute ("potter");
      T.Assert (not EL.Objects.Is_Null (Name), "Null attribute returned");
      Util.Tests.Assert_Equals (T, "harry", EL.Objects.To_String (Name), "Invalid attribute");

      Name := Ctx.Get_Attribute ("voldemort");
      T.Assert (EL.Objects.Is_Null (Name), "Oops... is there any horcrux left?");

   end Test_Get_Attribute;

   --  ------------------------------
   --  Test getting a bean object from the faces context.
   --  ------------------------------
   procedure Test_Get_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Ctx   : Faces_Context;
      Bean  : Util.Beans.Basic.Readonly_Bean_Access;
   begin
      T.Setup (Ctx);

      Bean := Ctx.Get_Bean ("dumbledore");
      T.Assert (Bean = null, "Dumbledore should not be a bean");

      Bean := Ctx.Get_Bean ("hogwarts");
      T.Assert (Bean /= null, "hogwarts should be a bean");
   end Test_Get_Bean;

   --  ------------------------------
   --  Test getting a bean object from the faces context and doing a conversion.
   --  ------------------------------
   procedure Test_Get_Bean_Helper (T : in out Test) is
      use type ASF.Applications.Tests.Form_Bean_Access;

      Ctx   : aliased Faces_Context;
      Bean  : ASF.Applications.Tests.Form_Bean_Access;
   begin
      T.Setup (Ctx);

      Bean := Get_Form_Bean ("hogwarts");
      T.Assert (Bean = null, "A bean was found while the faces context does not exist!");

      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, null);
      Bean := Get_Form_Bean ("hogwarts");
      T.Assert (Bean /= null, "hogwarts should be a bean");

      Bean := Get_Form_Bean ("dumbledore");
      T.Assert (Bean = null, "Dumbledore should not be a bean");

      ASF.Contexts.Faces.Restore (null);
   end Test_Get_Bean_Helper;

   --  ------------------------------
   --  Test the faces message queue.
   --  ------------------------------
   procedure Test_Add_Message (T : in out Test) is
      Ctx : Faces_Context;
   begin
      Ctx.Add_Message (Client_Id => "", Message => "msg1");
      Ctx.Add_Message (Client_Id => "", Message => "msg1");
      Ctx.Add_Message (Client_Id => "", Message => "msg2");
      Ctx.Add_Message (Client_Id => "", Message => "msg3");
      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => INFO);
      Ctx.Add_Message (Client_Id => "warn", Message => "msg3", Severity => WARN);
      Ctx.Add_Message (Client_Id => "error", Message => "msg3", Severity => ERROR);
      Ctx.Add_Message (Client_Id => "fatal", Message => "msg3", Severity => FATAL);
      T.Assert (Ctx.Get_Maximum_Severity = FATAL, "Add message failed");
   end Test_Add_Message;

   --  ------------------------------
   --  Test the application message factory for the creation of localized messages.
   --  ------------------------------
   procedure Test_Add_Localized_Message (T : in out Test) is
      App         : aliased Applications.Main.Application;
      App_Factory : Applications.Main.Application_Factory;
      Ctx         : aliased Faces_Context;
      Conf        : Applications.Config;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      App.Initialize (Conf, App_Factory);
      Set_Current (Ctx'Unchecked_Access, App'Unchecked_Access);
      ASF.Applications.Messages.Factory.Add_Message (Ctx, "asf.validators.length.maximum",
                                                     "23");
      --  ASF.Applications.Messages.Factory.Add_Message (Ctx, "asf.exceptions.unexpected.extended",
      --                                               "Fake-exception", "Fake-message");
      T.Assert (Ctx.Get_Maximum_Severity = ERROR, "Add message failed");
   end Test_Add_Localized_Message;

   procedure Test_Max_Severity (T : in out Test) is
      Ctx : Faces_Context;
   begin
      T.Assert (Ctx.Get_Maximum_Severity = NONE, "Invalid max severity with no message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => INFO);
      T.Assert (Ctx.Get_Maximum_Severity = INFO, "Invalid max severity with info message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => WARN);
      T.Assert (Ctx.Get_Maximum_Severity = WARN, "Invalid max severity with warn message");

      Ctx.Add_Message (Client_Id => "info", Message => "msg3", Severity => FATAL);
      T.Assert (Ctx.Get_Maximum_Severity = FATAL, "Invalid max severity with warn message");
   end Test_Max_Severity;

   procedure Test_Get_Messages (T : in out Test) is
      Ctx : Faces_Context;
   begin
      --  Iterator on an empty message list.
      declare
         Iter : constant Vectors.Cursor := Ctx.Get_Messages (Client_Id => "");
      begin
         T.Assert (not Vectors.Has_Element (Iter), "Iterator should indicate no message");
      end;

      Ctx.Add_Message (Client_Id => "info", Message => "msg1", Severity => INFO);
      declare
         Iter : constant Vectors.Cursor := Ctx.Get_Messages (Client_Id => "info");
         M    : Message;
      begin
         T.Assert (Vectors.Has_Element (Iter), "Iterator should indicate a message");

         M := Vectors.Element (Iter);
         Assert_Equals (T, "msg1", Get_Summary (M), "Invalid message");
         Assert_Equals (T, "msg1", Get_Detail (M), "Invalid details");
         T.Assert (INFO = Get_Severity (M), "Invalid severity");
      end;
   end Test_Get_Messages;

   --  ------------------------------
   --  Test adding some exception in the faces context.
   --  ------------------------------
   procedure Test_Queue_Exception (T : in out Test) is
      procedure Raise_Exception (Depth : in Natural;
                                 Excep : in Natural);
      procedure Check_Exception (Event   : in Events.Exceptions.Exception_Event'Class;
                                 Remove  : out Boolean;
                                 Context : in out Faces_Context'Class);

      Ctx : Faces_Context;
      Cnt : Natural := 0;

      procedure Raise_Exception (Depth : in Natural;
                                 Excep : in Natural) is
      begin
         if Depth > 0 then
            Raise_Exception (Depth - 1, Excep);
         end if;
         case Excep is
            when 1 =>
               raise Constraint_Error with "except code 1";

            when 2 =>
               raise Ada.IO_Exceptions.Name_Error;

            when others =>
               raise Program_Error with "Testing program error";
         end case;
      end Raise_Exception;

      procedure Check_Exception (Event   : in Events.Exceptions.Exception_Event'Class;
                                 Remove  : out Boolean;
                                 Context : in out Faces_Context'Class) is
         pragma Unreferenced (Context, Event);
      begin
         Cnt    := Cnt + 1;
         Remove := False;
      end Check_Exception;

   begin
      --  Create some exceptions and queue them.
      for I in 1 .. 3 loop
         begin
            Raise_Exception (3, I);
         exception
            when E : others =>
               Ctx.Queue_Exception (E);
         end;
      end loop;

      Ctx.Iterate_Exception (Check_Exception'Access);
      Util.Tests.Assert_Equals (T, 3, Cnt, "3 exception should have been queued");
   end Test_Queue_Exception;

   --  ------------------------------
   --  Test the flash instance.
   --  ------------------------------
   procedure Test_Flash_Context (T : in out Test) is
      use type ASF.Contexts.Faces.Flash_Context_Access;

      Ctx   : Faces_Context;
      Flash : aliased ASF.Contexts.Flash.Flash_Context;
   begin
      Ctx.Set_Flash (Flash'Unchecked_Access);

      T.Assert (Ctx.Get_Flash /= null, "Null flash context returned");
   end Test_Flash_Context;

   --  ------------------------------
   --  Test the mockup faces context.
   --  ------------------------------
   procedure Test_Mockup_Faces_Context (T : in out Test) is
      use type ASF.Requests.Request_Access;
      use type ASF.Responses.Response_Access;
      use type EL.Contexts.ELContext_Access;
   begin
      ASF.Applications.Tests.Initialize_Test_Application;
      declare
         Ctx   : Mockup.Mockup_Faces_Context;
      begin
         Ctx.Set_Method ("GET");
         Ctx.Set_Path_Info ("something.html");
         T.Assert (Current /= null, "There is no current faces context (mockup failed)");

         T.Assert (Current.Get_Request /= null, "There is no current request");
         T.Assert (Current.Get_Response /= null, "There is no current response");
         T.Assert (Current.Get_Application /= null, "There is no current application");
         T.Assert (Current.Get_ELContext /= null, "There is no current ELcontext");
      end;
      T.Assert (Current = null, "There is a current faces context but it shoudl be null");
   end Test_Mockup_Faces_Context;

end ASF.Contexts.Faces.Tests;

Add missing with clause for ASF.Applications.Main to fix GNAT 2017 compilation


-----------------------------------------------------------------------
--  asf-security -- ASF Security
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with EL.Functions;
package ASF.Security is

   --  EL function name exposed by Set_Functions.
   HAS_PERMISSION_FN  : constant String := "hasPermission";

   --  URI for the EL functions exposed by the security package (See Set_Functions).
   AUTH_NAMESPACE_URI : constant String := "http://code.google.com/p/ada-asf/auth";

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

end ASF.Security;

Package ASF.Security moved to Servlet.Security


-----------------------------------------------------------------------
--  atlas-server -- Application server
--  Copyright (C) 2011, 2012, 2013, 2016, 2017, 2018, 2019, 2020, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Util.Commands;

with AWS.Net.SSL;
with Servlet.Server.Web;

with AWA.Commands.Drivers;
with AWA.Commands.Start;
with AWA.Commands.Setup;
with AWA.Commands.Stop;
with AWA.Commands.List;
with AWA.Commands.Info;

with ADO.Drivers;
--  with ADO.Sqlite;
--  with ADO.Mysql;
--  with ADO.Postgresql;

with Atlas.Applications;
procedure Atlas.Server is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "atlas",
                               Container_Type => Servlet.Server.Web.AWS_Container);

   package List_Command is new AWA.Commands.List (Server_Commands);
   package Start_Command is new AWA.Commands.Start (Server_Commands);
   package Stop_Command is new AWA.Commands.Stop (Server_Commands);
   package Info_Command is new AWA.Commands.Info (Server_Commands);
   package Setup_Command is new AWA.Commands.Setup (Start_Command);

   Log       : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App       : constant Atlas.Applications.Application_Access
     := new Atlas.Applications.Application;
   WS        : Servlet.Server.Web.AWS_Container renames Server_Commands.WS;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
begin
   --  Initialize the database drivers (all of them or specific ones).
   ADO.Drivers.Initialize;
   --  ADO.Sqlite.Initialize;
   --  ADO.Mysql.Initialize;
   --  ADO.Postgresql.Initialize;
   WS.Register_Application (Atlas.Applications.CONTEXT_PATH, App.all'Access);

   if not AWS.Net.SSL.Is_Supported then
      Log.Error ("SSL is not supported by AWS.");
      Log.Error ("SSL is required for the OAuth2/OpenID connector to "
                 & "connect to OAuth2/OpenID providers.");
      Log.Error ("Please, rebuild AWS with SSL support.");
   end if;

   Log.Info ("Connect you browser to: http://localhost:8080{0}/index.html",
             Atlas.Applications.CONTEXT_PATH);
   Server_Commands.Run (Context, Arguments);

exception
   when E : others =>
      Context.Print (E);
end Atlas.Server;

-----------------------------------------------------------------------
--  atlas-server -- Application server
--  Copyright (C) 2011 - 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Util.Commands;

with AWA.Commands.Drivers;
with AWA.Commands.Start;
with AWA.Commands.Setup;
with AWA.Commands.Stop;
with AWA.Commands.List;
with AWA.Commands.Info;

with ADO.Sqlite;
--  with ADO.Mysql;
--  with ADO.Postgresql;

with Atlas.Applications;
with Atlas.Init;
procedure Atlas.Server is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "atlas",
                               Container_Type => Atlas.Init.Container_Type);

   package List_Command is new AWA.Commands.List (Server_Commands);
   package Start_Command is new AWA.Commands.Start (Server_Commands);
   package Stop_Command is new AWA.Commands.Stop (Server_Commands);
   package Info_Command is new AWA.Commands.Info (Server_Commands);
   package Setup_Command is new AWA.Commands.Setup (Start_Command);
   pragma Unreferenced (List_Command, Start_Command, Stop_Command, Info_Command, Setup_Command);

   Log       : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App       : constant Atlas.Applications.Application_Access
     := new Atlas.Applications.Application;
   WS        : Atlas.Init.Container_Type renames Server_Commands.WS;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
begin
   --  Initialize the database drivers (all of them or specific ones).
   --  ADO.Drivers.Initialize;
   ADO.Sqlite.Initialize;
   --  ADO.Mysql.Initialize;
   --  ADO.Postgresql.Initialize;

   WS.Register_Application (Atlas.Applications.CONTEXT_PATH, App.all'Access);

   Atlas.Init.Initialize (Log);

   Log.Info ("Connect you browser to: http://localhost:8080{0}/index.html",
             Atlas.Applications.CONTEXT_PATH);
   Server_Commands.Run (Context, Arguments);

exception
   when E : others =>
      Context.Print (E);
end Atlas.Server;

Update to be able to use EWS or AWS server according to build configuration


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   overriding
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   overriding
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Document the policy roles

Document the policy roles