-----------------------------------------------------------------------
--  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 Bfd.Sections;
with ELF;
with Util.Log.Loggers;

package body MAT.Symbols.Targets is

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

   --  ------------------------------
   --  Open the binary and load the symbols from that file.
   --  ------------------------------
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String) is
   begin
      Log.Info ("Loading symbols from {0}", Path);

      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  Load the symbol table for the associated region.
   --  ------------------------------
   procedure Open (Symbols : in out Region_Symbols;
                   Path    : in String) is
   begin
      Log.Info ("Loading symbols from {0}", Path);

      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  Load the symbols associated with a shared library described by the memory region.
   --  ------------------------------
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Region      : in MAT.Memory.Region_Info;
                           Offset_Addr : in MAT.Types.Target_Addr) is
      Pos  : constant Symbols_Cursor := Symbols.Libraries.Find (Region.Start_Addr);
      Syms : Region_Symbols_Ref;
   begin
      if not Symbols_Maps.Has_Element (Pos) then
         Syms := Region_Symbols_Refs.Create;
         Syms.Value.Region := Region;
         Syms.Value.Offset := Offset_Addr;
         Symbols.Libraries.Insert (Region.Start_Addr, Syms);
      else
         Syms := Symbols_Maps.Element (Pos);
      end if;
      if Ada.Strings.Unbounded.Length (Region.Path) > 0 then
         Open (Syms.Value.all, Ada.Strings.Unbounded.To_String (Region.Path));
      end if;
   end Load_Symbols;

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

      Iter    : MAT.Memory.Region_Info_Cursor := Regions.First;
   begin
      while MAT.Memory.Region_Info_Maps.Has_Element (Iter) loop
         declare
            Region : MAT.Memory.Region_Info := MAT.Memory.Region_Info_Maps.Element (Iter);
            Offset : MAT.Types.Target_Addr;
         begin
            if (Region.Flags and ELF.PF_X) /= 0 then
               if Ada.Strings.Unbounded.Length (Region.Path) = 0 then
                  Region.Path := Symbols.Path;
                  Offset := 0;
               else
                  Offset := Region.Start_Addr;
               end if;
               MAT.Symbols.Targets.Load_Symbols (Symbols, Region, Offset);
            end if;

         exception
            when Bfd.OPEN_ERROR =>
               Symbols.Console.Error ("Cannot open symbol library file '"
                                      & Ada.Strings.Unbounded.To_String (Region.Path) & "'");
         end;
         MAT.Memory.Region_Info_Maps.Next (Iter);
      end loop;
   end Load_Symbols;

   --  ------------------------------
   --  Demangle the symbol.
   --  ------------------------------
   procedure Demangle (Symbols : in Target_Symbols;
                       Symbol  : in out Symbol_Info) is
      use type Bfd.Demangle_Flags;
      use Ada.Strings.Unbounded;

      Pos : constant Natural := Index (Symbol.File, ".", Ada.Strings.Backward);
   begin
      if Symbol.Line = 0 or else Pos = 0 or else Symbol.Symbols.Is_Null then
         return;
      end if;
      declare
         Mode : Bfd.Demangle_Flags := Symbols.Demangle;
         Len  : constant Positive := Length (Symbol.File);
         Ext  : constant String := Slice (Symbol.File, Pos, Len);
         Sym  : constant String := To_String (Symbol.Name);
      begin
         if Mode = Bfd.Constants.DMGL_AUTO and then Ext = ".adb" then
            Mode := Bfd.Constants.DMGL_GNAT;
         end if;
         declare
            Name : constant String := Bfd.Symbols.Demangle (Symbol.Symbols.Value.File, Sym, Mode);
         begin
            if Name'Length > 0 then
               Symbol.Name := To_Unbounded_String (Name);
            end if;
         end;
      end;
   end Demangle;

   procedure Find_Nearest_Line (Symbols : in Region_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Symbol  : out Symbol_Info) is
      use type Bfd.Vma_Type;

      Text_Section : Bfd.Sections.Section;
      Pc : constant Bfd.Vma_Type := Bfd.Vma_Type (Addr);
   begin
      if not Bfd.Files.Is_Open (Symbols.File) then
         Symbol.File := Symbols.Region.Path;
         return;
      end if;
      Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
      Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                     Sec     => Text_Section,
                                     Symbols => Symbols.Symbols,
                                     Addr    => Pc,
                                     Name    => Symbol.File,
                                     Func    => Symbol.Name,
                                     Line    => Symbol.Line);
   end Find_Nearest_Line;

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

      Pos  : constant Symbols_Cursor := Symbols.Libraries.Floor (Addr);
      Text_Section : Bfd.Sections.Section;
   begin
      Symbol.Line := 0;
      if Symbols_Maps.Has_Element (Pos) then
         declare
            Syms : constant Region_Symbols_Ref := Symbols_Maps.Element (Pos);
         begin
            if Syms.Value.Region.End_Addr > Addr then
               Symbol.Symbols := Syms;
               Find_Nearest_Line (Symbols => Syms.Value.all,
                                  Addr    => Addr - Syms.Value.Offset,
                                  Symbol  => Symbol);
               Demangle (Symbols, Symbol);
               return;
            end if;
         end;
      end if;
      if Bfd.Files.Is_Open (Symbols.File) then
         Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
         Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                        Sec     => Text_Section,
                                        Symbols => Symbols.Symbols,
                                        Addr    => Bfd.Vma_Type (Addr),
                                        Name    => Symbol.File,
                                        Func    => Symbol.Name,
                                        Line    => Symbol.Line);
         Demangle (Symbols, Symbol);
      else
         Symbol.Line := 0;
         Symbol.File := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Symbol.Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
      end if;

   exception
      when Bfd.NOT_FOUND =>
         Symbol.Line := 0;
         Symbol.File := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Symbol.Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
   end Find_Nearest_Line;

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 Bfd.Sections;
with ELF;
with Util.Log.Loggers;

package body MAT.Symbols.Targets is

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

   --  ------------------------------
   --  Open the binary and load the symbols from that file.
   --  ------------------------------
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String) is
   begin
      Log.Info ("Loading symbols from {0}", Path);

      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  Load the symbol table for the associated region.
   --  ------------------------------
   procedure Open (Symbols : in out Region_Symbols;
                   Path    : in String) is
   begin
      Log.Info ("Loading symbols from {0}", Path);

      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  Load the symbols associated with a shared library described by the memory region.
   --  ------------------------------
   procedure Load_Symbols (Symbols     : in out Target_Symbols;
                           Region      : in MAT.Memory.Region_Info;
                           Offset_Addr : in MAT.Types.Target_Addr) is
      Pos  : constant Symbols_Cursor := Symbols.Libraries.Find (Region.Start_Addr);
      Syms : Region_Symbols_Ref;
   begin
      if not Symbols_Maps.Has_Element (Pos) then
         Syms := Region_Symbols_Refs.Create;
         Syms.Value.Region := Region;
         Syms.Value.Offset := Offset_Addr;
         Symbols.Libraries.Insert (Region.Start_Addr, Syms);
      else
         Syms := Symbols_Maps.Element (Pos);
      end if;
      if Ada.Strings.Unbounded.Length (Region.Path) > 0 then
         Open (Syms.Value.all, Ada.Strings.Unbounded.To_String (Region.Path));
      end if;
   end Load_Symbols;

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

      Iter    : MAT.Memory.Region_Info_Cursor := Regions.First;
   begin
      while MAT.Memory.Region_Info_Maps.Has_Element (Iter) loop
         declare
            Region : MAT.Memory.Region_Info := MAT.Memory.Region_Info_Maps.Element (Iter);
            Offset : MAT.Types.Target_Addr;
         begin
            if (Region.Flags and ELF.PF_X) /= 0 then
               if Ada.Strings.Unbounded.Length (Region.Path) = 0 then
                  Region.Path := Symbols.Path;
                  Offset := 0;
               else
                  Offset := Region.Start_Addr;
               end if;
               MAT.Symbols.Targets.Load_Symbols (Symbols, Region, Offset);
            end if;

         exception
            when Bfd.OPEN_ERROR =>
               Symbols.Console.Error ("Cannot open symbol library file '"
                                      & Ada.Strings.Unbounded.To_String (Region.Path) & "'");
         end;
         MAT.Memory.Region_Info_Maps.Next (Iter);
      end loop;
   end Load_Symbols;

   --  ------------------------------
   --  Demangle the symbol.
   --  ------------------------------
   procedure Demangle (Symbols : in Target_Symbols;
                       Symbol  : in out Symbol_Info) is
      use type Bfd.Demangle_Flags;
      use Ada.Strings.Unbounded;

      Pos : constant Natural := Index (Symbol.File, ".", Ada.Strings.Backward);
   begin
      if Symbol.Line = 0 or else Pos = 0 or else Symbol.Symbols.Is_Null then
         return;
      end if;
      declare
         Mode : Bfd.Demangle_Flags := Symbols.Demangle;
         Len  : constant Positive := Length (Symbol.File);
         Ext  : constant String := Slice (Symbol.File, Pos, Len);
         Sym  : constant String := To_String (Symbol.Name);
      begin
         if Mode = Bfd.Constants.DMGL_AUTO and then Ext = ".adb" then
            Mode := Bfd.Constants.DMGL_GNAT;
         end if;
         declare
            Name : constant String := Bfd.Symbols.Demangle (Symbol.Symbols.Value.File, Sym, Mode);
         begin
            if Name'Length > 0 then
               Symbol.Name := To_Unbounded_String (Name);
            end if;
         end;
      end;
   end Demangle;

   procedure Find_Nearest_Line (Symbols : in Region_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Symbol  : out Symbol_Info) is
      use type Bfd.Vma_Type;

      Text_Section : Bfd.Sections.Section;
      Pc : constant Bfd.Vma_Type := Bfd.Vma_Type (Addr);
   begin
      if not Bfd.Files.Is_Open (Symbols.File) then
         Symbol.File := Symbols.Region.Path;
         return;
      end if;
      Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
      Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                     Sec     => Text_Section,
                                     Symbols => Symbols.Symbols,
                                     Addr    => Pc,
                                     Name    => Symbol.File,
                                     Func    => Symbol.Name,
                                     Line    => Symbol.Line);
   end Find_Nearest_Line;

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

      Pos  : constant Symbols_Cursor := Symbols.Libraries.Floor (Addr);
      Text_Section : Bfd.Sections.Section;
   begin
      Symbol.Line := 0;
      if Symbols_Maps.Has_Element (Pos) then
         declare
            Syms : constant Region_Symbols_Ref := Symbols_Maps.Element (Pos);
         begin
            if Syms.Value.Region.End_Addr > Addr then
               Symbol.Symbols := Syms;
               Find_Nearest_Line (Symbols => Syms.Value.all,
                                  Addr    => Addr - Syms.Value.Offset,
                                  Symbol  => Symbol);
               Demangle (Symbols, Symbol);
               return;
            end if;
         end;
      end if;
      if Bfd.Files.Is_Open (Symbols.File) then
         Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
         Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                        Sec     => Text_Section,
                                        Symbols => Symbols.Symbols,
                                        Addr    => Bfd.Vma_Type (Addr),
                                        Name    => Symbol.File,
                                        Func    => Symbol.Name,
                                        Line    => Symbol.Line);
         Demangle (Symbols, Symbol);
      else
         Symbol.Line := 0;
         Symbol.File := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Symbol.Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
      end if;

   exception
      when Bfd.NOT_FOUND =>
         Symbol.Line := 0;
         Symbol.File := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Symbol.Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
   end Find_Nearest_Line;

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

      Iter  : Symbols_Cursor := Symbols.Libraries.First;
   begin
      while Symbols_Maps.Has_Element (Iter) loop
         declare
            Syms : constant Region_Symbols_Ref := Symbols_Maps.Element (Iter);
            Sym  : Bfd.Symbols.Symbol;
         begin
            if not Syms.Is_Null and then Bfd.Files.Is_Open (Syms.Value.File) then
               Sym := Bfd.Symbols.Get_Symbol (Syms.Value.Symbols, Name);
               if Sym /= Bfd.Symbols.Null_Symbol then
                  From := MAT.Types.Target_Addr (Bfd.Symbols.Get_Value (Sym));
                  From := From + Syms.Value.Offset;
                  To := From + MAT.Types.Target_Addr (Bfd.Symbols.Get_Symbol_Size (Sym));
                  return;
               end if;
            end if;
         end;
         Symbols_Maps.Next (Iter);
      end loop;
   end Find_Symbol_Range;

end MAT.Symbols.Targets;

Implement the Find_Symbol_Range procedure to lookup in every symbol table for a symbol


-----------------------------------------------------------------------
--  Writer Tests - Unit tests for ASF.Contexts.Writer
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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.
-----------------------------------------------------------------------

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with Util.Test_Caller;
package body ASF.Contexts.Writer.Tests is

   use Util.Tests;

   procedure Free_Writer is
     new Ada.Unchecked_Deallocation (Object => Test_Writer'Class,
                                     Name   => Test_Writer_Access);

   procedure Initialize (Stream       : in out Test_Writer;
                         Content_Type : in String;
                         Encoding     : in String;
                         Size         : in Natural) is
      Output : ASF.Streams.Print_Stream;
   begin
      Stream.Content.Initialize (Size => Size);
      Output.Initialize (Stream.Content'Unchecked_Access);
      Stream.Initialize (Content_Type, Encoding, Output);
   end Initialize;

   overriding
   procedure Write (Stream : in out Test_Writer;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      for I in Buffer'Range loop
         Append (Stream.Response, Character'Val (Buffer (I)));
      end loop;
   end Write;

   overriding
   procedure Flush (Stream : in out Test_Writer) is
   begin
      Response_Writer (Stream).Flush;
      Stream.Content.Flush (Into => Stream.Response);
   end Flush;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Writer := new Test_Writer;
      --  use a small buffer to test the flush
      T.Writer.Initialize ("text/xml", "UTF-8", 1024);
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      Free_Writer (T.Writer);
   end Tear_Down;

   --  Test the Start/Write/End_Element methods
   procedure Test_Write_Element (T : in out Test) is
   begin
      T.Writer.Start_Element ("p");
      T.Writer.Start_Element ("b");
      T.Writer.Write_Element ("i", "italic within a bold");
      T.Writer.End_Element ("b");
      T.Writer.End_Element ("p");
      T.Writer.Flush;

      Assert_Equals (T, "
italic within a bold
",
                     T.Writer.Response);

      T.Writer.Response := To_Unbounded_String ("");
      T.Writer.Start_Element ("div");
      T.Writer.Write_Attribute ("title", "A ""S&'%^&<>");
      T.Writer.Write_Attribute ("id", "23");
      T.Writer.End_Element ("div");
      T.Writer.Flush;

      Assert_Equals (T, "

",
                     T.Writer.Response);
   end Test_Write_Element;

   --  Test the Write_Char/Text methods
   procedure Test_Write_Text (T : in out Test) is
      use Ada.Calendar;
      Start : Ada.Calendar.Time;
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      T.Writer.Start_Element ("p");
      T.Writer.Write_Char ('<');
      T.Writer.Write_Char ('>');
      T.Writer.Write_Char ('~');
      T.Writer.Start_Element ("i");
      T.Writer.Write_Text ("""A' <>&");
      T.Writer.End_Element ("i");
      T.Writer.End_Element ("p");
      T.Writer.Flush;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Write text: " & Duration'Image (D));

      Assert_Equals (T, "
<>~""A' <>&
",
                     T.Writer.Response);
   end Test_Write_Text;

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

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Start_Element",
                       Test_Write_Element'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.End_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Attribute",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Text",
                       Test_Write_Text'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Char",
                       Test_Write_Text'Access);
   end Add_Tests;

end ASF.Contexts.Writer.Tests;

-----------------------------------------------------------------------
--  Writer Tests - Unit tests for ASF.Contexts.Writer
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2018, 2020 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.Text_IO;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with Util.Test_Caller;
package body ASF.Contexts.Writer.Tests is

   use Util.Tests;

   procedure Free_Writer is
     new Ada.Unchecked_Deallocation (Object => Test_Writer'Class,
                                     Name   => Test_Writer_Access);

   procedure Initialize (Stream       : in out Test_Writer;
                         Content_Type : in String;
                         Encoding     : in String;
                         Size         : in Natural) is
      Output : ASF.Streams.Print_Stream;
   begin
      Stream.Content.Initialize (Size => Size);
      Output.Initialize (Stream.Content'Unchecked_Access);
      Stream.Initialize (Content_Type, Encoding, Output);
   end Initialize;

   overriding
   procedure Write (Stream : in out Test_Writer;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      for I in Buffer'Range loop
         Append (Stream.Response, Character'Val (Buffer (I)));
      end loop;
   end Write;

   overriding
   procedure Flush (Stream : in out Test_Writer) is
   begin
      Response_Writer (Stream).Flush;
      Stream.Content.Flush (Into => Stream.Response);
   end Flush;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Writer := new Test_Writer;
      --  use a small buffer to test the flush
      T.Writer.Initialize ("text/xml", "UTF-8", 1024);
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      Free_Writer (T.Writer);
   end Tear_Down;

   --  Test the Start/Write/End_Element methods
   procedure Test_Write_Element (T : in out Test) is
   begin
      T.Writer.Start_Element ("p");
      T.Writer.Start_Element ("b");
      T.Writer.Write_Element ("i", "italic within a bold");
      T.Writer.End_Element ("b");
      T.Writer.End_Element ("p");
      --  T.Writer.Flush;

      Assert_Equals (T, "
italic within a bold
",
                     T.Writer.Response);

      T.Writer.Response := To_Unbounded_String ("");
      T.Writer.Start_Element ("div");
      T.Writer.Write_Attribute ("title", "A ""S&'%^&<>");
      T.Writer.Write_Attribute ("id", "23");
      T.Writer.End_Element ("div");
      --  T.Writer.Flush;

      Assert_Equals (T, "

",
                     T.Writer.Response);
   end Test_Write_Element;

   --  Test the Write_Char/Text methods
   procedure Test_Write_Text (T : in out Test) is
      use Ada.Calendar;
      Start : Ada.Calendar.Time;
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      T.Writer.Start_Element ("p");
      T.Writer.Write_Char ('<');
      T.Writer.Write_Char ('>');
      T.Writer.Write_Char ('~');
      T.Writer.Start_Element ("i");
      T.Writer.Write_Text ("""A' <>&");
      T.Writer.End_Element ("i");
      T.Writer.End_Element ("p");
      --  T.Writer.Flush;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Write text: " & Duration'Image (D));

      Assert_Equals (T, "
<>~""A' <>&
",
                     T.Writer.Response);
   end Test_Write_Text;

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

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Start_Element",
                       Test_Write_Element'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.End_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Attribute",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Text",
                       Test_Write_Text'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Char",
                       Test_Write_Text'Access);
   end Add_Tests;

end ASF.Contexts.Writer.Tests;

Update the unit test

Update the unit test


-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014, 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 Util.Listeners;

with Babel.Files;
with Babel.Files.Queues;
with Babel.Files.Buffers;
with Babel.Streams.Refs;
with Babel.Stores;
with Babel.Filters;
with Babel.Base;
with Babel.Base.Text;
package Babel.Strategies is

   type Strategy_Type is abstract tagged limited private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   procedure Peek_Directory (Strategy  : in out Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is abstract;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class);

   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Stream   : in out Babel.Streams.Refs.Stream_Ref);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Stream   : in Babel.Streams.Refs.Stream_Ref);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in out Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Stream   : in Babel.Streams.Refs.Stream_Ref);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

   --  Set the listeners to inform about changes.
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List);

   --  Set the database for use by the strategy.
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access);

private

   type Strategy_Type is abstract tagged limited record
      Read_Store  : Babel.Stores.Store_Type_Access;
      Write_Store : Babel.Stores.Store_Type_Access;
      Filters     : Babel.Filters.Filter_Type_Access;
      Buffers     : Babel.Files.Buffers.Buffer_Pool_Access;
      Listeners   : access Util.Listeners.List;
      --        Database    : Babel.Base.Database_Access;
      Database    : Babel.Base.Text.Text_Database;
   end record;

end Babel.Strategies;

-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014, 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 Util.Listeners;

with Babel.Files;
with Babel.Files.Queues;
with Babel.Files.Buffers;
with Babel.Streams.Refs;
with Babel.Stores;
with Babel.Filters;
with Babel.Base;
with Babel.Base.Text;
package Babel.Strategies is

   type Strategy_Type is abstract tagged limited private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   procedure Peek_Directory (Strategy  : in out Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is abstract;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class);

   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Stream   : in out Babel.Streams.Refs.Stream_Ref);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Stream   : in Babel.Streams.Refs.Stream_Ref);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in out Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Stream   : in Babel.Streams.Refs.Stream_Ref);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

   --  Set the listeners to inform about changes.
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List);

   --  Set the database for use by the strategy.
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access);

private

   type Strategy_Type is abstract tagged limited record
      Read_Store    : Babel.Stores.Store_Type_Access;
      Write_Store   : Babel.Stores.Store_Type_Access;
      Filters       : Babel.Filters.Filter_Type_Access;
      Buffers       : Babel.Files.Buffers.Buffer_Pool_Access;
      Listeners     : access Util.Listeners.List;
      Database      : Babel.Base.Text.Text_Database;
   end record;

end Babel.Strategies;

Fix presentation style

Fix presentation style


-----------------------------------------------------------------------
--  gen-model-tables -- Database table model representation
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number   : Natural := 0;
      Table    : Table_Definition_Access;
      Bean     : Util.Beans.Objects.Object;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type  : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name   : Unbounded_String;

      --  The SQL length for strings.
      Sql_Length : Positive := 255;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique    : Boolean := False;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the column is auditable (generate code to track changes).
      Is_Auditable : Boolean := False;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_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 : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_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 : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   package Table_Vectors is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Table_Definition_Access);
   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Parent_Name    : Unbounded_String;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;
      Has_Associations : Boolean := False;

      --  The list of tables that this table depends on.
      Dependencies     : Table_Vectors.Vector;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;

      --  Mark flag used by the dependency calculation.
      Has_Mark         : Boolean := False;

      --  Whether the bean type is a limited type or not.
      Is_Limited       : Boolean := False;

      --  Whether the serialization operation have to be generated.
      Is_Serializable  : Boolean := False;
   end record;

   --  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 : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

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

   --  Collect the dependencies to other tables.
   procedure Collect_Dependencies (O : in out Table_Definition);

   type Dependency_Type is (NONE, FORWARD, BACKWARD);  -- CIRCULAR is not yet managed.

   --  Get the dependency between the two tables.
   --  Returns NONE if both table don't depend on each other.
   --  Returns FORWARD if the <tt>Left</tt> table depends on <tt>Right</tt>.
   --  Returns BACKWARD if the <tt>Right</tt> table depends on <tt>Left</tt>.
   function Depends_On (Left, Right : in Table_Definition_Access) return Dependency_Type;

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Create an operation with the given name and add it to the table.
   procedure Add_Operation (Table     : in out Table_Definition;
                            Name      : in Unbounded_String;
                            Operation : out Model.Operations.Operation_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

   package Table_List is new Gen.Model.List (T        => Definition,
                                             T_Access => Definition_Access);

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

-----------------------------------------------------------------------
--  gen-model-tables -- Database table model representation
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number   : Natural := 0;
      Table    : Table_Definition_Access;
      Bean     : Util.Beans.Objects.Object;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type  : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name   : Unbounded_String;

      --  The SQL length for strings.
      Sql_Length : Positive := 255;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique    : Boolean := False;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the column is auditable (generate code to track changes).
      Is_Auditable : Boolean := False;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_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 : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_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 : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   package Table_Vectors is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Table_Definition_Access);
   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Parent_Name    : Unbounded_String;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;

      --  The number of <<PK>> columns found.
      Key_Count        : Natural := 0;
      Has_Associations : Boolean := False;

      --  The list of tables that this table depends on.
      Dependencies     : Table_Vectors.Vector;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;

      --  Mark flag used by the dependency calculation.
      Has_Mark         : Boolean := False;

      --  Whether the bean type is a limited type or not.
      Is_Limited       : Boolean := False;

      --  Whether the serialization operation have to be generated.
      Is_Serializable  : Boolean := False;
   end record;

   --  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 : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

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

   --  Collect the dependencies to other tables.
   procedure Collect_Dependencies (O : in out Table_Definition);

   type Dependency_Type is (NONE, FORWARD, BACKWARD);  -- CIRCULAR is not yet managed.

   --  Get the dependency between the two tables.
   --  Returns NONE if both table don't depend on each other.
   --  Returns FORWARD if the <tt>Left</tt> table depends on <tt>Right</tt>.
   --  Returns BACKWARD if the <tt>Right</tt> table depends on <tt>Left</tt>.
   function Depends_On (Left, Right : in Table_Definition_Access) return Dependency_Type;

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Create an operation with the given name and add it to the table.
   procedure Add_Operation (Table     : in out Table_Definition;
                            Name      : in Unbounded_String;
                            Operation : out Model.Operations.Operation_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

   package Table_List is new Gen.Model.List (T        => Definition,
                                             T_Access => Definition_Access);

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

Add a Key_Count member to the table to count the number of <<PK>> columns in the table


-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Bfd.Sections;
package body MAT.Symbols.Targets is

   --  ------------------------------
   --  Open the binary and load the symbols from that file.
   --  ------------------------------
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String) is
   begin
      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  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) is
      Text_Section : Bfd.Sections.Section;
   begin
      Line := 0;
      if Bfd.Files.Is_Open (Symbols.File) then
         Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
         Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                        Sec     => Text_Section,
                                        Symbols => Symbols.Symbols,
                                        Addr    => Bfd.Vma_Type (Addr),
                                        Name    => Name,
                                        Func    => Func,
                                        Line    => Line);
      else
         Line := 0;
         Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Func := Ada.Strings.Unbounded.To_Unbounded_String ("");
      end if;

   exception
      when Bfd.NOT_FOUND =>
         Line := 0;
         Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Func := Ada.Strings.Unbounded.To_Unbounded_String ("");
   end Find_Nearest_Line;

end MAT.Symbols.Targets;

-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Bfd.Sections;
package body MAT.Symbols.Targets is

   --  ------------------------------
   --  Open the binary and load the symbols from that file.
   --  ------------------------------
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String) is
   begin
      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   procedure Open (Symbols : in out Library_Symbols;
                   Path    : in String) is
   begin
      Bfd.Files.Open (Symbols.File, Path, "");
      if Bfd.Files.Check_Format (Symbols.File, Bfd.Files.OBJECT) then
         Bfd.Symbols.Read_Symbols (Symbols.File, Symbols.Symbols);
      end if;
   end Open;

   --  ------------------------------
   --  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) is
      Pos  : constant Symbols_Cursor := Symbols.Libraries.Find (Region.Start_Addr);
      Syms : Library_Symbols_Ref;
   begin
      if not Symbols_Maps.Has_Element (Pos) then
         Syms := Library_Symbols_Refs.Create;
         Syms.Value.Text_Addr := Region.Start_Addr;
         Symbols.Libraries.Insert (Region.Start_Addr, Syms);
      else
         Syms := Symbols_Maps.Element (Pos);
      end if;
      Open (Syms.Value.all, Ada.Strings.Unbounded.To_String (Region.Path));
   end Load_Symbols;

   --  ------------------------------
   --  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) is
      Text_Section : Bfd.Sections.Section;
   begin
      Line := 0;
      if Bfd.Files.Is_Open (Symbols.File) then
         Text_Section := Bfd.Sections.Find_Section (Symbols.File, ".text");
         Bfd.Symbols.Find_Nearest_Line (File    => Symbols.File,
                                        Sec     => Text_Section,
                                        Symbols => Symbols.Symbols,
                                        Addr    => Bfd.Vma_Type (Addr),
                                        Name    => Name,
                                        Func    => Func,
                                        Line    => Line);
      else
         Line := 0;
         Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Func := Ada.Strings.Unbounded.To_Unbounded_String ("");
      end if;

   exception
      when Bfd.NOT_FOUND =>
         Line := 0;
         Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
         Func := Ada.Strings.Unbounded.To_Unbounded_String ("");
   end Find_Nearest_Line;

end MAT.Symbols.Targets;

Implement the Load_Symbols procedure to load and insert the shared library symbols in the Target_Symbols object


-----------------------------------------------------------------------
--  mat-targets-readers - Definition and Analysis of process start events
--  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 MAT.Events;
with MAT.Readers;
package MAT.Targets.Readers is

   type Process_Servant is new MAT.Readers.Reader_Base with record
      Target  : Target_Type_Access;
      Reader  : MAT.Readers.Manager;
      Process : Target_Process_Type_Access;
   end record;
   type Process_Reader_Access is access all Process_Servant'Class;

   --  Create a new process after the begin event is received from the event stream.
   procedure Create_Process (For_Servant : in out Process_Servant;
                             Pid         : in MAT.Types.Target_Process_Ref);

   overriding
   procedure Dispatch (For_Servant : in out Process_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out MAT.Readers.Message);

   --  Register the reader to extract and analyze process events.
   procedure Register (Into   : in out MAT.Readers.Manager_Base'Class;
                       Reader : in Process_Reader_Access);

   --  Initialize the target object to prepare for reading process events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

private

   procedure Probe_Begin (For_Servant : in out Process_Servant;
                          Id          : in MAT.Events.Internal_Reference;
                          Defs        : in MAT.Events.Attribute_Table;
                          Frame       : in MAT.Events.Frame_Info;
                          Msg         : in out MAT.Readers.Message);

end MAT.Targets.Readers;

-----------------------------------------------------------------------
--  mat-targets-readers - Definition and Analysis of process start events
--  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 MAT.Events;
with MAT.Readers;
package MAT.Targets.Readers is

   type Process_Servant is new MAT.Readers.Reader_Base with record
      Target  : Target_Type_Access;
      Reader  : MAT.Readers.Manager;
      Process : Target_Process_Type_Access;
   end record;
   type Process_Reader_Access is access all Process_Servant'Class;

   --  Create a new process after the begin event is received from the event stream.
   procedure Create_Process (For_Servant : in out Process_Servant;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Dispatch (For_Servant : in out Process_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out MAT.Readers.Message);

   --  Register the reader to extract and analyze process events.
   procedure Register (Into   : in out MAT.Readers.Manager_Base'Class;
                       Reader : in Process_Reader_Access);

   --  Initialize the target object to prepare for reading process events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

private

   procedure Probe_Begin (For_Servant : in out Process_Servant;
                          Id          : in MAT.Events.Internal_Reference;
                          Defs        : in MAT.Events.Attribute_Table;
                          Frame       : in MAT.Events.Frame_Info;
                          Msg         : in out MAT.Readers.Message);

end MAT.Targets.Readers;

Add the Path parameter in the Create_Process procedure


-----------------------------------------------------------------------
--  Logs -- Utility Log Package
--  Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
--  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.Exceptions;
with Ada.Strings.Unbounded;

with Util.Log.Appenders;
with Util.Properties;
with Ada.Finalization;
package Util.Log.Loggers is

   use Ada.Exceptions;
   use Ada.Strings.Unbounded;

   --  The logger identifies and configures the log produced
   --  by a component that uses it.  The logger has a name
   --  which can be printed in the log outputs.  The logger instance
   --  contains a log level which can be used to control the level of
   --  logs.
   type Logger is tagged limited private;

   --  Create a logger with the given name.
   function Create (Name : in String) return Logger;

   --  Create a logger with the given name and use the specified level.
   function Create (Name  : in String;
                    Level : in Level_Type) return Logger;

   --  Initialize the logger and create a logger with the given name.
   function Create (Name   : in String;
                    Config : in String) return Logger;

   --  Change the log level
   procedure Set_Level (Log   : in out Logger;
                        Level : in Level_Type);

   --  Get the log level.
   function Get_Level (Log : in Logger) return Level_Type;

   --  Get the log level name.
   function Get_Level_Name (Log : in Logger) return String;

   procedure Print (Log     : in Logger;
                    Level   : in Level_Type;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in Unbounded_String;
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in Unbounded_String;
                    Arg2    : in Unbounded_String;
                    Arg3    : in String := "");

   procedure Info (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Info (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in Unbounded_String;
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Warn (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Error (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Error (Log     : in Logger'Class;
                    Message : in String;
                    E       : in Exception_Occurrence);

   --  Set the appender that will handle the log events
   procedure Set_Appender (Log      : in out Logger'Class;
                           Appender : in Util.Log.Appenders.Appender_Access);

   --  Initialize the log environment with the property file.
   procedure Initialize (Name : in String);

   --  Initialize the log environment with the properties.
   procedure Initialize (Properties : in Util.Properties.Manager);

private

   type Logger_Info;
   type Logger_Info_Access is access all Logger_Info;

   type Logger_Info is record
      Next_Logger : Logger_Info_Access;
      Prev_Logger : Logger_Info_Access;
      Level       : Level_Type := INFO_LEVEL;
      Name        : Unbounded_String;
      Appender    : Util.Log.Appenders.Appender_Access;
   end record;

   type Logger is new Ada.Finalization.Limited_Controlled with record
      Name     : Unbounded_String;
      Instance : Logger_Info_Access;
   end record;

   --  Finalize the logger and flush the associated appender
   procedure Finalize (Log : in out Logger);

end Util.Log.Loggers;

-----------------------------------------------------------------------
--  Logs -- Utility Log Package
--  Copyright (C) 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
--  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.Exceptions;
with Ada.Strings.Unbounded;

with Util.Log.Appenders;
with Util.Properties;
with Ada.Finalization;
package Util.Log.Loggers is

   use Ada.Exceptions;
   use Ada.Strings.Unbounded;

   --  The logger identifies and configures the log produced
   --  by a component that uses it.  The logger has a name
   --  which can be printed in the log outputs.  The logger instance
   --  contains a log level which can be used to control the level of
   --  logs.
   type Logger is tagged limited private;
   type Logger_Access is access constant Logger'Class;

   --  Create a logger with the given name.
   function Create (Name : in String) return Logger;

   --  Create a logger with the given name and use the specified level.
   function Create (Name  : in String;
                    Level : in Level_Type) return Logger;

   --  Initialize the logger and create a logger with the given name.
   function Create (Name   : in String;
                    Config : in String) return Logger;

   --  Change the log level
   procedure Set_Level (Log   : in out Logger;
                        Level : in Level_Type);

   --  Get the log level.
   function Get_Level (Log : in Logger) return Level_Type;

   --  Get the log level name.
   function Get_Level_Name (Log : in Logger) return String;

   procedure Print (Log     : in Logger;
                    Level   : in Level_Type;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in Unbounded_String;
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Debug (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in Unbounded_String;
                    Arg2    : in Unbounded_String;
                    Arg3    : in String := "");

   procedure Info (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Info (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in Unbounded_String;
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Warn (Log     : in Logger'Class;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   procedure Error (Log     : in Logger'Class;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "";
                    Arg3    : in String := "");

   procedure Error (Log     : in Logger'Class;
                    Message : in String;
                    E       : in Exception_Occurrence);

   --  Set the appender that will handle the log events
   procedure Set_Appender (Log      : in out Logger'Class;
                           Appender : in Util.Log.Appenders.Appender_Access);

   --  Initialize the log environment with the property file.
   procedure Initialize (Name : in String);

   --  Initialize the log environment with the properties.
   procedure Initialize (Properties : in Util.Properties.Manager);

private

   type Logger_Info;
   type Logger_Info_Access is access all Logger_Info;

   type Logger_Info is record
      Next_Logger : Logger_Info_Access;
      Prev_Logger : Logger_Info_Access;
      Level       : Level_Type := INFO_LEVEL;
      Name        : Unbounded_String;
      Appender    : Util.Log.Appenders.Appender_Access;
   end record;

   type Logger is new Ada.Finalization.Limited_Controlled with record
      Name     : Unbounded_String;
      Instance : Logger_Info_Access;
   end record;

   --  Finalize the logger and flush the associated appender
   procedure Finalize (Log : in out Logger);

end Util.Log.Loggers;

Define the Logger_Access type

Define the Logger_Access type


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

with ASF.Sessions;

with Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;
package body ASF.Security.Servlets is

   use Util.Log;

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

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (Openid.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Openid_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  Property name that specifies the OpenID callback URL.
   OPENID_VERIFY_URL      : constant String := "openid.callback_url";

   --  Property name that specifies the realm.
   OPENID_REALM           : constant String := "openid.realm";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   procedure Initialize (Server  : in Openid_Servlet;
                         Manager : in out OpenID.Manager) is
      Ctx          : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Callback_URI : constant String := Ctx.Get_Init_Parameter (OPENID_VERIFY_URL);
      Realm        : constant String := Ctx.Get_Init_Parameter (OPENID_REALM);
   begin
      Manager.Initialize (Return_To => Callback_URI,
                          Name      => Realm);
   end Initialize;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      Ctx  : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return Ctx.Get_Init_Parameter ("openid.provider." & URI (URI'First + 1 .. URI'Last));
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Provider : constant String := Server.Get_Provider_URL (Request);
   begin
      Log.Info ("Request OpenId authentication to {0}", Provider);

      if Provider'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : OpenID.Manager;
         OP    : OpenID.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
      begin
         Server.Initialize (Mgr);

         --  Yadis discovery (get the XRDS file).
         Mgr.Discover (Provider, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      use type OpenID.Auth_Result;

      type Auth_Params is new OpenID.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return Request.Get_Parameter (Name);
      end Get_Parameter;

      Session : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean    : Util.Beans.Objects.Object;
      Mgr     : OpenID.Manager;
      Assoc   : Association_Access;
      Auth    : OpenID.Authentication;
      Params  : Auth_Params;
      Ctx     : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      Log.Info ("Verify openid authentication");

      if not Session.Is_Valid then
         Log.Warn ("Session has expired during OpenID authentication process");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Bean := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Params, Auth);
      if OpenID.Get_Status (Auth) /= OpenID.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", OpenID.Get_Email (Auth));

      --  Get a user principal and set it on the session.
      declare
         User : ASF.Principals.Principal_Access;
         URL  : constant String := Ctx.Get_Init_Parameter ("openid.success_url");
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Auth, User);
         Session.Set_Principal (User);

         Log.Info ("Redirect user to success URL: {0}", URL);
         Response.Send_Redirect (Location => URL);
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in OpenID.Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);

      P : constant OpenID.Principal_Access := OpenID.Create_Principal (Auth);
   begin
      Result := P.all'Access;
   end Create_Principal;

end ASF.Security.Servlets;

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

with ASF.Sessions;

with Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;
package body ASF.Security.Servlets is

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

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (OpenID.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Openid_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  Property name that specifies the OpenID callback URL.
   OPENID_VERIFY_URL      : constant String := "openid.callback_url";

   --  Property name that specifies the realm.
   OPENID_REALM           : constant String := "openid.realm";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   procedure Initialize (Server  : in Openid_Servlet;
                         Manager : in out OpenID.Manager) is
      Ctx          : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Callback_URI : constant String := Ctx.Get_Init_Parameter (OPENID_VERIFY_URL);
      Realm        : constant String := Ctx.Get_Init_Parameter (OPENID_REALM);
   begin
      Manager.Initialize (Return_To => Callback_URI,
                          Name      => Realm);
   end Initialize;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      Ctx  : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return Ctx.Get_Init_Parameter ("openid.provider." & URI (URI'First + 1 .. URI'Last));
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Provider : constant String := Server.Get_Provider_URL (Request);
   begin
      Log.Info ("Request OpenId authentication to {0}", Provider);

      if Provider'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : OpenID.Manager;
         OP    : OpenID.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
      begin
         Server.Initialize (Mgr);

         --  Yadis discovery (get the XRDS file).
         Mgr.Discover (Provider, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      use type OpenID.Auth_Result;

      type Auth_Params is new OpenID.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return Request.Get_Parameter (Name);
      end Get_Parameter;

      Session : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean    : Util.Beans.Objects.Object;
      Mgr     : OpenID.Manager;
      Assoc   : Association_Access;
      Auth    : OpenID.Authentication;
      Params  : Auth_Params;
      Ctx     : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      Log.Info ("Verify openid authentication");

      if not Session.Is_Valid then
         Log.Warn ("Session has expired during OpenID authentication process");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Bean := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Params, Auth);
      if OpenID.Get_Status (Auth) /= OpenID.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", OpenID.Get_Email (Auth));

      --  Get a user principal and set it on the session.
      declare
         User : ASF.Principals.Principal_Access;
         URL  : constant String := Ctx.Get_Init_Parameter ("openid.success_url");
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Auth, User);
         Session.Set_Principal (User);

         Log.Info ("Redirect user to success URL: {0}", URL);
         Response.Send_Redirect (Location => URL);
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in OpenID.Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);

      P : constant OpenID.Principal_Access := OpenID.Create_Principal (Auth);
   begin
      Result := P.all'Access;
   end Create_Principal;

end ASF.Security.Servlets;

Fix compilation warning

Fix compilation warning