-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Targets.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Prev_Event  : MAT.Events.Targets.Probe_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Targets.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.Start_Id := Event.Id;
            Info.Start_Time := Event.Time;
         end if;
         Info.End_Id := Event.Id;
         Info.End_Time := Event.Time;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.Start_Id   := First_Event.Id;
      Info.Start_Time := First_Event.Time;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Id    : MAT.Events.Targets.Event_Id_Type;
      Last_Id     : MAT.Events.Targets.Event_Id_Type;
      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.Targets.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Targets.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.Targets.MSG_MALLOC
             and Event.Index /= MAT.Events.Targets.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Targets.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Targets.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Targets.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               declare
                  Pos : constant MAT.Events.Targets.Frame_Event_Info_Cursor
                    := Frames.Find (Backtrace (I));
               begin
                  if MAT.Events.Targets.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Count := 1;
                        Frames.Insert (Backtrace (I), Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Targets.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Prev_Event  : MAT.Events.Targets.Probe_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Targets.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.Start_Id := Event.Id;
            Info.Start_Time := Event.Time;
         end if;
         Info.End_Id := Event.Id;
         Info.End_Time := Event.Time;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.Start_Id   := First_Event.Id;
      Info.Start_Time := First_Event.Time;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Id    : MAT.Events.Targets.Event_Id_Type;
      Last_Id     : MAT.Events.Targets.Event_Id_Type;
      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.Targets.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Targets.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.Targets.MSG_MALLOC
             and Event.Index /= MAT.Events.Targets.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Targets.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Targets.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Targets.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               declare
                  Pos : constant MAT.Events.Targets.Frame_Event_Info_Cursor
                    := Frames.Find (Backtrace (I));
               begin
                  if MAT.Events.Targets.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Frame_Addr := Backtrace (I);
                        Info.Count := 1;
                        Frames.Insert (Backtrace (I), Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

Store the frame address in the event info object


-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;

with Bfd.Symbols;
with Bfd.Files;

with Util.Refs;

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

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

   package Library_Symbols_Refs is
     new Util.Refs.References (Library_Symbols, Library_Symbols_Access);

   subtype Library_Symbols_Ref is Library_Symbols_Refs.Ref;

   --  The <tt>Symbols_Maps</tt> keeps a sorted list of symbol tables indexed
   --  by their mapping address.
   use type Library_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 => Library_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
      File      : Bfd.Files.File_Type;
      Symbols   : Bfd.Symbols.Symbol_Table;
      Libraries : Symbols_Maps.Map;
   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);

   --  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;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   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 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 Util.Refs;

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

   --  The <tt>Library_Symbols</tt> holds the symbol table associated with
   --  a shared library loaded by the program.  The <tt>Text_Addr</tt> indicates
   --  the text segment address of the loaded library.
   type Library_Symbols is new Util.Refs.Ref_Entity with record
      Start_Addr : MAT.Types.Target_Addr;
      End_Addr   : MAT.Types.Target_Addr;
      File       : Bfd.Files.File_Type;
      Symbols    : Bfd.Symbols.Symbol_Table;
   end record;
   type Library_Symbols_Access is access all Library_Symbols;

   package Library_Symbols_Refs is
     new Util.Refs.References (Library_Symbols, Library_Symbols_Access);

   subtype Library_Symbols_Ref is Library_Symbols_Refs.Ref;

   --  The <tt>Symbols_Maps</tt> keeps a sorted list of symbol tables indexed
   --  by their mapping address.
   use type Library_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 => Library_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
      File      : Bfd.Files.File_Type;
      Symbols   : Bfd.Symbols.Symbol_Table;
      Libraries : Symbols_Maps.Map;
   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);

   --  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;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   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 the end address to the library symbol object


-----------------------------------------------------------------------
--  wiki-helpers-parser -- Generic procedure for the wiki parser
--  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.
-----------------------------------------------------------------------
with Wiki.Helpers;
with Wiki.Streams;
procedure Wiki.Helpers.Parser (Engine  : in out Engine_Type;
                               Content : in Element_Type;
                               Doc     : in out Wiki.Documents.Document) is

   use type Wiki.Streams.Input_Stream_Access;

   type Wide_Input is new Wiki.Streams.Input_Stream with record
      Pos : Positive;
      Len : Natural;
   end record;

   overriding
   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean);

   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean) is
   begin
      if Buf.Pos > Buf.Len then
         Is_Eof := True;
         Token := Wiki.Helpers.CR;
      else
         Token := Element (Content, Buf.Pos);
         Buf.Pos := Buf.Pos + 1;
         Is_Eof := False;
      end if;
   end Read;

   Buffer : aliased Wide_Input;
begin
   Buffer.Pos   := 1;
   Buffer.Len   := Length (Content);
   Parse (Engine, Buffer'Unchecked_Access, Doc);
end Wiki.Helpers.Parser;

-----------------------------------------------------------------------
--  wiki-helpers-parser -- Generic procedure for the wiki parser
--  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.
-----------------------------------------------------------------------
with Wiki.Helpers;
with Wiki.Streams;
procedure Wiki.Helpers.Parser (Engine  : in out Engine_Type;
                               Content : in Element_Type;
                               Doc     : in out Wiki.Documents.Document) is

   use type Wiki.Streams.Input_Stream_Access;

   type Wide_Input is new Wiki.Streams.Input_Stream with record
      Pos : Positive;
      Len : Natural;
   end record;

   overriding
   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean);

   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean) is
   begin
      if Buf.Pos <= Buf.Len then
         Element (Content, Buf.Pos, Token);
         Is_Eof := False;
      else
         Is_Eof := True;
         Token := Wiki.Helpers.CR;
      end if;
   end Read;

   Buffer : aliased Wide_Input;
begin
   Buffer.Pos   := 1;
   Buffer.Len   := Length (Content);
   Parse (Engine, Buffer'Unchecked_Access, Doc);
end Wiki.Helpers.Parser;

Change the Element function into a procedure that also takes care of updating the position


-----------------------------------------------------------------------
--  druss-commands-bboxes -- Commands to manage the bboxes
--  Copyright (C) 2017, 2018 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 Druss.Commands.Bboxes is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Discover (Command   : in Command_Type;
                       Context   : in out Context_Type);

   --  Add the bbox with the given IP address.
   procedure Add_Bbox (Command : in Command_Type;
                       IP      : in String;
                       Context : in out Context_Type);

   --  Enable or disable the bbox management by Druss.
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Util.Commands.Argument_List'Class;
                        Context   : in out Context_Type);

   --  Set the password to be used by the Bbox API to connect to the box.
   procedure Do_Password (Command   : in Command_Type;
                          Args      : in Util.Commands.Argument_List'Class;
                          Context   : in out Context_Type);

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Druss.Commands.Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Bboxes;

-----------------------------------------------------------------------
--  druss-commands-bboxes -- Commands to manage the bboxes
--  Copyright (C) 2017, 2018, 2019 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 Druss.Commands.Bboxes is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Discover (Command   : in Command_Type;
                       Context   : in out Context_Type);

   --  Add the bbox with the given IP address.
   procedure Add_Bbox (Command : in Command_Type;
                       IP      : in String;
                       Context : in out Context_Type);

   --  Enable or disable the bbox management by Druss.
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Util.Commands.Argument_List'Class;
                        Context   : in out Context_Type);

   --  Set the password to be used by the Bbox API to connect to the box.
   procedure Do_Password (Command   : in Command_Type;
                          Args      : in Util.Commands.Argument_List'Class;
                          Context   : in out Context_Type);

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Druss.Commands.Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Bboxes;

Change Help command to accept in out command


-----------------------------------------------------------------------
--  awa-services-filters -- Setup service context in request processing flow
--  Copyright (C) 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 AWA.Services.Contexts;
with AWA.Applications;
with AWA.Users.Principals;

with ASF.Principals;

package body AWA.Services.Filters is

   --  ------------------------------
   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The Filter_Chain passed in to this
   --  method allows the Filter to pass on the request and response to the next
   --  entity in the chain.
   --
   --  Before passing the control to the next filter, initialize the service
   --  context to give access to the current application, current user and
   --  manage possible transaction rollbacks.
   --  ------------------------------
   procedure Do_Filter (F        : in Service_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is

      pragma Unreferenced (F);

      use type ASF.Principals.Principal_Access;

      App : constant ASF.Servlets.Servlet_Registry_Access := ASF.Servlets.Get_Servlet_Context (Chain);
      P   : constant ASF.Principals.Principal_Access := Request.Get_User_Principal;
      Context     : aliased AWA.Services.Contexts.Service_Context;
      Principal   : AWA.Users.Principals.Principal_Access;
      Application : AWA.Applications.Application_Access;
   begin
      --  Get the user
      if P /= null and then P.all in AWA.Users.Principals.Principal'Class then
         Principal := AWA.Users.Principals.Principal'Class (P.all)'Access;
      else
         Principal := null;
      end if;

      --  Get the application
      if App.all in AWA.Applications.Application'Class then
         Application := AWA.Applications.Application'Class (App.all)'Access;
      else
         Application := null;
      end if;

      --  Setup the service context.
      Context.Set_Context (Application, Principal);

      --  Give the control to the next chain up to the servlet.
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);

      --  By leaving this scope, the active database transactions are rollbacked
      --  (finalization of Service_Context)
   end Do_Filter;

end AWA.Services.Filters;

Fix compilation warnings

Fix compilation warnings


with Test;
with OpenAL.Context;
with OpenAL.Context.Error;

procedure init_002 is
  package ALC       renames OpenAL.Context;
  package ALC_Error renames OpenAL.Context.Error;

  Device  : ALC.Device_t;
  Context : ALC.Context_t;
  OK      : Boolean;

  use type ALC.Device_t;
  use type ALC.Context_t;
  use type ALC_Error.Error_t;
begin
  Test.Initialize ("init_002");

  Device := ALC.Open_Default_Device;
  Test.Check_Test (12, "device opened", Device /= ALC.Invalid_Device);
  Test.Check_Test (13, "no device error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  Context := ALC.Create_Context (Device);
  Test.Check_Test (14, "context created", Context /= ALC.Invalid_Context);
  Test.Check_Test (15, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  OK := ALC.Make_Context_Current (Context);
  Test.Check_Test (16, "context made current", OK);
  Test.Check_Test (17, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  OK := ALC.Make_Context_Current (ALC.Null_Context);
  Test.Check_Test (18, "no context made current", OK);
  Test.Check_Test (19, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  OK := ALC.Close_Device (Device);
  Test.Check_Test (20, "device failed to close", OK = False);
  Test.Check_Test (21, "device error", ALC_Error.Get_Error (Device) /= ALC_Error.No_Error);

  Test.Finish;
end init_002;

with Test;
with OpenAL.Context;
with OpenAL.Context.Error;

procedure init_002 is
  package ALC       renames OpenAL.Context;
  package ALC_Error renames OpenAL.Context.Error;

  Device  : ALC.Device_t;
  Context : ALC.Context_t;
  OK      : Boolean;

  use type ALC.Device_t;
  use type ALC.Context_t;
  use type ALC_Error.Error_t;
begin
  Test.Initialize ("init_002");

  Device := ALC.Open_Default_Device;
  Test.Check_Test (12, "device opened", Device /= ALC.Invalid_Device);
  Test.Check_Test (13, "no device error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  Context := ALC.Create_Context (Device);
  Test.Check_Test (14, "context created", Context /= ALC.Invalid_Context);
  Test.Check_Test (15, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  OK := ALC.Make_Context_Current (Context);
  Test.Check_Test (16, "context made current", OK);
  Test.Check_Test (17, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  OK := ALC.Make_Context_Current (ALC.Null_Context);
  Test.Check_Test (18, "no context made current", OK);
  Test.Check_Test (19, "no context error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  --
  -- According to the 1.1 spec, this should return False.
  -- Unfortunately, no implementation actually does that...
  --

  OK := ALC.Close_Device (Device);
  Test.Check_Test (20, "device closed", OK);
  Test.Check_Test (21, "device error", ALC_Error.Get_Error (Device) = ALC_Error.No_Error);

  Test.Finish;
end init_002;

Adjust init_002

Adjust init_002


-----------------------------------------------------------------------
--  babel-base -- Database for files
--  Copyright (C) 2014 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.Dates.ISO8601;
with Babel.Files.Sets;
with Babel.Files.Lifecycles;
with Ada.Text_IO;
package body Babel.Base.Text is

   --  ------------------------------
   --  Insert the file in the database.
   --  ------------------------------
   overriding
   procedure Insert (Into : in out Text_Database;
                     File : in Babel.Files.File_Type) is
   begin
      Into.Files.Insert (File);
   end Insert;

   --  ------------------------------
   --  Write the SHA1 checksum for the files stored in the map.
   --  ------------------------------
   procedure Save (Database : in Text_Database;
                   Path     : in String) is
      Checksum : Ada.Text_IO.File_Type;

      procedure Write_Checksum (Position : in Babel.Files.Sets.File_Cursor) is
         File : constant Babel.Files.File_Type := Babel.Files.Sets.File_Sets.Element (Position);
         SHA1 : constant String := Babel.Files.Get_SHA1 (File);
         Path : constant String := Babel.Files.Get_Path (File);
      begin
         Ada.Text_IO.Put (Checksum, SHA1);
         Ada.Text_IO.Put (Checksum, Babel.Files.Uid_Type'Image (Babel.Files.Get_User (File)));
         Ada.Text_IO.Put (Checksum, Babel.Files.Gid_Type'Image (Babel.Files.Get_Group (File)));
         Ada.Text_IO.Put (Checksum, " ");
         Ada.Text_IO.Put (Checksum, Util.Dates.ISO8601.Image (Babel.Files.Get_Date (File)));
         Ada.Text_IO.Put (Checksum, Babel.Files.File_Size'Image (Babel.Files.Get_Size (File)));
         Ada.Text_IO.Put (Checksum, " ");
         Ada.Text_IO.Put (Checksum, Path);
         Ada.Text_IO.New_Line (Checksum);
      end Write_Checksum;

   begin
      Ada.Text_IO.Create (File => Checksum, Name => Path);
      Database.Files.Iterate (Write_Checksum'Access);
      Ada.Text_IO.Close (File => Checksum);
   end Save;

end Babel.Base.Text;

-----------------------------------------------------------------------
--  babel-base -- Database for files
--  Copyright (C) 2014 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.Dates.ISO8601;
with Babel.Files.Sets;
with Babel.Files.Lifecycles;
with Ada.Text_IO;
package body Babel.Base.Text is

   --  ------------------------------
   --  Insert the file in the database.
   --  ------------------------------
   overriding
   procedure Insert (Into : in out Text_Database;
                     File : in Babel.Files.File_Type) is
   begin
      Into.Files.Insert (File);
   end Insert;

   --  ------------------------------
   --  Write the SHA1 checksum for the files stored in the map.
   --  ------------------------------
   procedure Save (Database : in Text_Database;
                   Path     : in String) is
      Checksum : Ada.Text_IO.File_Type;

      procedure Write_Checksum (Position : in Babel.Files.Sets.File_Cursor) is
         File : constant Babel.Files.File_Type := Babel.Files.Sets.File_Sets.Element (Position);
         SHA1 : constant String := Babel.Files.Get_SHA1 (File);
         Path : constant String := Babel.Files.Get_Path (File);
      begin
         Ada.Text_IO.Put (Checksum, SHA1);
         Ada.Text_IO.Put (Checksum, Babel.Uid_Type'Image (Babel.Files.Get_User (File)));
         Ada.Text_IO.Put (Checksum, Babel.Gid_Type'Image (Babel.Files.Get_Group (File)));
         Ada.Text_IO.Put (Checksum, " ");
         Ada.Text_IO.Put (Checksum, Util.Dates.ISO8601.Image (Babel.Files.Get_Date (File)));
         Ada.Text_IO.Put (Checksum, Babel.Files.File_Size'Image (Babel.Files.Get_Size (File)));
         Ada.Text_IO.Put (Checksum, " ");
         Ada.Text_IO.Put (Checksum, Path);
         Ada.Text_IO.New_Line (Checksum);
      end Write_Checksum;

   begin
      Ada.Text_IO.Create (File => Checksum, Name => Path);
      Database.Files.Iterate (Write_Checksum'Access);
      Ada.Text_IO.Close (File => Checksum);
   end Save;

end Babel.Base.Text;

Use Babel.Uid_Type and Babel.Gid_Type types


-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.Openid;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.Openid;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.Openid.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.Openid.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  Copyright (C) 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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.OpenID;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.OpenID;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   procedure Remove_Cookie (Name : in String);

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.OpenID.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.OpenID.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

Fix some compilation warnings

Fix some compilation warnings


-----------------------------------------------------------------------
--  gen-model-beans -- Ada Bean declarations
--  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 Ada.Strings.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Mappings;
with Gen.Model.Packages;
with Gen.Model.Tables;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

-----------------------------------------------------------------------
--  gen-model-beans -- Ada Bean declarations
--  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 Ada.Strings.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

Fix compilation warning

Fix compilation warning


--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ahven.AStrings;

package body Ahven.Listeners.Basic is
   use Ahven.AStrings;

   -- Because of Ada.Text_IO output capturing, the result
   -- recording is happening in the End_Test procedure.
   --
   -- Add_{Pass,Failure,Error} procedures delegate result
   -- saving to the Set_Last_Test_Info procedure, which
   -- records the latest result to the listener.

   procedure Set_Last_Test_Info (Listener : in out Basic_Listener;
                                 Info     :        Context;
                                 Result   :        Result_Type) is
   begin
      Listener.Last_Test_Result := Result;
      if Info.Phase = TEST_RUN then
         Results.Set_Routine_Name (Listener.Last_Info, Info.Routine_Name);
         Results.Set_Test_Name (Listener.Last_Info, Info.Test_Name);
         Results.Set_Message (Listener.Last_Info, Info.Message);
         Results.Set_Long_Message (Listener.Last_Info, Info.Long_Message);
      end if;
   end Set_Last_Test_Info;

   procedure Add_Pass (Listener : in out Basic_Listener;
                       Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, PASS_RESULT);
   end Add_Pass;

   procedure Add_Failure (Listener : in out Basic_Listener;
                          Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, FAILURE_RESULT);
   end Add_Failure;

   procedure Add_Skipped (Listener : in out Basic_Listener;
                         Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, SKIPPED_RESULT);
   end Add_Skipped;

   procedure Add_Error (Listener : in out Basic_Listener;
                        Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, ERROR_RESULT);
   end Add_Error;

   procedure Start_Test (Listener : in out Basic_Listener;
                         Info     :        Context) is
      R : Result_Collection_Access := null;
   begin
      Listener.Start_Time := Ada.Calendar.Clock;
      if Info.Test_Kind = CONTAINER then
         R := new Result_Collection;
         Set_Name (R.all, Info.Test_Name);
         Set_Parent (R.all, Listener.Current_Result);

         if Listener.Current_Result = null then
            Add_Child (Listener.Main_Result, R);
         else
            Add_Child (Listener.Current_Result.all, R);
         end if;
         Listener.Current_Result := R;
      elsif Listener.Capture_Output then
         -- A test routine? Let's create a temporary file
         -- and direct Ada.Text_IO output there (if requested).
         Temporary_Output.Create_Temp (Listener.Output_File);
         Temporary_Output.Redirect_Output (Listener.Output_File);
      end if;
   end Start_Test;

   procedure End_Test (Listener : in out Basic_Listener;
                       Info     :        Context) is
      use type Ada.Calendar.Time;

      Execution_Time : constant Duration :=
        Ada.Calendar.Clock - Listener.Start_Time;

      procedure Add_Result (Collection : in out Result_Collection) is
         My_Info : Result_Info := Listener.Last_Info;
      begin
         if Info.Phase = TEST_RUN then
            Set_Routine_Name (My_Info, To_String (Info.Routine_Name));
         end if;
         -- It is possible that only Start_Test and End_Test
         -- are called (e.g. for Test_Suite), so the latest
         -- test result can be unset (set to NO_RESULT)
         --
         -- In that case, we simply jump to parent collection.
         -- Otherwise, we record the result.
         if Listener.Last_Test_Result /= NO_RESULT then
            if Listener.Capture_Output then
               -- End of the test routine, so we can restore
               -- the normal output now and close the temporary file.
               Temporary_Output.Restore_Output;
               Temporary_Output.Close_Temp (Listener.Output_File);

               -- Saving the name of the temporary file to the test result,
               -- so the file can be deleted later
               Set_Output_File
                 (My_Info, Temporary_Output.Get_Name (Listener.Output_File));
            end if;

            Set_Message (My_Info, Get_Message (Listener.Last_Info));
            Set_Long_Message (My_Info, Get_Long_Message (Listener.Last_Info));
            Results.Set_Execution_Time (My_Info, Execution_Time);

            case Listener.Last_Test_Result is
               when PASS_RESULT =>
                  Add_Pass (Collection, My_Info);
               when FAILURE_RESULT =>
                  Add_Failure (Collection, My_Info);
               when ERROR_RESULT | NO_RESULT =>
                  Add_Error (Collection, My_Info);
               when SKIPPED_RESULT =>
                  Add_Skipped (Collection, My_Info);
            end case;
            Listener.Last_Test_Result := NO_RESULT;
         else
            Listener.Current_Result :=
              Get_Parent (Listener.Current_Result.all);
         end if;
      end Add_Result;
   begin
      if Listener.Current_Result /= null then
         Add_Result (Listener.Current_Result.all);
      else
         Add_Result (Listener.Main_Result);
      end if;
   end End_Test;

   procedure Set_Output_Capture (Listener : in out Basic_Listener;
                                 Capture  :        Boolean) is
   begin
      Listener.Capture_Output := Capture;
   end Set_Output_Capture;

   function Get_Output_Capture (Listener : Basic_Listener)
     return Boolean is
   begin
      return Listener.Capture_Output;
   end Get_Output_Capture;

   procedure Remove_File (Name : String) is
      Handle : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Open (Handle, Ada.Text_IO.Out_File, Name);
      Ada.Text_IO.Delete (Handle);
   exception
      when others =>
         null; -- For now we can safely ignore errors (like missing file)
   end Remove_File;

   procedure Remove_Files (Collection : in out Result_Collection) is
      procedure Remove (Name : Bounded_String) is
      begin
         if Length (Name) > 0 then
            Remove_File (To_String (Name));
         end if;
      end Remove;

      procedure Remove_Loop (First_Item : Result_Info_Cursor) is
         Loop_Iter : Result_Info_Cursor := First_Item;
      begin
         loop
            exit when not Is_Valid (Loop_Iter);
            Remove (Get_Output_File (Data (Loop_Iter)));
            Loop_Iter := Next (Loop_Iter);
         end loop;
      end Remove_Loop;

      Child_Iter : Result_Collection_Cursor;
   begin
      Remove_Loop (First_Pass (Collection));
      Remove_Loop (First_Failure (Collection));
      Remove_Loop (First_Error (Collection));
      Remove_Loop (First_Skipped (Collection));

      Child_Iter := First_Child (Collection);
      Child_Loop:
      loop
         exit Child_Loop when not Is_Valid (Child_Iter);
         Remove_Files (Data (Child_Iter).all);
         Child_Iter := Next (Child_Iter);
      end loop Child_Loop;
   end Remove_Files;

   procedure Finalize (Listener : in out Basic_Listener) is
   begin
      Remove_Files (Listener.Main_Result);
      Results.Release (Listener.Main_Result);
   end Finalize;
end Ahven.Listeners.Basic;

--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ahven.AStrings;

package body Ahven.Listeners.Basic is
   use Ahven.AStrings;

   -- Because of Ada.Text_IO output capturing, the result
   -- recording is happening in the End_Test procedure.
   --
   -- Add_{Pass,Failure,Error} procedures delegate result
   -- saving to the Set_Last_Test_Info procedure, which
   -- records the latest result to the listener.

   procedure Set_Last_Test_Info (Listener : in out Basic_Listener;
                                 Info     :        Context;
                                 Result   :        Result_Type) is
   begin
      Listener.Last_Test_Result := Result;
      if Info.Phase = TEST_RUN then
         Results.Set_Routine_Name (Listener.Last_Info, Info.Routine_Name);
         Results.Set_Test_Name (Listener.Last_Info, Info.Test_Name);
         Results.Set_Message (Listener.Last_Info, Info.Message);
         Results.Set_Long_Message (Listener.Last_Info, Info.Long_Message);
      end if;
   end Set_Last_Test_Info;

   procedure Add_Pass (Listener : in out Basic_Listener;
                       Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, PASS_RESULT);
   end Add_Pass;

   procedure Add_Failure (Listener : in out Basic_Listener;
                          Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, FAILURE_RESULT);
   end Add_Failure;

   procedure Add_Skipped (Listener : in out Basic_Listener;
                         Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, SKIPPED_RESULT);
   end Add_Skipped;

   procedure Add_Error (Listener : in out Basic_Listener;
                        Info     :        Context) is
   begin
      Set_Last_Test_Info (Listener, Info, ERROR_RESULT);
   end Add_Error;

   procedure Start_Test (Listener : in out Basic_Listener;
                         Info     :        Context) is
      R : Result_Collection_Access := null;
   begin
      Listener.Start_Time := Ada.Calendar.Clock;
      if Info.Test_Kind = CONTAINER then
         R := new Result_Collection;
         Set_Name (R.all, Info.Test_Name);
         Set_Parent (R.all, Listener.Current_Result);

         if Listener.Current_Result = null then
            Add_Child (Listener.Main_Result, R);
         else
            Add_Child (Listener.Current_Result.all, R);
         end if;
         Listener.Current_Result := R;
      elsif Listener.Capture_Output then
         -- A test routine? Let's create a temporary file
         -- and direct Ada.Text_IO output there (if requested).
         Temporary_Output.Create_Temp (Listener.Output_File);
         Temporary_Output.Redirect_Output (Listener.Output_File);
      end if;
   end Start_Test;

   procedure End_Test (Listener : in out Basic_Listener;
                       Info     :        Context) is
      use type Ada.Calendar.Time;

      Execution_Time : constant Duration :=
        Ada.Calendar.Clock - Listener.Start_Time;

      procedure Add_Result (Collection : in out Result_Collection) is
         My_Info : Result_Info := Listener.Last_Info;
      begin
         if Info.Phase = TEST_RUN then
            Set_Routine_Name (My_Info, To_String (Info.Routine_Name));
         end if;
         -- It is possible that only Start_Test and End_Test
         -- are called (e.g. for Test_Suite), so the latest
         -- test result can be unset (set to NO_RESULT)
         --
         -- In that case, we simply jump to parent collection.
         -- Otherwise, we record the result.
         if Listener.Last_Test_Result /= NO_RESULT then
            if Listener.Capture_Output then
               -- End of the test routine, so we can restore
               -- the normal output now and close the temporary file.
               Temporary_Output.Restore_Output;
               Temporary_Output.Close_Temp (Listener.Output_File);

               -- Saving the name of the temporary file to the test result,
               -- so the file can be deleted later
               Set_Output_File
                 (My_Info, Temporary_Output.Get_Name (Listener.Output_File));
            end if;

            Set_Message (My_Info, Get_Message (Listener.Last_Info));
            Set_Long_Message (My_Info, Get_Long_Message (Listener.Last_Info));
            Results.Set_Execution_Time (My_Info, Execution_Time);

            case Listener.Last_Test_Result is
               when PASS_RESULT =>
                  Add_Pass (Collection, My_Info);
               when FAILURE_RESULT =>
                  Add_Failure (Collection, My_Info);
               when ERROR_RESULT | NO_RESULT =>
                  Add_Error (Collection, My_Info);
               when SKIPPED_RESULT =>
                  Add_Skipped (Collection, My_Info);
            end case;
            Listener.Last_Test_Result := NO_RESULT;
         else
            Listener.Current_Result :=
              Get_Parent (Listener.Current_Result.all);
         end if;
      end Add_Result;
   begin
      if Listener.Current_Result /= null then
         Add_Result (Listener.Current_Result.all);
      else
         Add_Result (Listener.Main_Result);
      end if;
   end End_Test;

   procedure Set_Output_Capture (Listener : in out Basic_Listener;
                                 Capture  :        Boolean) is
   begin
      Listener.Capture_Output := Capture;
   end Set_Output_Capture;

   function Get_Output_Capture (Listener : Basic_Listener)
     return Boolean is
   begin
      return Listener.Capture_Output;
   end Get_Output_Capture;

   procedure Remove_File (Name : String) is
      Handle : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Open (Handle, Ada.Text_IO.Out_File, Name);
      Ada.Text_IO.Delete (Handle);
   exception
      when others =>
         null; -- For now we can safely ignore errors (like missing file)
   end Remove_File;

   procedure Remove_Files (Collection : in out Result_Collection) is
      procedure Remove (Name : Bounded_String) is
      begin
         if Length (Name) > 0 then
            Remove_File (To_String (Name));
         end if;
      end Remove;

      procedure Remove_Loop (First_Item : Result_Info_Cursor) is
         Loop_Iter : Result_Info_Cursor := First_Item;
      begin
         loop
            exit when not Is_Valid (Loop_Iter);
            Remove (Get_Output_File (Data (Loop_Iter)));
            Loop_Iter := Next (Loop_Iter);
         end loop;
      end Remove_Loop;

      Child_Iter : Result_Collection_Cursor;
   begin
      Remove_Loop (First_Pass (Collection));
      Remove_Loop (First_Failure (Collection));
      Remove_Loop (First_Error (Collection));
      Remove_Loop (First_Skipped (Collection));

      Child_Iter := First_Child (Collection);
      Child_Loop :
      loop
         exit Child_Loop when not Is_Valid (Child_Iter);
         Remove_Files (Data (Child_Iter).all);
         Child_Iter := Next (Child_Iter);
      end loop Child_Loop;
   end Remove_Files;

   procedure Finalize (Listener : in out Basic_Listener) is
   begin
      Remove_Files (Listener.Main_Result);
      Results.Release (Listener.Main_Result);
   end Finalize;
end Ahven.Listeners.Basic;

Fix style warning

Fix style warning


-----------------------------------------------------------------------
--  awa-modules-reader -- Read module configuration files
--  Copyright (C) 2011, 2012, 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 Util.Serialize.IO.XML;

with AWA.Applications.Configs;
with Security.Policies;

--  The <b>AWA.Modules.Reader</b> package reads the module configuration files
--  and initializes the module.
package body AWA.Modules.Reader is

   --  ------------------------------
   --  Read the module configuration file and configure the components
   --  ------------------------------
   procedure Read_Configuration (Plugin  : in out Module'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access) is

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

      package Config is
        new AWA.Applications.Configs.Reader_Config (Reader,
                                                    Plugin.App.all'Unchecked_Access,
                                                    Context,
                                                    False);
      pragma Warnings (Off, Config);

      Sec    : constant Security.Policies.Policy_Manager_Access := Plugin.App.Get_Security_Manager;
   begin
      Log.Info ("Reading module configuration file {0}", File);

      Sec.Prepare_Config (Reader);
      if AWA.Modules.Log.Get_Level >= Util.Log.DEBUG_LEVEL then
         Util.Serialize.IO.Dump (Reader, AWA.Modules.Log);
      end if;

      --  Read the configuration file and record managed beans, navigation rules.
      Reader.Parse (File);
      Sec.Finish_Config (Reader);

   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

end AWA.Modules.Reader;

-----------------------------------------------------------------------
--  awa-modules-reader -- Read module configuration files
--  Copyright (C) 2011, 2012, 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 Util.Serialize.IO.XML;
with Util.Serialize.Mappers;

with AWA.Applications.Configs;
with Security.Policies;

--  The <b>AWA.Modules.Reader</b> package reads the module configuration files
--  and initializes the module.
package body AWA.Modules.Reader is

   --  ------------------------------
   --  Read the module configuration file and configure the components
   --  ------------------------------
   procedure Read_Configuration (Plugin  : in out Module'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access) is

      Reader : Util.Serialize.IO.XML.Parser;
      Mapper : Util.Serialize.Mappers.Processing;

      package Config is
        new AWA.Applications.Configs.Reader_Config (Mapper,
                                                    Plugin.App.all'Unchecked_Access,
                                                    Context,
                                                    False);
      pragma Warnings (Off, Config);

      Sec    : constant Security.Policies.Policy_Manager_Access := Plugin.App.Get_Security_Manager;
   begin
      Log.Info ("Reading module configuration file {0}", File);

      Sec.Prepare_Config (Mapper);
      if AWA.Modules.Log.Get_Level >= Util.Log.DEBUG_LEVEL then
         Util.Serialize.Mappers.Dump (Mapper, AWA.Modules.Log);
      end if;

      --  Read the configuration file and record managed beans, navigation rules.
      Reader.Parse (File, Mapper);
      Sec.Finish_Config (Reader);

   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

end AWA.Modules.Reader;

Update to use the new parser/mapper interface


-----------------------------------------------------------------------
--  awa-components-wikis -- Wiki rendering component
--  Copyright (C) 2011, 2015, 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.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ASF.Contexts.Faces;
with ASF.Components;
with ASF.Components.Html;

with Wiki.Strings;
with Wiki.Render;
with Wiki.Render.Links;
package AWA.Components.Wikis is

   use ASF.Contexts.Faces;

   --  The wiki format of the wiki text.  The valid values are:
   --  dotclear, google, creole, phpbb, mediawiki
   FORMAT_NAME : constant String := "format";

   VALUE_NAME  : constant String := ASF.Components.VALUE_NAME;

   --  The link renderer bean that controls the generation of page and image links.
   LINKS_NAME  : constant String := "links";

   --  ------------------------------
   --  Wiki component
   --  ------------------------------
   --
   --  <awa:wiki value="wiki-text" format="dotclear|google|creole|phpbb" styleClass="class"/>
   --
   type UIWiki is new ASF.Components.Html.UIHtmlComponent with null record;
   type UIWiki_Access is access all UIWiki'Class;

   --  Get the wiki format style.  The format style is obtained from the <b>format</b>
   --  attribute name.
   function Get_Wiki_Style (UI      : in UIWiki;
                            Context : in Faces_Context'Class)
                            return Wiki.Wiki_Syntax;

   --  Get the links renderer that must be used to render image and page links.
   function Get_Links_Renderer (UI      : in UIWiki;
                                Context : in Faces_Context'Class)
                                return Wiki.Render.Links.Link_Renderer_Access;

   --  Render the wiki text
   overriding
   procedure Encode_Begin (UI      : in UIWiki;
                           Context : in out Faces_Context'Class);

   use Ada.Strings.Wide_Wide_Unbounded;

   IMAGE_PREFIX_ATTR : constant String := "image_prefix";
   PAGE_PREFIX_ATTR  : constant String := "page_prefix";

   type Link_Renderer_Bean is new Util.Beans.Basic.Bean
     and Wiki.Render.Links.Link_Renderer with record
      Page_Prefix  : Unbounded_Wide_Wide_String;
      Image_Prefix : Unbounded_Wide_Wide_String;
   end record;

   --  Make a link adding a prefix unless the link is already absolute.
   procedure Make_Link (Renderer : in Link_Renderer_Bean;
                        Link     : in Wiki.Strings.WString;
                        Prefix   : in Unbounded_Wide_Wide_String;
                        URI      : out Unbounded_Wide_Wide_String);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Link_Renderer_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Link_Renderer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in Link_Renderer_Bean;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in Link_Renderer_Bean;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean);

private

   function Starts_With (Content : in Unbounded_Wide_Wide_String;
                         Item    : in String) return Boolean;

end AWA.Components.Wikis;

-----------------------------------------------------------------------
--  awa-components-wikis -- Wiki rendering component
--  Copyright (C) 2011, 2015, 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.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ASF.Contexts.Faces;
with ASF.Components;
with ASF.Components.Html;

with Wiki.Strings;
with Wiki.Render;
with Wiki.Plugins;
with Wiki.Render.Links;
package AWA.Components.Wikis is

   use ASF.Contexts.Faces;

   --  The wiki format of the wiki text.  The valid values are:
   --  dotclear, google, creole, phpbb, mediawiki
   FORMAT_NAME : constant String := "format";

   VALUE_NAME  : constant String := ASF.Components.VALUE_NAME;

   --  The link renderer bean that controls the generation of page and image links.
   LINKS_NAME  : constant String := "links";

   --  The plugin factory bean that must be used for Wiki plugins.
   PLUGINS_NAME  : constant String := "plugins";

   --  ------------------------------
   --  Wiki component
   --  ------------------------------
   --
   --  <awa:wiki value="wiki-text" format="dotclear|google|creole|phpbb" styleClass="class"/>
   --
   type UIWiki is new ASF.Components.Html.UIHtmlComponent with null record;
   type UIWiki_Access is access all UIWiki'Class;

   --  Get the wiki format style.  The format style is obtained from the <b>format</b>
   --  attribute name.
   function Get_Wiki_Style (UI      : in UIWiki;
                            Context : in Faces_Context'Class)
                            return Wiki.Wiki_Syntax;

   --  Get the links renderer that must be used to render image and page links.
   function Get_Links_Renderer (UI      : in UIWiki;
                                Context : in Faces_Context'Class)
                                return Wiki.Render.Links.Link_Renderer_Access;

   --  Get the plugin factory that must be used by the Wiki parser.
   function Get_Plugin_Factory (UI      : in UIWiki;
                                Context : in Faces_Context'Class)
                                return Wiki.Plugins.Plugin_Factory_Access;

   --  Render the wiki text
   overriding
   procedure Encode_Begin (UI      : in UIWiki;
                           Context : in out Faces_Context'Class);

   use Ada.Strings.Wide_Wide_Unbounded;

   IMAGE_PREFIX_ATTR : constant String := "image_prefix";
   PAGE_PREFIX_ATTR  : constant String := "page_prefix";

   type Link_Renderer_Bean is new Util.Beans.Basic.Bean
     and Wiki.Render.Links.Link_Renderer with record
      Page_Prefix  : Unbounded_Wide_Wide_String;
      Image_Prefix : Unbounded_Wide_Wide_String;
   end record;

   --  Make a link adding a prefix unless the link is already absolute.
   procedure Make_Link (Renderer : in Link_Renderer_Bean;
                        Link     : in Wiki.Strings.WString;
                        Prefix   : in Unbounded_Wide_Wide_String;
                        URI      : out Unbounded_Wide_Wide_String);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Link_Renderer_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Link_Renderer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in Link_Renderer_Bean;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in Link_Renderer_Bean;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean);

private

   function Starts_With (Content : in Unbounded_Wide_Wide_String;
                         Item    : in String) return Boolean;

end AWA.Components.Wikis;

Declare Get_Plugin_Factory function

Declare Get_Plugin_Factory function