-----------------------------------------------------------------------
--  mat-interp -- Command interpreter
--  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.Strings;
with Util.Log.Loggers;

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Bfd;

with MAT.Types;
with MAT.Readers.Files;
with MAT.Memory.Tools;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Expressions;
with MAT.Frames;
with MAT.Frames.Print;
with MAT.Consoles;
package body MAT.Commands is

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

   package Command_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Command_Handler,
                                                Equivalent_Keys => "=",
                                                Hash            => Ada.Strings.Hash);

   Commands : Command_Map.Map;

   --  ------------------------------
   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   --  ------------------------------
   procedure Slot_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
      Slots : MAT.Memory.Allocation_Map;
      Iter  : MAT.Memory.Allocation_Cursor;

      procedure Print (Addr : in MAT.Types.Target_Addr;
                       Slot : in MAT.Memory.Allocation) is
         use type MAT.Frames.Frame_Type;
         Backtrace : MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Slot.Frame);

         Name : Ada.Strings.Unbounded.Unbounded_String;
         Func : Ada.Strings.Unbounded.Unbounded_String;
         Line : Natural;
      begin
         Ada.Text_IO.Put (MAT.Types.Hex_Image (Addr));
         Ada.Text_IO.Set_Col (14);
         Ada.Text_IO.Put (MAT.Types.Target_Size'Image (Slot.Size));
         Ada.Text_IO.Set_Col (30);
         Ada.Text_IO.Put (MAT.Types.Target_Thread_Ref'Image (Slot.Thread));
         Ada.Text_IO.Set_Col (50);
         Ada.Text_IO.Put (MAT.Types.Target_Tick_Ref'Image (Slot.Time));
         Ada.Text_IO.New_Line;
         for I in Backtrace'Range loop
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (Natural'Image (I));
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (MAT.Types.Hex_Image (Backtrace (I)));
            MAT.Symbols.Targets.Find_Nearest_Line (Symbols => Target.Symbols,
                                                   Addr    => Backtrace (I),
                                                   Name    => Name,
                                                   Func    => Func,
                                                   Line    => Line);
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Func));
            Ada.Text_IO.Put (" ");
            Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Name));
            if Line /= 0 then
               Ada.Text_IO.Put (":");
               Ada.Text_IO.Put (Util.Strings.Image (Line));
            end if;
            Ada.Text_IO.New_Line;
         end loop;
      end Print;

      Filter : MAT.Expressions.Expression_Type;
   begin
      Filter := MAT.Expressions.Parse (Args);
      Target.Memory.Find (From   => MAT.Types.Target_Addr'First,
                          To     => MAT.Types.Target_Addr'Last,
                          Filter => Filter,
                          Into   => Slots);
      Iter := Slots.First;
      while MAT.Memory.Allocation_Maps.Has_Element (Iter) loop
         MAT.Memory.Allocation_Maps.Query_Element (Iter, Print'Access);
         MAT.Memory.Allocation_Maps.Next (Iter);
      end loop;

   exception
      when E : others =>
         Target.Console.Error ("Invalid selection");
   end Slot_Command;

   --  ------------------------------
   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   --  ------------------------------
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String) is
      Sizes   : MAT.Memory.Tools.Size_Info_Map;
      Iter    : MAT.Memory.Tools.Size_Info_Cursor;
      Console : constant MAT.Consoles.Console_Access := Target.Console;
   begin
      Console.Start_Title;
      Console.Print_Title (MAT.Consoles.F_SIZE, "Slot size", 25);
      Console.Print_Title (MAT.Consoles.F_COUNT, "Count", 15);
      Console.Print_Title (MAT.Consoles.F_TOTAL_SIZE, "Total size", 15);
      Console.End_Title;

      MAT.Memory.Targets.Size_Information (Memory => Target.Memory,
                                           Sizes  => Sizes);
      Iter := Sizes.First;
      while MAT.Memory.Tools.Size_Info_Maps.Has_Element (Iter) loop
         declare
            use type MAT.Types.Target_Size;

            Size  : MAT.Types.Target_Size := MAT.Memory.Tools.Size_Info_Maps.Key (Iter);
            Info  : MAT.Memory.Tools.Size_Info_Type := MAT.Memory.Tools.Size_Info_Maps.Element (Iter);
            Total : MAT.Types.Target_Size := Size * MAT.Types.Target_Size (Info.Count);
         begin
            Console.Start_Row;
            Console.Print_Size (MAT.Consoles.F_SIZE, Size);
            Console.Print_Field (MAT.Consoles.F_COUNT, Info.Count);
            Console.Print_Field (MAT.Consoles.F_TOTAL_SIZE, Total);
            Console.End_Row;
         end;
         MAT.Memory.Tools.Size_Info_Maps.Next (Iter);
      end loop;
   end Sizes_Command;

   --  ------------------------------
   --  Threads command.
   --  Collect statistics about the threads and their allocation.
   --  ------------------------------
   procedure Threads_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String) is
      Sizes   : MAT.Memory.Tools.Size_Info_Map;
      Threads : MAT.Memory.Memory_Info_Map;
      Iter    : MAT.Memory.Memory_Info_Cursor;
      Console : constant MAT.Consoles.Console_Access := Target.Console;
   begin
      Console.Start_Title;
      Console.Print_Title (MAT.Consoles.F_Thread, "Thread", 10);
      Console.Print_Title (MAT.Consoles.F_COUNT, "# Allocation", 12);
      Console.Print_Title (MAT.Consoles.F_TOTAL_SIZE, "Total size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_SIZE, "Min slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_SIZE, "Max slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_ADDR, "Low address", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_ADDR, "High address", 15);
      Console.End_Title;

      MAT.Memory.Targets.Thread_Information (Memory  => Target.Memory,
                                             Threads => Threads);
      Iter := Threads.First;
      while MAT.Memory.Memory_Info_Maps.Has_Element (Iter) loop
         declare
            use type MAT.Types.Target_Size;

            Thread : constant Types.Target_Thread_Ref := MAT.Memory.Memory_Info_Maps.Key (Iter);
            Info   : constant Memory.Memory_Info := MAT.Memory.Memory_Info_Maps.Element (Iter);
         begin
            Console.Start_Row;
            Console.Print_Field (MAT.Consoles.F_THREAD, Integer (Thread));
            Console.Print_Field (MAT.Consoles.F_COUNT, Info.Alloc_Count);
            Console.Print_Size (MAT.Consoles.F_TOTAL_SIZE, Info.Total_Size);
            Console.Print_Size (MAT.Consoles.F_MIN_SIZE, Info.Min_Slot_Size);
            Console.Print_Size (MAT.Consoles.F_MAX_SIZE, Info.Max_Slot_Size);
            Console.Print_Field (MAT.Consoles.F_MIN_ADDR, Info.Min_Addr);
            Console.Print_Field (MAT.Consoles.F_MAX_ADDR, Info.Max_Addr);
            Console.End_Row;
         end;
         MAT.Memory.Memory_Info_Maps.Next (Iter);
      end loop;
   end Threads_Command;

   --  ------------------------------
   --  Symbol command.
   --  Load the symbols from the binary file.
   --  ------------------------------
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String) is
   begin
      MAT.Symbols.Targets.Open (Target.Symbols, Args);

   exception
      when Bfd.OPEN_ERROR =>
         Target.Console.Error ("Cannot open symbol file '" & Args & "'");
   end Symbol_Command;

   --  ------------------------------
   --  Exit command.
   --  ------------------------------
   procedure Exit_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
   begin
      raise Stop_Interp;
   end Exit_Command;

   --  ------------------------------
   --  Open a MAT file and read the events.
   --  ------------------------------
   procedure Open_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
      Reader : MAT.Readers.Files.File_Reader_Type;
   begin
      Target.Initialize (Reader);
      Reader.Open (Args);
      Reader.Read_All;

   exception
      when E : Ada.IO_Exceptions.Name_Error =>
         Log.Error ("Cannot open {0}", Args);
   end Open_Command;

   function Get_Command (Line : in String) return String is
      Pos : Natural := Util.Strings.Index (Line, ' ');
   begin
      if Pos <= 0 then
         return Line;
      else
         return Line (Line'First .. Pos - 1);
      end if;
   end Get_Command;

   --  ------------------------------
   --  Execute the command given in the line.
   --  ------------------------------
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String) is
      Command : constant String := Get_Command (Line);
      Index   : constant Natural := Util.Strings.Index (Line, ' ');
      Pos     : constant Command_Map.Cursor := Commands.Find (Command);
   begin
      if Command_Map.Has_Element (Pos) then
         Command_Map.Element (Pos) (Target, Line (Index + 1 .. Line'Last));
      elsif Command'Length > 0 then
         Target.Console.Error ("Command '" & Command & "' not found");
      end if;
   end Execute;

begin
   Commands.Insert ("exit", Exit_Command'Access);
   Commands.Insert ("quit", Exit_Command'Access);
   Commands.Insert ("open", Open_Command'Access);
   Commands.Insert ("sizes", Sizes_Command'Access);
   Commands.Insert ("symbol", Symbol_Command'Access);
   Commands.Insert ("slots", Slot_Command'Access);
   Commands.Insert ("threads", Threads_Command'Access);
end MAT.Commands;

-----------------------------------------------------------------------
--  mat-interp -- Command interpreter
--  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.Strings;
with Util.Log.Loggers;

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Bfd;

with MAT.Types;
with MAT.Readers.Files;
with MAT.Memory.Tools;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Expressions;
with MAT.Frames;
with MAT.Frames.Print;
with MAT.Consoles;
package body MAT.Commands is

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

   package Command_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Command_Handler,
                                                Equivalent_Keys => "=",
                                                Hash            => Ada.Strings.Hash);

   Commands : Command_Map.Map;

   --  ------------------------------
   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   --  ------------------------------
   procedure Slot_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
      Slots : MAT.Memory.Allocation_Map;
      Iter  : MAT.Memory.Allocation_Cursor;

      procedure Print (Addr : in MAT.Types.Target_Addr;
                       Slot : in MAT.Memory.Allocation) is
         use type MAT.Frames.Frame_Type;
         Backtrace : MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Slot.Frame);

         Name : Ada.Strings.Unbounded.Unbounded_String;
         Func : Ada.Strings.Unbounded.Unbounded_String;
         Line : Natural;
      begin
         Ada.Text_IO.Put (MAT.Types.Hex_Image (Addr));
         Ada.Text_IO.Set_Col (14);
         Ada.Text_IO.Put (MAT.Types.Target_Size'Image (Slot.Size));
         Ada.Text_IO.Set_Col (30);
         Ada.Text_IO.Put (MAT.Types.Target_Thread_Ref'Image (Slot.Thread));
         Ada.Text_IO.Set_Col (50);
         Ada.Text_IO.Put (MAT.Types.Target_Tick_Ref'Image (Slot.Time));
         Ada.Text_IO.New_Line;
         for I in Backtrace'Range loop
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (Natural'Image (I));
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (MAT.Types.Hex_Image (Backtrace (I)));
            MAT.Symbols.Targets.Find_Nearest_Line (Symbols => Target.Symbols,
                                                   Addr    => Backtrace (I),
                                                   Name    => Name,
                                                   Func    => Func,
                                                   Line    => Line);
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Func));
            Ada.Text_IO.Put (" ");
            Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Name));
            if Line /= 0 then
               Ada.Text_IO.Put (":");
               Ada.Text_IO.Put (Util.Strings.Image (Line));
            end if;
            Ada.Text_IO.New_Line;
         end loop;
      end Print;

      Filter : MAT.Expressions.Expression_Type;
   begin
      Filter := MAT.Expressions.Parse (Args);
      Target.Memory.Find (From   => MAT.Types.Target_Addr'First,
                          To     => MAT.Types.Target_Addr'Last,
                          Filter => Filter,
                          Into   => Slots);
      Iter := Slots.First;
      while MAT.Memory.Allocation_Maps.Has_Element (Iter) loop
         MAT.Memory.Allocation_Maps.Query_Element (Iter, Print'Access);
         MAT.Memory.Allocation_Maps.Next (Iter);
      end loop;

   exception
      when E : others =>
         Target.Console.Error ("Invalid selection");
   end Slot_Command;

   --  ------------------------------
   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   --  ------------------------------
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String) is
      Sizes   : MAT.Memory.Tools.Size_Info_Map;
      Iter    : MAT.Memory.Tools.Size_Info_Cursor;
      Console : constant MAT.Consoles.Console_Access := Target.Console;
   begin
      Console.Start_Title;
      Console.Print_Title (MAT.Consoles.F_SIZE, "Slot size", 25);
      Console.Print_Title (MAT.Consoles.F_COUNT, "Count", 15);
      Console.Print_Title (MAT.Consoles.F_TOTAL_SIZE, "Total size", 15);
      Console.End_Title;

      MAT.Memory.Targets.Size_Information (Memory => Target.Memory,
                                           Sizes  => Sizes);
      Iter := Sizes.First;
      while MAT.Memory.Tools.Size_Info_Maps.Has_Element (Iter) loop
         declare
            use type MAT.Types.Target_Size;

            Size  : MAT.Types.Target_Size := MAT.Memory.Tools.Size_Info_Maps.Key (Iter);
            Info  : MAT.Memory.Tools.Size_Info_Type := MAT.Memory.Tools.Size_Info_Maps.Element (Iter);
            Total : MAT.Types.Target_Size := Size * MAT.Types.Target_Size (Info.Count);
         begin
            Console.Start_Row;
            Console.Print_Size (MAT.Consoles.F_SIZE, Size);
            Console.Print_Field (MAT.Consoles.F_COUNT, Info.Count);
            Console.Print_Field (MAT.Consoles.F_TOTAL_SIZE, Total);
            Console.End_Row;
         end;
         MAT.Memory.Tools.Size_Info_Maps.Next (Iter);
      end loop;
   end Sizes_Command;

   --  ------------------------------
   --  Threads command.
   --  Collect statistics about the threads and their allocation.
   --  ------------------------------
   procedure Threads_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String) is
      Sizes   : MAT.Memory.Tools.Size_Info_Map;
      Threads : MAT.Memory.Memory_Info_Map;
      Iter    : MAT.Memory.Memory_Info_Cursor;
      Console : constant MAT.Consoles.Console_Access := Target.Console;
   begin
      Console.Start_Title;
      Console.Print_Title (MAT.Consoles.F_Thread, "Thread", 10);
      Console.Print_Title (MAT.Consoles.F_COUNT, "# Allocation", 12);
      Console.Print_Title (MAT.Consoles.F_TOTAL_SIZE, "Total size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_SIZE, "Min slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_SIZE, "Max slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_ADDR, "Low address", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_ADDR, "High address", 15);
      Console.End_Title;

      MAT.Memory.Targets.Thread_Information (Memory  => Target.Memory,
                                             Threads => Threads);
      Iter := Threads.First;
      while MAT.Memory.Memory_Info_Maps.Has_Element (Iter) loop
         declare
            use type MAT.Types.Target_Size;

            Thread : constant Types.Target_Thread_Ref := MAT.Memory.Memory_Info_Maps.Key (Iter);
            Info   : constant Memory.Memory_Info := MAT.Memory.Memory_Info_Maps.Element (Iter);
         begin
            Console.Start_Row;
            Console.Print_Field (MAT.Consoles.F_THREAD, Integer (Thread));
            Console.Print_Field (MAT.Consoles.F_COUNT, Info.Alloc_Count);
            Console.Print_Size (MAT.Consoles.F_TOTAL_SIZE, Info.Total_Size);
            Console.Print_Size (MAT.Consoles.F_MIN_SIZE, Info.Min_Slot_Size);
            Console.Print_Size (MAT.Consoles.F_MAX_SIZE, Info.Max_Slot_Size);
            Console.Print_Field (MAT.Consoles.F_MIN_ADDR, Info.Min_Addr);
            Console.Print_Field (MAT.Consoles.F_MAX_ADDR, Info.Max_Addr);
            Console.End_Row;
         end;
         MAT.Memory.Memory_Info_Maps.Next (Iter);
      end loop;
   end Threads_Command;

   --  ------------------------------
   --  Frames command.
   --  Collect statistics about the frames and their allocation.
   --  ------------------------------
   procedure Frames_Command (Target : in out MAT.Targets.Target_Type'Class;
                              Args   : in String) is
      Sizes   : MAT.Memory.Tools.Size_Info_Map;
      Frames  : MAT.Memory.Frame_Info_Map;
      Iter    : MAT.Memory.Frame_Info_Cursor;
      Level   : Positive := 3;
      Console : constant MAT.Consoles.Console_Access := Target.Console;
   begin
      Console.Start_Title;
      Console.Print_Title (MAT.Consoles.F_FILE_NAME, "File", 20);
      Console.Print_Title (MAT.Consoles.F_FUNCTION_NAME, "Function", 20);
      Console.Print_Title (MAT.Consoles.F_LINE_NUMBER, "Line", 6);
      Console.Print_Title (MAT.Consoles.F_COUNT, "# Allocation", 12);
      Console.Print_Title (MAT.Consoles.F_TOTAL_SIZE, "Total size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_SIZE, "Min slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_SIZE, "Max slot size", 15);
      Console.Print_Title (MAT.Consoles.F_MIN_ADDR, "Low address", 15);
      Console.Print_Title (MAT.Consoles.F_MAX_ADDR, "High address", 15);
      Console.End_Title;

      MAT.Memory.Targets.Frame_Information (Memory => Target.Memory,
                                            Level  => Level,
                                            Frames => Frames);
      Iter := Frames.First;
      while MAT.Memory.Frame_Info_Maps.Has_Element (Iter) loop
         declare
            use type MAT.Types.Target_Size;

            Func   : constant Types.Target_Addr := MAT.Memory.Frame_Info_Maps.Key (Iter);
            Info   : constant Memory.Frame_Info := MAT.Memory.Frame_Info_Maps.Element (Iter);
            Name : Ada.Strings.Unbounded.Unbounded_String;
            File_Name : Ada.Strings.Unbounded.Unbounded_String;
            Line : Natural;
         begin
            MAT.Symbols.Targets.Find_Nearest_Line (Symbols => Target.Symbols,
                                                   Addr    => Func,
                                                   Name    => Name,
                                                   Func    => File_Name,
                                                   Line    => Line);
            Console.Start_Row;
            Console.Print_Field (MAT.Consoles.F_FILE_NAME, File_Name);
            Console.Print_Field (MAT.Consoles.F_FUNCTION_NAME, Name);
            Console.Print_Field (MAT.Consoles.F_LINE_NUMBER, Line);
            Console.Print_Field (MAT.Consoles.F_COUNT, Info.Memory.Alloc_Count);
            Console.Print_Size (MAT.Consoles.F_TOTAL_SIZE, Info.Memory.Total_Size);
            Console.Print_Size (MAT.Consoles.F_MIN_SIZE, Info.Memory.Min_Slot_Size);
            Console.Print_Size (MAT.Consoles.F_MAX_SIZE, Info.Memory.Max_Slot_Size);
            Console.Print_Field (MAT.Consoles.F_MIN_ADDR, Info.Memory.Min_Addr);
            Console.Print_Field (MAT.Consoles.F_MAX_ADDR, Info.Memory.Max_Addr);
            Console.End_Row;
         end;
         MAT.Memory.Frame_Info_Maps.Next (Iter);
      end loop;
   end Frames_Command;

   --  ------------------------------
   --  Symbol command.
   --  Load the symbols from the binary file.
   --  ------------------------------
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String) is
   begin
      MAT.Symbols.Targets.Open (Target.Symbols, Args);

   exception
      when Bfd.OPEN_ERROR =>
         Target.Console.Error ("Cannot open symbol file '" & Args & "'");
   end Symbol_Command;

   --  ------------------------------
   --  Exit command.
   --  ------------------------------
   procedure Exit_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
   begin
      raise Stop_Interp;
   end Exit_Command;

   --  ------------------------------
   --  Open a MAT file and read the events.
   --  ------------------------------
   procedure Open_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String) is
      Reader : MAT.Readers.Files.File_Reader_Type;
   begin
      Target.Initialize (Reader);
      Reader.Open (Args);
      Reader.Read_All;

   exception
      when E : Ada.IO_Exceptions.Name_Error =>
         Log.Error ("Cannot open {0}", Args);
   end Open_Command;

   function Get_Command (Line : in String) return String is
      Pos : Natural := Util.Strings.Index (Line, ' ');
   begin
      if Pos <= 0 then
         return Line;
      else
         return Line (Line'First .. Pos - 1);
      end if;
   end Get_Command;

   --  ------------------------------
   --  Execute the command given in the line.
   --  ------------------------------
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String) is
      Command : constant String := Get_Command (Line);
      Index   : constant Natural := Util.Strings.Index (Line, ' ');
      Pos     : constant Command_Map.Cursor := Commands.Find (Command);
   begin
      if Command_Map.Has_Element (Pos) then
         Command_Map.Element (Pos) (Target, Line (Index + 1 .. Line'Last));
      elsif Command'Length > 0 then
         Target.Console.Error ("Command '" & Command & "' not found");
      end if;

   exception
      when Stop_Interp =>
         raise;

      when E : others =>
         Log.Error ("Exception: ", E);
         Target.Console.Error ("Exception while processing command");

   end Execute;

begin
   Commands.Insert ("exit", Exit_Command'Access);
   Commands.Insert ("quit", Exit_Command'Access);
   Commands.Insert ("open", Open_Command'Access);
   Commands.Insert ("sizes", Sizes_Command'Access);
   Commands.Insert ("symbol", Symbol_Command'Access);
   Commands.Insert ("slots", Slot_Command'Access);
   Commands.Insert ("threads", Threads_Command'Access);
   Commands.Insert ("frames", Frames_Command'Access);
end MAT.Commands;

Define the frames command New function Frames_Command to print the functions that allocate memory


-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  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 Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc(" & Size (Item.Size) & ")";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ")";
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ")";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  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 Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & ")";
            end if;

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Update the event brief format to be even briefer


-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Util.Encoders.Base16;
with Util.Encoders.Base64;
with Util.Encoders.SHA1;
package body Util.Encoders is

   use Ada;
   use Ada.Strings.Unbounded;

   use type Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   --  ------------------------------
   function Encode (E    : in Encoder;
                    Data : in String) return String is
   begin
      if E.Encode = null then
         raise Not_Supported with "There is no encoder";
      end if;
      return E.Encode.Transform (Data);
   end Encode;

   --  ------------------------------
   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   --  ------------------------------
   function Decode (E    : in Encoder;
                    Data : in String) return String is
   begin
      if E.Decode = null then
         raise Not_Supported with "There is no decoder";
      end if;
      return E.Decode.Transform (Data);
   end Decode;

   MIN_BUFFER_SIZE : constant Streams.Stream_Element_Offset := 64;
   MAX_BUFFER_SIZE : constant Streams.Stream_Element_Offset := 2_048;

   function Best_Size (Length : Natural) return Streams.Stream_Element_Offset;
   pragma Inline (Best_Size);

   --  ------------------------------
   --  Compute a good size for allocating a buffer on the stack
   --  ------------------------------
   function Best_Size (Length : Natural) return Streams.Stream_Element_Offset is
   begin
      if Length < Natural (MIN_BUFFER_SIZE) then
         return MIN_BUFFER_SIZE;
      elsif Length > Natural (MAX_BUFFER_SIZE) then
         return MAX_BUFFER_SIZE;
      else
         return Streams.Stream_Element_Offset (((Length + 15) / 16) * 16);
      end if;
   end Best_Size;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   function Transform (E    : in out Transformer'Class;
                       Data : in String) return String is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Buf      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Res      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Tmp      : String (1 .. Natural (Buf_Size));
      Result   : Ada.Strings.Unbounded.Unbounded_String;
      Pos      : Natural := Data'First;
   begin
      while Pos <= Data'Last loop
         declare
            Last_Encoded  : Streams.Stream_Element_Offset;
            First_Encoded : Streams.Stream_Element_Offset := 1;
            Last          : Streams.Stream_Element_Offset;
            Size          : Streams.Stream_Element_Offset;
            Next_Pos      : Natural;
         begin
            --  Fill the stream buffer with our input string
            Size := Streams.Stream_Element_Offset (Data'Last - Pos + 1);
            if Size > Buf'Length then
               Size := Buf'Length;
            end if;
            for I in 1 .. Size loop
               Buf (I) := Character'Pos (Data (Natural (I) + Pos - 1));
            end loop;
            Next_Pos := Pos + Natural (Size);

            --  Encode that buffer and put the result in out result string.
            loop
               E.Transform (Data    => Buf (First_Encoded .. Size),
                            Into    => Res,
                            Encoded => Last_Encoded,
                            Last    => Last);

               --  If the encoder generated nothing, move the position backward
               --  to take into account the remaining bytes not taken into account.
               if Last < 1 then
                  Next_Pos := Next_Pos - Natural (Size - First_Encoded + 1);
                  exit;
               end if;
               for I in 1 .. Last loop
                  Tmp (Natural (I)) := Character'Val (Res (I));
               end loop;
               Append (Result, Tmp (1 .. Natural (Last)));
               exit when Last_Encoded = Size;
               First_Encoded := Last_Encoded + 1;
            end loop;

            --  The encoder cannot encode the data
            if Pos = Next_Pos then
               raise Encoding_Error with "Encoding cannot proceed";
            end if;
            Pos := Next_Pos;
         end;
      end loop;
      return To_String (Result);
   end Transform;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   procedure Transform (E    : in out Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset) is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Buf      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Pos      : Natural := Data'First;
      First    : Streams.Stream_Element_Offset := Into'First;
   begin
      Last := Into'First - 1;
      while Pos <= Data'Last and Last < Into'Last loop
         declare
            Last_Encoded  : Streams.Stream_Element_Offset;
            Size          : Streams.Stream_Element_Offset;
            Next_Pos      : Natural;
         begin
            --  Fill the stream buffer with our input string
            Size := Streams.Stream_Element_Offset (Data'Last - Pos + 1);
            if Size > Buf'Length then
               Size := Buf'Length;
            end if;
            for I in 1 .. Size loop
               Buf (I) := Character'Pos (Data (Natural (I) + Pos - 1));
            end loop;
            Next_Pos := Pos + Natural (Size);

            --  Encode that buffer and put the result in the output data array.
            E.Transform (Data    => Buf (1 .. Size),
                         Into    => Into (First .. Into'Last),
                         Encoded => Last_Encoded,
                         Last    => Last);

            --  If the encoded has not used all the data, update the position for the next run.
            if Last_Encoded /= Size then
               Next_Pos := Next_Pos - Natural (Size - Last_Encoded + 1);
            end if;

            --  The encoder cannot encode the data
            if Pos = Next_Pos then
               raise Encoding_Error with "Encoding cannot proceed";
            end if;
            First := Last;
            Pos := Next_Pos;
         end;
      end loop;
      if Pos <= Data'Last then
         raise Encoding_Error with "Not enough space for encoding";
      end if;
   end Transform;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   function Transform (E    : in out Transformer'Class;
                       Data : in Streams.Stream_Element_Array) return String is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Res      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Tmp      : String (1 .. Natural (Buf_Size));
      Result   : Ada.Strings.Unbounded.Unbounded_String;
      Last_Encoded  : Streams.Stream_Element_Offset;
      Last          : Streams.Stream_Element_Offset;
   begin

      --  Encode that buffer and put the result in out result string.
      E.Transform (Data    => Data,
                   Into    => Res,
                   Encoded => Last_Encoded,
                   Last    => Last);

      for I in 1 .. Last loop
         Tmp (Natural (I)) := Character'Val (Res (I));
      end loop;
      Append (Result, Tmp (1 .. Natural (Last)));
      return To_String (Result);
   end Transform;

   --  ------------------------------
   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   --  ------------------------------
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset) is
      use type Interfaces.Unsigned_64;

      P    : Ada.Streams.Stream_Element_Offset := Pos;
      V, U : Interfaces.Unsigned_64;
   begin
      V := Val;
      loop
         if V < 16#07F# then
            Into (P) := Ada.Streams.Stream_Element (V);
            Last := P;
            return;
         end if;
         U := V and 16#07F#;
         Into (P) := Ada.Streams.Stream_Element (U or 16#80#);
         P := P + 1;
         V := Interfaces.Shift_Right (V, 7);
      end loop;
   end Encode_LEB128;

   --  ------------------------------
   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   --  ------------------------------
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset) is
      use type Interfaces.Unsigned_64;
      use type Interfaces.Unsigned_8;

      P     : Ada.Streams.Stream_Element_Offset := Pos;
      Value : Interfaces.Unsigned_64 := 0;
      V     : Interfaces.Unsigned_8;
      Shift : Integer := 0;
   begin
      loop
         V := Interfaces.Unsigned_8 (From (P));
         if (V and 16#80#) = 0 then
            Val := Interfaces.Shift_Left (Interfaces.Unsigned_64 (V), Shift) or Value;
            Last := P + 1;
            return;
         end if;
         V := V and 16#07F#;
         Value := Interfaces.Shift_Left (Interfaces.Unsigned_64 (V), Shift) or Value;
         P := P + 1;
         Shift := Shift + 7;
      end loop;
   end Decode_LEB128;

   --  ------------------------------
   --  Create the encoder object for the specified algorithm.
   --  ------------------------------
   function Create (Name : String) return Encoder is
   begin
      if Name = BASE_16 or Name = HEX then
         return E : Encoder do
            E.Encode := new Util.Encoders.Base16.Encoder;
            E.Decode := new Util.Encoders.Base16.Decoder;
         end return;

      elsif Name = BASE_64 then
         return E : Encoder do
            E.Encode := new Util.Encoders.Base64.Encoder;
            E.Decode := new Util.Encoders.Base64.Decoder;
         end return;

      elsif Name = BASE_64_URL then
         return E : Encoder do
            E.Encode := Util.Encoders.Base64.Create_URL_Encoder;
            E.Decode := Util.Encoders.Base64.Create_URL_Decoder;
         end return;

      elsif Name = HASH_SHA1 then
         return E : Encoder do
            E.Encode := new Util.Encoders.SHA1.Encoder;
            E.Decode := new Util.Encoders.Base64.Decoder;
         end return;
      end if;
      raise Not_Supported with "Invalid encoder: " & Name;
   end Create;

   --  ------------------------------
   --  Delete the transformers
   --  ------------------------------
   overriding
   procedure Finalize (E : in out Encoder) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Transformer'Class, Transformer_Access);

   begin
      Free (E.Encode);
      Free (E.Decode);
   end Finalize;

end Util.Encoders;

-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Util.Encoders.Base16;
with Util.Encoders.Base64;
with Util.Encoders.SHA1;
package body Util.Encoders is

   use Ada;
   use Ada.Strings.Unbounded;

   use type Ada.Streams.Stream_Element_Offset;

   procedure Free is
     new Ada.Unchecked_Deallocation (Transformer'Class, Transformer_Access);

   --  ------------------------------
   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   --  ------------------------------
   function Encode (E    : in Encoder;
                    Data : in String) return String is
   begin
      if E.Encode = null then
         raise Not_Supported with "There is no encoder";
      end if;
      return E.Encode.Transform (Data);
   end Encode;

   --  ------------------------------
   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   --  ------------------------------
   function Decode (E    : in Decoder;
                    Data : in String) return String is
   begin
      if E.Decode = null then
         raise Not_Supported with "There is no decoder";
      end if;
      return E.Decode.Transform (Data);
   end Decode;

   MIN_BUFFER_SIZE : constant Streams.Stream_Element_Offset := 64;
   MAX_BUFFER_SIZE : constant Streams.Stream_Element_Offset := 2_048;

   function Best_Size (Length : Natural) return Streams.Stream_Element_Offset;
   pragma Inline (Best_Size);

   --  ------------------------------
   --  Compute a good size for allocating a buffer on the stack
   --  ------------------------------
   function Best_Size (Length : Natural) return Streams.Stream_Element_Offset is
   begin
      if Length < Natural (MIN_BUFFER_SIZE) then
         return MIN_BUFFER_SIZE;
      elsif Length > Natural (MAX_BUFFER_SIZE) then
         return MAX_BUFFER_SIZE;
      else
         return Streams.Stream_Element_Offset (((Length + 15) / 16) * 16);
      end if;
   end Best_Size;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   function Transform (E    : in out Transformer'Class;
                       Data : in String) return String is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Buf      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Res      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Tmp      : String (1 .. Natural (Buf_Size));
      Result   : Ada.Strings.Unbounded.Unbounded_String;
      Pos      : Natural := Data'First;
      Last          : Streams.Stream_Element_Offset;
   begin
      while Pos <= Data'Last loop
         declare
            Last_Encoded  : Streams.Stream_Element_Offset;
            First_Encoded : Streams.Stream_Element_Offset := 1;
            Size          : Streams.Stream_Element_Offset;
            Next_Pos      : Natural;
         begin
            --  Fill the stream buffer with our input string
            Size := Streams.Stream_Element_Offset (Data'Last - Pos + 1);
            if Size > Buf'Length then
               Size := Buf'Length;
            end if;
            for I in 1 .. Size loop
               Buf (I) := Character'Pos (Data (Natural (I) + Pos - 1));
            end loop;
            Next_Pos := Pos + Natural (Size);

            --  Encode that buffer and put the result in out result string.
            loop
               E.Transform (Data    => Buf (First_Encoded .. Size),
                            Into    => Res,
                            Encoded => Last_Encoded,
                            Last    => Last);

               --  If the encoder generated nothing, move the position backward
               --  to take into account the remaining bytes not taken into account.
               if Last < 1 then
                  Next_Pos := Next_Pos - Natural (Size - First_Encoded + 1);
                  exit;
               end if;
               for I in 1 .. Last loop
                  Tmp (Natural (I)) := Character'Val (Res (I));
               end loop;
               Append (Result, Tmp (1 .. Natural (Last)));
               exit when Last_Encoded = Size;
               First_Encoded := Last_Encoded + 1;
            end loop;

            --  The encoder cannot encode the data
            if Pos = Next_Pos then
               raise Encoding_Error with "Encoding cannot proceed";
            end if;
            Pos := Next_Pos;
         end;
      end loop;
      Last := 0;
      E.Finish (Into => Res,
                Last => Last);
      if Last > 0 then
         for I in 1 .. Last loop
            Tmp (Natural (I)) := Character'Val (Res (I));
         end loop;
         Append (Result, Tmp (1 .. Natural (Last)));
      end if;
      return To_String (Result);
   end Transform;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   procedure Transform (E    : in out Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset) is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Buf      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Pos      : Natural := Data'First;
      First    : Streams.Stream_Element_Offset := Into'First;
   begin
      Last := Into'First - 1;
      while Pos <= Data'Last and Last < Into'Last loop
         declare
            Last_Encoded  : Streams.Stream_Element_Offset;
            Size          : Streams.Stream_Element_Offset;
            Next_Pos      : Natural;
         begin
            --  Fill the stream buffer with our input string
            Size := Streams.Stream_Element_Offset (Data'Last - Pos + 1);
            if Size > Buf'Length then
               Size := Buf'Length;
            end if;
            for I in 1 .. Size loop
               Buf (I) := Character'Pos (Data (Natural (I) + Pos - 1));
            end loop;
            Next_Pos := Pos + Natural (Size);

            --  Encode that buffer and put the result in the output data array.
            E.Transform (Data    => Buf (1 .. Size),
                         Into    => Into (First .. Into'Last),
                         Encoded => Last_Encoded,
                         Last    => Last);

            --  If the encoded has not used all the data, update the position for the next run.
            if Last_Encoded /= Size then
               Next_Pos := Next_Pos - Natural (Size - Last_Encoded + 1);
            end if;

            --  The encoder cannot encode the data
            if Pos = Next_Pos then
               raise Encoding_Error with "Encoding cannot proceed";
            end if;
            First := Last;
            Pos := Next_Pos;
         end;
      end loop;
      if Pos <= Data'Last then
         raise Encoding_Error with "Not enough space for encoding";
      end if;
   end Transform;

   --  ------------------------------
   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   --  ------------------------------
   function Transform (E    : in out Transformer'Class;
                       Data : in Streams.Stream_Element_Array) return String is
      Buf_Size : constant Streams.Stream_Element_Offset := Best_Size (Data'Length);
      Res      : Streams.Stream_Element_Array (1 .. Buf_Size);
      Tmp      : String (1 .. Natural (Buf_Size));
      Result   : Ada.Strings.Unbounded.Unbounded_String;
      Last_Encoded  : Streams.Stream_Element_Offset;
      Last          : Streams.Stream_Element_Offset;
   begin

      --  Encode that buffer and put the result in out result string.
      E.Transform (Data    => Data,
                   Into    => Res,
                   Encoded => Last_Encoded,
                   Last    => Last);

      E.Finish (Res (Last + 1 .. Res'Last), Last);
      for I in 1 .. Last loop
         Tmp (Natural (I)) := Character'Val (Res (I));
      end loop;
      Append (Result, Tmp (1 .. Natural (Last)));
      return To_String (Result);
   end Transform;

   --  ------------------------------
   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   --  ------------------------------
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset) is
      use type Interfaces.Unsigned_64;

      P    : Ada.Streams.Stream_Element_Offset := Pos;
      V, U : Interfaces.Unsigned_64;
   begin
      V := Val;
      loop
         if V < 16#07F# then
            Into (P) := Ada.Streams.Stream_Element (V);
            Last := P;
            return;
         end if;
         U := V and 16#07F#;
         Into (P) := Ada.Streams.Stream_Element (U or 16#80#);
         P := P + 1;
         V := Interfaces.Shift_Right (V, 7);
      end loop;
   end Encode_LEB128;

   --  ------------------------------
   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   --  ------------------------------
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset) is
      use type Interfaces.Unsigned_64;
      use type Interfaces.Unsigned_8;

      P     : Ada.Streams.Stream_Element_Offset := Pos;
      Value : Interfaces.Unsigned_64 := 0;
      V     : Interfaces.Unsigned_8;
      Shift : Integer := 0;
   begin
      loop
         V := Interfaces.Unsigned_8 (From (P));
         if (V and 16#80#) = 0 then
            Val := Interfaces.Shift_Left (Interfaces.Unsigned_64 (V), Shift) or Value;
            Last := P + 1;
            return;
         end if;
         V := V and 16#07F#;
         Value := Interfaces.Shift_Left (Interfaces.Unsigned_64 (V), Shift) or Value;
         P := P + 1;
         Shift := Shift + 7;
      end loop;
   end Decode_LEB128;

   --  ------------------------------
   --  Create the encoder object for the specified algorithm.
   --  ------------------------------
   function Create (Name : String) return Encoder is
   begin
      if Name = BASE_16 or Name = HEX then
         return E : Encoder do
            E.Encode := new Util.Encoders.Base16.Encoder;
         end return;

      elsif Name = BASE_64 then
         return E : Encoder do
            E.Encode := new Util.Encoders.Base64.Encoder;
         end return;

      elsif Name = BASE_64_URL then
         return E : Encoder do
            E.Encode := Util.Encoders.Base64.Create_URL_Encoder;
         end return;

      elsif Name = HASH_SHA1 then
         return E : Encoder do
            E.Encode := new Util.Encoders.SHA1.Encoder;
         end return;
      end if;
      raise Not_Supported with "Invalid encoder: " & Name;
   end Create;

   --  ------------------------------
   --  Create the encoder object for the specified algorithm.
   --  ------------------------------
   function Create (Name : String) return Decoder is
   begin
      if Name = BASE_16 or Name = HEX then
         return E : Decoder do
            E.Decode := new Util.Encoders.Base16.Decoder;
         end return;

      elsif Name = BASE_64 then
         return E : Decoder do
            E.Decode := new Util.Encoders.Base64.Decoder;
         end return;

      elsif Name = BASE_64_URL then
         return E : Decoder do
            E.Decode := Util.Encoders.Base64.Create_URL_Decoder;
         end return;

      elsif Name = HASH_SHA1 then
         return E : Decoder do
            E.Decode := new Util.Encoders.Base64.Decoder;
         end return;
      end if;
      raise Not_Supported with "Invalid encoder: " & Name;
   end Create;

   --  ------------------------------
   --  Delete the transformers
   --  ------------------------------
   overriding
   procedure Finalize (E : in out Encoder) is

   begin
      Free (E.Encode);
   end Finalize;

   --  ------------------------------
   --  Delete the transformers
   --  ------------------------------
   overriding
   procedure Finalize (E : in out Decoder) is
   begin
      Free (E.Decode);
   end Finalize;

end Util.Encoders;

Refactor the encoders - Update the Decode function to use the Decoder type - Implement the Create function for the Decoder - Implement the Finalize procedure for the Decoder


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

with Ada.IO_Exceptions;

with ASF.Beans;

with ADO.Drivers;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
package body AWA.Applications is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Applications.Configs");

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
   begin
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      Application'Class (App).Initialize_Modules;
      App.Load_Configuration;
   end Initialize;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
   end Initialize_Components;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      declare
         DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
      begin
         App.Events.Initialize (DB);
      end;
      AWA.Modules.Initialize (App.Modules, Conf);

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Load_Configuration (App : in out Application) is
      Paths : constant String := App.Get_Config (P_Module_Dir.P);
      Base  : constant String := App.Get_Config (P_Config_File.P);
      Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      Ctx   : aliased EL.Contexts.Default.Default_Context;
   begin
      AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access);

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Warn ("Application configuration file '{0}' does not exist", Path);
   end Load_Configuration;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (App : Application)
                         return ADO.Sessions.Session is
   begin
      return App.DB_Factory.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (App : Application)
                                return ADO.Sessions.Master_Session is
   begin
      return App.DB_Factory.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
--        procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
--        procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory) is
--        begin
--           Module.Register_Factory (Factory);
--        end Set_Beans;
--
--        procedure Register_Beans is
--           new ASF.Applications.Main.Register_Beans (Set_Beans);
   begin
      --  Module.Initialize ();
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);

--        Register_Beans (App);
--        App.View.Register_Module (Module);  SCz: 2011-08-10: must check if necessary
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

end AWA.Applications;

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

with Ada.IO_Exceptions;

with ADO.Drivers;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
package body AWA.Applications is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Applications.Configs");

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
   begin
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      Application'Class (App).Initialize_Modules;
      App.Load_Configuration;
   end Initialize;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
   end Initialize_Components;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
   begin
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      declare
         DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
      begin
         App.Events.Initialize (DB);
      end;
      AWA.Modules.Initialize (App.Modules, Conf);

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Load_Configuration (App : in out Application) is
      Paths : constant String := App.Get_Config (P_Module_Dir.P);
      Base  : constant String := App.Get_Config (P_Config_File.P);
      Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      Ctx   : aliased EL.Contexts.Default.Default_Context;
   begin
      AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access);

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Warn ("Application configuration file '{0}' does not exist", Path);
   end Load_Configuration;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (App : Application)
                         return ADO.Sessions.Session is
   begin
      return App.DB_Factory.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (App : Application)
                                return ADO.Sessions.Master_Session is
   begin
      return App.DB_Factory.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

end AWA.Applications;

Remove unused commented code

Remove unused commented code