-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 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 ELF;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Defs  : in MAT.Events.Attribute_Table;
                          Msg   : in out MAT.Readers.Message;
                          Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size  := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path  := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Event.Addr := Heap.Start_Addr;
      Event.Size := Heap.Size;
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
      Probe.Target.Process.Endian := MAT.Readers.Get_Endian (Msg);
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message;
                            Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
      Offset : MAT.Types.Target_Addr;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Event.Addr := Addr;
      Event.Size := 0;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

                  when M_TYPE =>
                     Kind := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               if Ada.Strings.Unbounded.Length (Path) = 0 then
                  Region.Path := Probe.Target.Process.Path;
                  Offset := 0;
               else
                  Region.Path := Path;
                  Offset := Region.Start_Addr;
               end if;
               Event.Size := Event.Size + Region.Size;
               Probe.Target.Process.Memory.Add_Region (Region);

               --  When auto-symbol loading is enabled, load the symbols associated with the
               --  shared libraries used by the program.
               if Probe.Target.Options.Load_Symbols then
                  begin
                     Probe.Target.Process.Symbols.Value.Load_Symbols (Region, Offset);
                  end;
               end if;
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.Targets.MSG_BEGIN then
         Probe.Probe_Begin (Params.all, Msg, Event);
      elsif Event.Index = MAT.Events.Targets.MSG_LIBRARY then
         Probe.Probe_Library (Params.all, Msg, Event);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.Targets.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.Targets.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.Targets.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 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 ELF;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Defs  : in MAT.Events.Attribute_Table;
                          Msg   : in out MAT.Readers.Message;
                          Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size  := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path  := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Event.Addr := Heap.Start_Addr;
      Event.Size := Heap.Size;
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
      Probe.Target.Process.Endian := MAT.Readers.Get_Endian (Msg);
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message;
                            Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
      Offset : MAT.Types.Target_Addr;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Event.Addr := Addr;
      Event.Size := 0;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

                  when M_TYPE =>
                     Kind := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               if Ada.Strings.Unbounded.Length (Path) = 0 then
                  Region.Path := Probe.Target.Process.Path;
                  Offset := 0;
               else
                  Region.Path := Path;
                  Offset := Region.Start_Addr;
               end if;
               Event.Size := Event.Size + Region.Size;
               Probe.Target.Process.Memory.Add_Region (Region);

               --  When auto-symbol loading is enabled, load the symbols associated with the
               --  shared libraries used by the program.
               if Probe.Target.Options.Load_Symbols then
                  begin
                     Probe.Target.Process.Symbols.Value.Load_Symbols (Region, Offset);
                  end;
               end if;
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.Targets.MSG_BEGIN then
         Probe.Probe_Begin (Params.all, Msg, Event);
      elsif Event.Index = MAT.Events.Targets.MSG_LIBRARY then
         Probe.Probe_Library (Params.all, Msg, Event);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in out MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.Targets.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.Targets.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.Targets.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

Change the Event parameter of Execute to an in out parameter


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

with Parameters;
with HelperText;
with Unix;
with File_Operations;
with Ada.Directories;
with Ada.Text_IO;

package body Ravenports is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package TIO renames Ada.Text_IO;
   package DIR renames Ada.Directories;

   --------------------------------------------------------------------------------------------
   --  check_version_available
   --------------------------------------------------------------------------------------------
   procedure check_version_available
   is
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc   : constant String := consdir & conspiracy_version;
   begin
      if DIR.Exists (version_loc) then
         if fetch_latest_version_info (temporary_ver_loc) then
            declare
               currentver : constant String := FOP.head_n1 (version_loc);
               latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
            begin
               if latestver = currentver then
                  TIO.Put_Line ("The latest version of Ravenports, " & latestver &
                                  ", is currently installed.");
               else
                  TIO.Put_Line ("A newer version of Ravenports is available: " & latestver);
                  TIO.Put_Line ("The " & currentver & " version is currently installed.");
               end if;
            end;
            DIR.Delete_File (temporary_ver_loc);
         end if;
      else
         TIO.Put_Line ("It appears that Ravenports has not been installed at " & consdir);
      end if;
   exception
      when others => null;
   end check_version_available;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_version_info
   --------------------------------------------------------------------------------------------
   function fetch_latest_version_info (tmp_location : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      cmd_output    : HT.Text;
      cmd           : constant String := fetch_program & " -q --no-verify-peer " &
                                         remote_version & " -o " & tmp_location;
      use type DIR.File_Kind;
   begin
      if not DIR.Exists ("/tmp") or else
        DIR.Kind ("/tmp") /= DIR.Directory
      then
         TIO.Put_Line ("The /tmp directory does not exist, bailing ...");
         return False;
      end if;
      if not DIR.Exists (fetch_program) then
         TIO.Put_Line ("It appears that the system root has not yet been installed at " & sysroot);
         TIO.Put_Line ("This must be rectified before Ravenports can be checked or fetched.");
         return False;
      end if;

      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_version_info;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_tarball
   --------------------------------------------------------------------------------------------
   function fetch_latest_tarball (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      tarball       : constant String := github_archive & "/" & latest_version & ".tar.gz";
      cmd_output    : HT.Text;
      cmd : constant String := fetch_program & " -q " & tarball & " -o /tmp";
   begin
      --  covered by previous existence checks of fetch_latest_version_info
      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_tarball;

   --------------------------------------------------------------------------------------------
   --  later_version_available
   --------------------------------------------------------------------------------------------
   function later_version_available (available : out Boolean) return String
   is
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc : constant String := consdir & conspiracy_version;
   begin
      available := True;
      --  We know consdir exists because we couldn't get here if it didn't.
      if fetch_latest_version_info (temporary_ver_loc) then
         declare
            latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
         begin
            DIR.Delete_File (temporary_ver_loc);
            if DIR.Exists (version_loc) then
               declare
                  currentver : constant String := FOP.head_n1 (version_loc);
               begin
                  if latestver = currentver then
                     available := False;
                  end if;
               end;
            end if;
            return latestver;
         end;
      else
         available := False;
         TIO.Put_Line ("Failed to fetch latest version information from Github");
         return "";
      end if;
   end later_version_available;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   procedure retrieve_latest_ravenports
   is
      available      : Boolean;
      latest_version : constant String := later_version_available (available);
   begin
      if not available then
         TIO.Put_Line ("Ravenports update skipped as no new version is available.");
         return;
      end if;

      clean_up (latest_version);
      if not fetch_latest_tarball (latest_version) then
         TIO.Put_Line ("Ravenports update skipped as tarball download failed.");
         return;
      end if;

      if relocate_existing_ravenports and then
        explode_tarball_into_conspiracy (latest_version)
      then
         clean_up (latest_version);
      end if;
   end retrieve_latest_ravenports;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   function relocate_existing_ravenports return Boolean
   is
      consdir : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
   begin
      DIR.Rename (Old_Name => consdir, New_Name => consdir_old);
      return True;
   exception
      when others =>
         return False;
   end relocate_existing_ravenports;

   --------------------------------------------------------------------------------------------
   --  explode_tarball_into_conspiracy
   --------------------------------------------------------------------------------------------
   function explode_tarball_into_conspiracy (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      mv_program    : constant String := sysroot & "/bin/mv ";
      tar_program   : constant String := sysroot & "/usr/bin/tar ";
      tarball       : constant String := "/tmp/" & latest_version & ".tar.gz";
      extract_dir   : constant String := "/tmp/Ravenports-" & latest_version;
      cmd_output    : HT.Text;
      command       : constant String := tar_program & "-C /tmp -xf " & tarball;
      command2      : constant String := mv_program & extract_dir & " " & consdir;
   begin
      if Unix.piped_mute_command (command, cmd_output) then
         return Unix.piped_mute_command (command2, cmd_output);
      else
         return False;
      end if;
   end explode_tarball_into_conspiracy;

   --------------------------------------------------------------------------------------------
   --  clean_up
   --------------------------------------------------------------------------------------------
   procedure clean_up (latest_version : String)
   is
      sysroot     : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
      extract_old : constant String := "/tmp/Ravenports-" & latest_version;
      command     : constant String := sysroot & "/bin/rm -rf " & consdir_old;
      command2    : constant String := sysroot & "/bin/rm -rf " & extract_old;
      tarball     : constant String := "/tmp/" & latest_version & ".tar.gz";
      cmd_output  : HT.Text;
      success     : Boolean;
   begin
      if DIR.Exists (consdir_old) then
         success := Unix.piped_mute_command (command, cmd_output);
      end if;
      if DIR.Exists (tarball) then
         DIR.Delete_File (tarball);
      end if;
      if DIR.Exists (extract_old) then
         success := Unix.piped_mute_command (command2, cmd_output);
      end if;
   exception
      when others => null;
   end clean_up;

end Ravenports;

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

with Parameters;
with HelperText;
with Unix;
with File_Operations;
with Ada.Directories;
with Ada.Text_IO;

package body Ravenports is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package TIO renames Ada.Text_IO;
   package DIR renames Ada.Directories;

   --------------------------------------------------------------------------------------------
   --  check_version_available
   --------------------------------------------------------------------------------------------
   procedure check_version_available
   is
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc   : constant String := consdir & conspiracy_version;
   begin
      if DIR.Exists (version_loc) then
         if fetch_latest_version_info (temporary_ver_loc) then
            declare
               currentver : constant String := FOP.head_n1 (version_loc);
               latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
            begin
               if latestver = currentver then
                  TIO.Put_Line ("The latest version of Ravenports, " & latestver &
                                  ", is currently installed.");
               else
                  TIO.Put_Line ("A newer version of Ravenports is available: " & latestver);
                  TIO.Put_Line ("The " & currentver & " version is currently installed.");
               end if;
            end;
            DIR.Delete_File (temporary_ver_loc);
         end if;
      else
         TIO.Put_Line ("It appears that Ravenports has not been installed at " & consdir);
      end if;
   exception
      when others => null;
   end check_version_available;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_version_info
   --------------------------------------------------------------------------------------------
   function fetch_latest_version_info (tmp_location : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      cmd_output    : HT.Text;
      cmd           : constant String := fetch_program & " -q --no-verify-peer " &
                                         remote_version & " -o " & tmp_location;
      use type DIR.File_Kind;
   begin
      if not DIR.Exists ("/tmp") or else
        DIR.Kind ("/tmp") /= DIR.Directory
      then
         TIO.Put_Line ("The /tmp directory does not exist, bailing ...");
         return False;
      end if;
      if not DIR.Exists (fetch_program) then
         TIO.Put_Line ("It appears that the system root has not yet been installed at " & sysroot);
         TIO.Put_Line ("This must be rectified before Ravenports can be checked or fetched.");
         return False;
      end if;

      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_version_info;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_tarball
   --------------------------------------------------------------------------------------------
   function fetch_latest_tarball (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      tarball       : constant String := github_archive & "/" & latest_version & ".tar.gz";
      cmd_output    : HT.Text;
      cmd : constant String := fetch_program & " -q " & tarball & " -o /tmp";
   begin
      --  covered by previous existence checks of fetch_latest_version_info
      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_tarball;

   --------------------------------------------------------------------------------------------
   --  later_version_available
   --------------------------------------------------------------------------------------------
   function later_version_available (available : out Boolean) return String
   is
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc : constant String := consdir & conspiracy_version;
   begin
      available := True;
      --  We know consdir exists because we couldn't get here if it didn't.
      if fetch_latest_version_info (temporary_ver_loc) then
         declare
            latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
         begin
            DIR.Delete_File (temporary_ver_loc);
            if DIR.Exists (version_loc) then
               declare
                  currentver : constant String := FOP.head_n1 (version_loc);
               begin
                  if latestver = currentver then
                     available := False;
                  end if;
               end;
            end if;
            return latestver;
         end;
      else
         available := False;
         TIO.Put_Line ("Failed to fetch latest version information from Github");
         return "";
      end if;
   end later_version_available;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   procedure retrieve_latest_ravenports
   is
      available      : Boolean;
      latest_version : constant String := later_version_available (available);
   begin
      if not available then
         TIO.Put_Line ("Ravenports update skipped as no new version is available.");
         return;
      end if;

      clean_up (latest_version);
      if not fetch_latest_tarball (latest_version) then
         TIO.Put_Line ("Ravenports update skipped as tarball download failed.");
         return;
      end if;

      if relocate_existing_ravenports and then
        explode_tarball_into_conspiracy (latest_version)
      then
         clean_up (latest_version);
         TIO.Put_Line ("Ravenports updated to version " & latest_version);
      end if;
   end retrieve_latest_ravenports;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   function relocate_existing_ravenports return Boolean
   is
      consdir : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
   begin
      DIR.Rename (Old_Name => consdir, New_Name => consdir_old);
      return True;
   exception
      when others =>
         return False;
   end relocate_existing_ravenports;

   --------------------------------------------------------------------------------------------
   --  explode_tarball_into_conspiracy
   --------------------------------------------------------------------------------------------
   function explode_tarball_into_conspiracy (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      mv_program    : constant String := sysroot & "/bin/mv ";
      tar_program   : constant String := sysroot & "/usr/bin/tar ";
      tarball       : constant String := "/tmp/" & latest_version & ".tar.gz";
      extract_dir   : constant String := "/tmp/Ravenports-" & latest_version;
      cmd_output    : HT.Text;
      command       : constant String := tar_program & "-C /tmp -xf " & tarball;
      command2      : constant String := mv_program & extract_dir & " " & consdir;
   begin
      if Unix.piped_mute_command (command, cmd_output) then
         return Unix.piped_mute_command (command2, cmd_output);
      else
         return False;
      end if;
   end explode_tarball_into_conspiracy;

   --------------------------------------------------------------------------------------------
   --  clean_up
   --------------------------------------------------------------------------------------------
   procedure clean_up (latest_version : String)
   is
      sysroot     : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
      extract_old : constant String := "/tmp/Ravenports-" & latest_version;
      command     : constant String := sysroot & "/bin/rm -rf " & consdir_old;
      command2    : constant String := sysroot & "/bin/rm -rf " & extract_old;
      tarball     : constant String := "/tmp/" & latest_version & ".tar.gz";
      cmd_output  : HT.Text;
      success     : Boolean;
   begin
      if DIR.Exists (consdir_old) then
         success := Unix.piped_mute_command (command, cmd_output);
      end if;
      if DIR.Exists (tarball) then
         DIR.Delete_File (tarball);
      end if;
      if DIR.Exists (extract_old) then
         success := Unix.piped_mute_command (command2, cmd_output);
      end if;
   exception
      when others => null;
   end clean_up;

end Ravenports;

Add positive feedback to success ravenports update

requested-by: dillon


-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  Copyright (C) 2016 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.
-----------------------------------------------------------------------

package body Wiki.Nodes is

   --  ------------------------------
   --  Create a text node.
   --  ------------------------------
   function Create_Text (Text : in WString) return Node_Type_Access is
   begin
      return new Node_Type '(Kind => N_TEXT,
                             Len  => Text'Length,
                             Text => Text,
                             others => <>);
   end Create_Text;

end Wiki.Nodes;

-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  Copyright (C) 2016 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.
-----------------------------------------------------------------------

package body Wiki.Nodes is

   --  ------------------------------
   --  Create a text node.
   --  ------------------------------
   function Create_Text (Text : in WString) return Node_Type_Access is
   begin
      return new Node_Type '(Kind => N_TEXT,
                             Len  => Text'Length,
                             Text => Text,
                             others => <>);
   end Create_Text;

   --  ------------------------------
   --  Append a node to the node list.
   --  ------------------------------
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access) is
      Block : Node_List_Block_Access := Into.Current;
   begin
      if Block.Last = Block.Max then
         Block.Next := new Node_List_Block (Into.Length);
         Block := Block.Next;
         Into.Current := Block;
      end if;
      Block.Last := Block.Last + 1;
      Block.List (Block.Last) := Node;
      Into.Length := Into.Length + 1;
   end Append;

end Wiki.Nodes;

Implement the Append procedure

Implement the Append procedure


-----------------------------------------------------------------------
--  wiki-utils -- Wiki utility operations
--  Copyright (C) 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 Wiki.Render.Text;
with Wiki.Render.Html;
with Wiki.Filters.Html;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
package body Wiki.Utils is

   --  ------------------------------
   --  Render the wiki text according to the wiki syntax in HTML into a string.
   --  ------------------------------
   function To_Html (Text   : in Wide_Wide_String;
                     Syntax : in Wiki.Parsers.Wiki_Syntax_Type) return String is
      Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Builder_Stream;
      Renderer : aliased Wiki.Render.Html.Html_Renderer;
      Filter   : aliased Wiki.Filters.Html.Html_Filter_Type;
      Engine   : Wiki.Parsers.Parser;
   begin
      Renderer.Set_Output_Stream (Stream'Unchecked_Access);
      Engine.Add_Filter (Filter'Unchecked_Access);
      Engine.Set_Syntax (Syntax);
      Engine.Parse (Text, Renderer'Unchecked_Access);
      return Stream.To_String;
   end To_Html;

   --  ------------------------------
   --  Render the wiki text according to the wiki syntax in text into a string.
   --  Wiki formatting and decoration are removed.
   --  ------------------------------
   function To_Text (Text   : in Wide_Wide_String;
                     Syntax : in Wiki.Parsers.Wiki_Syntax_Type) return String is
      Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
      Renderer : aliased Wiki.Render.Text.Text_Renderer;
      Engine   : Wiki.Parsers.Parser;
   begin
      Renderer.Set_Output_Stream (Stream'Unchecked_Access);
      Engine.Set_Syntax (Syntax);
      Engine.Parse (Text, Renderer'Unchecked_Access);
      return Stream.To_String;
   end To_Text;

end Wiki.Utils;

-----------------------------------------------------------------------
--  wiki-utils -- Wiki utility operations
--  Copyright (C) 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 Wiki.Render.Text;
with Wiki.Render.Html;
with Wiki.Filters.Html;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
with Wiki.Nodes;
package body Wiki.Utils is

   --  ------------------------------
   --  Render the wiki text according to the wiki syntax in HTML into a string.
   --  ------------------------------
   function To_Html (Text   : in Wide_Wide_String;
                     Syntax : in Wiki.Parsers.Wiki_Syntax_Type) return String is
      Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Builder_Stream;
      Renderer : aliased Wiki.Render.Html.Html_Renderer;
      Doc      : Wiki.Nodes.Document;
      Filter   : aliased Wiki.Filters.Html.Html_Filter_Type;
      Engine   : Wiki.Parsers.Parser;
   begin
      Renderer.Set_Output_Stream (Stream'Unchecked_Access);
      Engine.Add_Filter (Filter'Unchecked_Access);
      Engine.Set_Syntax (Syntax);
      Engine.Parse (Text, Doc);
      Renderer.Render (Doc);
      return Stream.To_String;
   end To_Html;

   --  ------------------------------
   --  Render the wiki text according to the wiki syntax in text into a string.
   --  Wiki formatting and decoration are removed.
   --  ------------------------------
   function To_Text (Text   : in Wide_Wide_String;
                     Syntax : in Wiki.Parsers.Wiki_Syntax_Type) return String is
      Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
      Doc      : Wiki.Nodes.Document;
      Renderer : aliased Wiki.Render.Text.Text_Renderer;
      Engine   : Wiki.Parsers.Parser;
   begin
      Renderer.Set_Output_Stream (Stream'Unchecked_Access);
      Engine.Set_Syntax (Syntax);
      Engine.Parse (Text, Doc);
      Renderer.Render (Doc);
      return Stream.To_String;
   end To_Text;

end Wiki.Utils;

Update the To_Html and To_Text to parse into a document and render the result


-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011 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.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with EL.Contexts;

package ASF.Beans.Mappers is

   type Managed_Bean_Fields is (FIELD_NAME,
                                FIELD_CLASS,
                                FIELD_SCOPE,
                                FIELD_MANAGED_BEAN,
                                FIELD_PROPERTY,
                                FIELD_PROPERTY_NAME,
                                FIELD_PROPERTY_VALUE,
                                FIELD_PROPERTY_CLASS);

   type Bean_Factory_Access is access all ASF.Beans.Bean_Factory;

   type Managed_Bean is record
      Name         : Util.Beans.Objects.Object;
      Class        : Util.Beans.Objects.Object;
      Scope        : Scope_Type := REQUEST_SCOPE;
      Factory      : Bean_Factory_Access  := null;
      Params       : ASF.Beans.Parameter_Bean_Ref.Ref;
      Prop_Name    : Util.Beans.Objects.Object;
      Prop_Value   : Util.Beans.Objects.Object;
      Context      : EL.Contexts.ELContext_Access := null;
   end record;
   type Managed_Bean_Access is access all Managed_Bean;

   --  Set the field identified by Field with the Value.
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the managed bean definitions.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Factory : in Bean_Factory_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Managed_Bean;
   end Reader_Config;

private

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Managed_Bean,
                                               Element_Type_Access => Managed_Bean_Access,
                                               Fields              => Managed_Bean_Fields,
                                               Set_Member          => Set_Member);

end ASF.Beans.Mappers;

-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011 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.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with EL.Contexts;

package ASF.Beans.Mappers is

   type Managed_Bean_Fields is (FIELD_NAME,
                                FIELD_CLASS,
                                FIELD_SCOPE,
                                FIELD_MANAGED_BEAN,
                                FIELD_PROPERTY,
                                FIELD_PROPERTY_NAME,
                                FIELD_PROPERTY_VALUE,
                                FIELD_PROPERTY_CLASS);

   type Bean_Factory_Access is access all ASF.Beans.Bean_Factory;

   type Managed_Bean is limited record
      Name         : Util.Beans.Objects.Object;
      Class        : Util.Beans.Objects.Object;
      Scope        : Scope_Type := REQUEST_SCOPE;
      Factory      : Bean_Factory_Access  := null;
      Params       : ASF.Beans.Parameter_Bean_Ref.Ref;
      Prop_Name    : Util.Beans.Objects.Object;
      Prop_Value   : Util.Beans.Objects.Object;
      Context      : EL.Contexts.ELContext_Access := null;
   end record;
   type Managed_Bean_Access is access all Managed_Bean;

   --  Set the field identified by Field with the Value.
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the managed bean definitions.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Factory : in Bean_Factory_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Managed_Bean;
   end Reader_Config;

private

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Managed_Bean,
                                               Element_Type_Access => Managed_Bean_Access,
                                               Fields              => Managed_Bean_Fields,
                                               Set_Member          => Set_Member);

end ASF.Beans.Mappers;

Use a limited record for Managed_Bean since we don't need to copy these objects and this reduces the code size


-----------------------------------------------------------------------
--  EL.Methods.Proc_1 -- Procedure Binding with 1 argument
--  Copyright (C) 2010, 2011, 2012, 2013 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.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
package EL.Methods.Proc_1 is

   use Util.Beans.Methods;

   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in out Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   procedure Execute (Method  : in EL.Expressions.Method_Expression'Class;
                      Param   : in out Param1_Type;
                      Context : in EL.Contexts.ELContext'Class);

   --  Execute the method describe by the method binding object.
   --  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in out Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   procedure Execute (Method  : in EL.Expressions.Method_Info;
                      Param   : in out Param1_Type);

   --  Function access to the proxy.
   type Proxy_Access is
      access procedure (O : access Util.Beans.Basic.Readonly_Bean'Class;
                        P : in out Param1_Type);

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is abstract new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with procedure Method (O  : in out Bean;
                             P1 : in out Param1_Type);
   package Bind is

      --  Method that Execute will invoke.
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in out Param1_Type);

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Proc_1;

-----------------------------------------------------------------------
--  EL.Methods.Proc_1 -- Procedure Binding with 1 argument
--  Copyright (C) 2010, 2011, 2012, 2013, 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 EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
package EL.Methods.Proc_1 is

   use Util.Beans.Methods;

   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in out Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   procedure Execute (Method  : in EL.Expressions.Method_Expression'Class;
                      Param   : in out Param1_Type;
                      Context : in EL.Contexts.ELContext'Class);

   --  Execute the method describe by the method binding object.
   --  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in out Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   procedure Execute (Method  : in EL.Expressions.Method_Info;
                      Param   : in out Param1_Type);

   --  Function access to the proxy.
   type Proxy_Access is
      access procedure (O : access Util.Beans.Basic.Readonly_Bean'Class;
                        P : in out Param1_Type);

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is abstract limited new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with procedure Method (O  : in out Bean;
                             P1 : in out Param1_Type);
   package Bind is

      --  Method that Execute will invoke.
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in out Param1_Type);

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Proc_1;

Update the Bind generic package to use a limited type for the Bean type


-----------------------------------------------------------------------
--  security-policies -- Security 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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Positive'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  Get the security controller associated with the permission index <b>Index</b>.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
--        package Role_Config is
--          new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
--        pragma Warnings (Off, Role_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
   begin
      null;
   end Finalize;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security 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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Positive'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  Get the security controller associated with the permission index <b>Index</b>.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
--        package Role_Config is
--          new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
--        pragma Warnings (Off, Role_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Set_Reader_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
   begin
      null;
   end Finalize;

end Security.Policies;

Configure the XML reader for each policy that was registered in the policy manager


-----------------------------------------------------------------------
--  wiki-filters-collectors -- Wiki word and link collectors
--  Copyright (C) 2016 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.
-----------------------------------------------------------------------

package body Wiki.Filters.Collectors is

   procedure Add_String (Into : in out WString_Maps.Map;
                         Item : in Wiki.Strings.WString) is

      procedure Increment (Key : in Wiki.Strings.WString;
                           Value : in out Natural) is
         pragma Unreferenced (Key);
      begin
         Value := Value + 1;
      end Increment;

      Pos : constant WString_Maps.Cursor := Into.Find (Item);
   begin
      if WString_Maps.Has_Element (Pos) then
         Into.Update_Element (Pos, Increment'Access);
      else
         Into.Insert (Item, 1);
      end if;
   end Add_String;

   function Find (Map  : in Collector_Type;
                  Item : in Wiki.Strings.WString) return Cursor is
   begin
      return Map.Items.Find (Item);
   end Find;

   function Contains (Map  : in Collector_Type;
                      Item : in Wiki.Strings.WString) return Boolean is
   begin
      return Map.Items.Contains (Item);
   end Contains;

   procedure Iterate (Map : in Collector_Type;
                      Process : not null access procedure (Pos : in Cursor)) is
   begin
      Map.Items.Iterate (Process);
   end Iterate;

   --  ------------------------------
   --  Word Collector type
   --  ------------------------------
   procedure Collect_Words (Filter  : in out Word_Collector_Type;
                            Content : in Wiki.Strings.WString) is
      Pos   : Natural := Content'First;
      Start : Natural := Content'First;
      C     : Wiki.Strings.WChar;
   begin
      while Pos <= Content'Last loop
         C := Content (Pos);
         if Wiki.Strings.Is_Alphanumeric (C) then
            null;
         else
            if Start + 1 < Pos - 1 then
               Add_String (Filter.Items, Content (Start .. Pos - 1));
            end if;
            Start := Pos + 1;
         end if;
         Pos := Pos + 1;
      end loop;
      if Start < Content'Last then
         Add_String (Filter.Items, Content (Start .. Content'Last));
      end if;
   end Collect_Words;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Word_Collector_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      Filter.Collect_Words (Text);
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Word_Collector_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Collect_Words (Header);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   procedure Add_Link (Filter     : in out Word_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Link (Document, Name, Attributes);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   procedure Add_Image (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Image (Document, Name, Attributes);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   procedure Add_Quote (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Quote (Document, Name, Attributes);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   procedure Add_Preformatted (Filter   : in out Word_Collector_Type;
                               Document : in out Wiki.Documents.Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString) is
   begin
      Filter.Collect_Words (Text);
      Filter_Type (Filter).Add_Preformatted (Document, Text, Format);
   end Add_Preformatted;

   procedure Collect_Link (Filter     : in out Link_Collector_Type;
                           Attributes : in Wiki.Attributes.Attribute_List;
                           Name       : in String) is
      Href : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attributes, Name);
   begin
      if Href'Length > 0 then
         Add_String (Filter.Items, Href);
      end if;
   end Collect_Link;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Link_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Collect_Link (Filter, Attributes, "href");
      Filter_Type (Filter).Add_Link (Document, Name, Attributes);
   end Add_Link;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Link_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Tag = A_TAG then
         Collect_Link (Filter, Attributes, "href");
      end if;
      Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
   end Push_Node;

end Wiki.Filters.Collectors;

-----------------------------------------------------------------------
--  wiki-filters-collectors -- Wiki word and link collectors
--  Copyright (C) 2016 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.
-----------------------------------------------------------------------

package body Wiki.Filters.Collectors is

   procedure Add_String (Into : in out WString_Maps.Map;
                         Item : in Wiki.Strings.WString);

   procedure Add_String (Into : in out WString_Maps.Map;
                         Item : in Wiki.Strings.WString) is

      procedure Increment (Key : in Wiki.Strings.WString;
                           Value : in out Natural);

      procedure Increment (Key : in Wiki.Strings.WString;
                           Value : in out Natural) is
         pragma Unreferenced (Key);
      begin
         Value := Value + 1;
      end Increment;

      Pos : constant WString_Maps.Cursor := Into.Find (Item);
   begin
      if WString_Maps.Has_Element (Pos) then
         Into.Update_Element (Pos, Increment'Access);
      else
         Into.Insert (Item, 1);
      end if;
   end Add_String;

   function Find (Map  : in Collector_Type;
                  Item : in Wiki.Strings.WString) return Cursor is
   begin
      return Map.Items.Find (Item);
   end Find;

   function Contains (Map  : in Collector_Type;
                      Item : in Wiki.Strings.WString) return Boolean is
   begin
      return Map.Items.Contains (Item);
   end Contains;

   procedure Iterate (Map : in Collector_Type;
                      Process : not null access procedure (Pos : in Cursor)) is
   begin
      Map.Items.Iterate (Process);
   end Iterate;

   --  ------------------------------
   --  Word Collector type
   --  ------------------------------
   procedure Collect_Words (Filter  : in out Word_Collector_Type;
                            Content : in Wiki.Strings.WString) is
      Pos   : Natural := Content'First;
      Start : Natural := Content'First;
      C     : Wiki.Strings.WChar;
   begin
      while Pos <= Content'Last loop
         C := Content (Pos);
         if Wiki.Strings.Is_Alphanumeric (C) then
            null;
         else
            if Start + 1 < Pos - 1 then
               Add_String (Filter.Items, Content (Start .. Pos - 1));
            end if;
            Start := Pos + 1;
         end if;
         Pos := Pos + 1;
      end loop;
      if Start < Content'Last then
         Add_String (Filter.Items, Content (Start .. Content'Last));
      end if;
   end Collect_Words;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Word_Collector_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      Filter.Collect_Words (Text);
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Word_Collector_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Collect_Words (Header);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   procedure Add_Link (Filter     : in out Word_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Link (Document, Name, Attributes);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   procedure Add_Image (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Image (Document, Name, Attributes);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   procedure Add_Quote (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Filter_Type (Filter).Add_Quote (Document, Name, Attributes);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   procedure Add_Preformatted (Filter   : in out Word_Collector_Type;
                               Document : in out Wiki.Documents.Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString) is
   begin
      Filter.Collect_Words (Text);
      Filter_Type (Filter).Add_Preformatted (Document, Text, Format);
   end Add_Preformatted;

   procedure Collect_Link (Filter     : in out Link_Collector_Type;
                           Attributes : in Wiki.Attributes.Attribute_List;
                           Name       : in String) is
      Href : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attributes, Name);
   begin
      if Href'Length > 0 then
         Add_String (Filter.Items, Href);
      end if;
   end Collect_Link;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Link_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Collect_Link (Filter, Attributes, "href");
      Filter_Type (Filter).Add_Link (Document, Name, Attributes);
   end Add_Link;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Link_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Tag = A_TAG then
         Collect_Link (Filter, Attributes, "href");
      end if;
      Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
   end Push_Node;

end Wiki.Filters.Collectors;

Declare Add_String and Increment procedures