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

package body Natools.Smaz_Implementations.Base_256 is

   use type Ada.Streams.Stream_Element;
   use type Ada.Streams.Stream_Element_Offset;

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Ada.Streams.Stream_Element;
      Verbatim_Length : out Natural;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
   is
      Input_Byte : constant Ada.Streams.Stream_Element := Input (Offset);
   begin
      if Input_Byte <= Last_Code then
         Code := Input_Byte;
         Verbatim_Length := 0;
      else
         Code := 0;

         if not Variable_Length_Verbatim then
            Verbatim_Length
              := Positive (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
         elsif Input_Byte < Ada.Streams.Stream_Element'Last then
            Verbatim_Length
              := Positive (Ada.Streams.Stream_Element'Last - Input_Byte);
         else
            Offset := Offset + 1;
            Verbatim_Length
              := Positive (Input (Offset))
               + Natural (Ada.Streams.Stream_Element'Last - Last_Code)
               - 1;
         end if;
      end if;

      Offset := Offset + 1;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String) is
   begin
      for I in Output'Range loop
         Output (I) := Character'Val (Input (Offset));
         Offset := Offset + 1;
      end loop;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      pragma Unreferenced (Input);
   begin
      Offset := Offset + Ada.Streams.Stream_Element_Offset (Verbatim_Length);
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count
            (Ada.Streams.Stream_Element'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Remaining : Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Input_Length);
      Overhead : Ada.Streams.Stream_Element_Count := 0;
   begin
      if Variable_Length_Verbatim then
         if Remaining >= Verbatim2_Max_Size then
            declare
               Full_Blocks : constant Ada.Streams.Stream_Element_Count
                 := Remaining / Verbatim2_Max_Size;
            begin
               Overhead := Overhead + 2 * Full_Blocks;
               Remaining := Remaining - Verbatim2_Max_Size * Full_Blocks;
            end;
         end if;

         if Remaining > Verbatim1_Max_Size then
            Overhead := Overhead + 2;
            Remaining := 0;
         end if;
      end if;

      declare
         Full_Blocks : constant Ada.Streams.Stream_Element_Count
           := Remaining / Verbatim1_Max_Size;
      begin
         Overhead := Overhead + Full_Blocks;
      end;

      return Overhead + Ada.Streams.Stream_Element_Count (Input_Length);
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Ada.Streams.Stream_Element) is
   begin
      Output (Offset) := Code;
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Input_Index : Positive := Input'First;
      Remaining_Length, Block_Length : Positive;
   begin
      while Input_Index in Input'Range loop
         Remaining_Length := Input'Last - Input_Index + 1;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Output (Offset) := Ada.Streams.Stream_Element'Last;
            Output (Offset + 1) := Ada.Streams.Stream_Element
              (Block_Length - Verbatim1_Max_Size);
            Offset := Offset + 2;
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Output (Offset)
              := Ada.Streams.Stream_Element'Last
               - Ada.Streams.Stream_Element
                  (Block_Length - 1 + Boolean'Pos (Variable_Length_Verbatim));
            Offset := Offset + 1;
         end if;

         Verbatim_Copy :
         for I in 1 .. Block_Length loop
            Output (Offset) := Character'Pos (Input (Input_Index));
            Offset := Offset + 1;
            Input_Index := Input_Index + 1;
         end loop Verbatim_Copy;
      end loop;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_256;

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

package body Natools.Smaz_Implementations.Base_256 is

   use type Ada.Streams.Stream_Element;
   use type Ada.Streams.Stream_Element_Offset;

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Ada.Streams.Stream_Element;
      Verbatim_Length : out Natural;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
   is
      Input_Byte : constant Ada.Streams.Stream_Element := Input (Offset);
   begin
      if Input_Byte <= Last_Code then
         Code := Input_Byte;
         Verbatim_Length := 0;
      else
         Code := 0;

         if not Variable_Length_Verbatim then
            Verbatim_Length
              := Positive (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
         elsif Input_Byte < Ada.Streams.Stream_Element'Last then
            Verbatim_Length
              := Positive (Ada.Streams.Stream_Element'Last - Input_Byte);
         else
            Offset := Offset + 1;
            Verbatim_Length
              := Positive (Input (Offset))
               + Natural (Ada.Streams.Stream_Element'Last - Last_Code)
               - 1;
         end if;
      end if;

      Offset := Offset + 1;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String) is
   begin
      for I in Output'Range loop
         Output (I) := Character'Val (Input (Offset));
         Offset := Offset + 1;
      end loop;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      pragma Unreferenced (Input);
   begin
      Offset := Offset + Ada.Streams.Stream_Element_Offset (Verbatim_Length);
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count
            (Ada.Streams.Stream_Element'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Remaining : Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Input_Length);
      Overhead : Ada.Streams.Stream_Element_Count := 0;
   begin
      if Variable_Length_Verbatim then
         if Remaining >= Verbatim2_Max_Size then
            declare
               Full_Blocks : constant Ada.Streams.Stream_Element_Count
                 := Remaining / Verbatim2_Max_Size;
            begin
               Overhead := Overhead + 2 * Full_Blocks;
               Remaining := Remaining - Verbatim2_Max_Size * Full_Blocks;
            end;
         end if;

         if Remaining > Verbatim1_Max_Size then
            Overhead := Overhead + 2;
            Remaining := 0;
         end if;
      end if;

      declare
         Block_Count : constant Ada.Streams.Stream_Element_Count
           := (Remaining + Verbatim1_Max_Size - 1) / Verbatim1_Max_Size;
      begin
         Overhead := Overhead + Block_Count;
      end;

      return Overhead + Ada.Streams.Stream_Element_Count (Input_Length);
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Ada.Streams.Stream_Element) is
   begin
      Output (Offset) := Code;
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Ada.Streams.Stream_Element;
      Variable_Length_Verbatim : in Boolean)
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Input_Index : Positive := Input'First;
      Remaining_Length, Block_Length : Positive;
   begin
      while Input_Index in Input'Range loop
         Remaining_Length := Input'Last - Input_Index + 1;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Output (Offset) := Ada.Streams.Stream_Element'Last;
            Output (Offset + 1) := Ada.Streams.Stream_Element
              (Block_Length - Verbatim1_Max_Size);
            Offset := Offset + 2;
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Output (Offset)
              := Ada.Streams.Stream_Element'Last
               - Ada.Streams.Stream_Element
                  (Block_Length - 1 + Boolean'Pos (Variable_Length_Verbatim));
            Offset := Offset + 1;
         end if;

         Verbatim_Copy :
         for I in 1 .. Block_Length loop
            Output (Offset) := Character'Pos (Input (Input_Index));
            Offset := Offset + 1;
            Input_Index := Input_Index + 1;
         end loop Verbatim_Copy;
      end loop;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_256;

fix off-by-one error in Verbatim_Size

smaz_implementations-base_256: fix off-by-one error in Verbatim_Size


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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.IO_Exceptions;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      begin
         loop
            exit when End_Of_File (Handle);
            Get (Handle, Char);
            if First then
               Put (File, "<![CDATA[");
               First := False;
            end if;
            CData_Ending := State_Change (CData_Ending);

            Put (File, Char);
            if End_Of_Line (Handle) then
               New_Line (File);
            end if;
         end loop;

         --  The End_Error exception is sometimes raised.
      exception
         when Ada.IO_Exceptions.End_Error =>
            null;
      end;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

Handle the End_Error exception which can be raised while reading a file


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

   --  ------------------------------
   --  Append a node to the tag node.
   --  ------------------------------
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access) is
   begin
      if Into.Children = null then
         Into.Children := new Node_List;
         Into.Children.Current := Into.Children.First'Access;
      end if;
      Append (Into.Children.all, Node);
   end Append;

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

   --  Finalize the node list to release the allocated memory.
   overriding
   procedure Finalize (List : in out Node_List) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Node_List_Block, Node_List_Block_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Node_Type, Node_Type_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Node_List, Node_List_Access);

      procedure Release (List : in out Node_List_Block_Access);

      procedure Free_Block (Block : in out Node_List_Block) is
      begin
         for I in 1 .. Block.Last loop
            if Block.List (I).Kind = N_TAG_START then
               Free (Block.List (I).Children);
            end if;
            Free (Block.List (I));
         end loop;
      end Free_Block;

      procedure Release (List : in out Node_List_Block_Access) is
         Next  : Node_List_Block_Access := List;
         Block : Node_List_Block_Access;
      begin
         while Next /= null loop
            Block := Next;
            Free_Block (Block.all);
            Next := Next.Next;
            Free (Block);
         end loop;
      end Release;

   begin
      Release (List.First.Next);
      Free_Block (List.First);
   end Finalize;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (List    : in Node_List_Access;
                      Process : not null access procedure (Node : in Node_Type)) is
      Block : Node_List_Block_Access := List.First'Access;
   begin
      loop
         for I in 1 .. Block.Last loop
            Process (Block.List (I).all);
         end loop;
         Block := Block.Next;
         exit when Block = null;
      end loop;
   end Iterate;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
--     procedure Iterate (Doc     : in Document;
--                        Process : not null access procedure (Node : in Node_Type)) is
--        Block : Node_List_Block_Access := Doc.Nodes.Value.First'Access;
--     begin
--        loop
--           for I in 1 .. Block.Last loop
--              Process (Block.List (I).all);
--           end loop;
--           Block := Block.Next;
--           exit when Block = null;
--        end loop;
--     end Iterate;

   --  Append a node to the node list.
   procedure Append (Into : in out Node_List_Ref;
                     Node : in Node_Type_Access) is
   begin
      if Into.Is_Null then
         Node_List_Refs.Ref (Into) := Node_List_Refs.Create;
         Into.Value.Current := Into.Value.First'Access;
      end if;
      Append (Into.Value.all, Node);
   end Append;

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (List    : in Node_List_Ref;
                      Process : not null access procedure (Node : in Node_Type)) is
   begin
      if not List.Is_Null then
         Iterate (List.Value, Process);
      end if;
   end Iterate;

end Wiki.Nodes;

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

   --  ------------------------------
   --  Append a node to the tag node.
   --  ------------------------------
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access) is
   begin
      if Into.Children = null then
         Into.Children := new Node_List;
         Into.Children.Current := Into.Children.First'Access;
      end if;
      Append (Into.Children.all, Node);
   end Append;

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

   --  Finalize the node list to release the allocated memory.
   overriding
   procedure Finalize (List : in out Node_List) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Node_List_Block, Node_List_Block_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Node_Type, Node_Type_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Node_List, Node_List_Access);

      procedure Release (List : in out Node_List_Block_Access);

      procedure Free_Block (Block : in out Node_List_Block) is
      begin
         for I in 1 .. Block.Last loop
            if Block.List (I).Kind = N_TAG_START then
               Free (Block.List (I).Children);
            end if;
            Free (Block.List (I));
         end loop;
      end Free_Block;

      procedure Release (List : in out Node_List_Block_Access) is
         Next  : Node_List_Block_Access := List;
         Block : Node_List_Block_Access;
      begin
         while Next /= null loop
            Block := Next;
            Free_Block (Block.all);
            Next := Next.Next;
            Free (Block);
         end loop;
      end Release;

   begin
      Release (List.First.Next);
      Free_Block (List.First);
   end Finalize;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (List    : in Node_List_Access;
                      Process : not null access procedure (Node : in Node_Type)) is
      Block : Node_List_Block_Access := List.First'Access;
   begin
      loop
         for I in 1 .. Block.Last loop
            Process (Block.List (I).all);
         end loop;
         Block := Block.Next;
         exit when Block = null;
      end loop;
   end Iterate;

   --  Append a node to the node list.
   procedure Append (Into : in out Node_List_Ref;
                     Node : in Node_Type_Access) is
   begin
      if Into.Is_Null then
         Node_List_Refs.Ref (Into) := Node_List_Refs.Create;
         Into.Value.Current := Into.Value.First'Access;
      end if;
      Append (Into.Value.all, Node);
   end Append;

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (List    : in Node_List_Ref;
                      Process : not null access procedure (Node : in Node_Type)) is
   begin
      if not List.Is_Null then
         Iterate (List.Value, Process);
      end if;
   end Iterate;

end Wiki.Nodes;

Remove unused Iterate procedure

Remove unused Iterate procedure


-----------------------------------------------------------------------
--  ado-drivers-tests -- Unit tests for database drivers
--  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 Util.Tests;
package ADO.Drivers.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Initialize operation.
   procedure Test_Initialize (T : in out Test);

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

   --  Test the Set_Connection procedure.
   procedure Test_Set_Connection (T : in out Test);

   --  Test the Set_Connection procedure with several error cases.
   procedure Test_Set_Connection_Error (T : in out Test);

end ADO.Drivers.Tests;

-----------------------------------------------------------------------
--  ado-drivers-tests -- Unit tests for database drivers
--  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 Util.Tests;
package ADO.Drivers.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Initialize operation.
   procedure Test_Initialize (T : in out Test);

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

   --  Test the Set_Connection procedure.
   procedure Test_Set_Connection (T : in out Test);

   --  Test the Set_Connection procedure with several error cases.
   procedure Test_Set_Connection_Error (T : in out Test);

   --  Test the connection operations on an empty connection.
   procedure Test_Empty_Connection (T : in out Test);

end ADO.Drivers.Tests;

Declare Test_Empty_Connection test procedure


-----------------------------------------------------------------------
--  asf-lifecycles-restore -- Restore view phase
--  Copyright (C) 2010, 2011, 2015, 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.Exceptions;
with ASF.Applications.Main;
with ASF.Components.Root;
with ASF.Requests;
with Util.Log.Loggers;
package body ASF.Lifecycles.Restore is

   use Ada.Exceptions;
   use ASF.Applications;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Restore");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Restore_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Controller.View_Handler := Views;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Restore_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use ASF.Components;

      Req     : constant ASF.Requests.Request_Access := Context.Get_Request;
      Page    : constant String := Context.Get_View_Name;
      View    : Components.Root.UIViewRoot;
   begin
      Controller.View_Handler.Restore_View (Page, Context, View);

      Context.Set_View_Root (View);

      --  If the view was not found, render the response immediately.
      --  The missing page will be handled by the lifecycle response handler.
      if Components.Root.Get_Root (View) = null then
         Context.Render_Response;

         --  If this is not a postback, check for view parameters.
      elsif Req.Get_Method = "GET" then
         --  We need to process the ASF lifecycle towards the meta data component tree.
         --  This allows some Ada beans to be initialized from the request parameters
         --  and have some component actions called on the http GET (See <f:viewActions)).
         Components.Root.Set_Meta (View);

         --  If the view has no meta data, render the response immediately.
         if not Components.Root.Has_Meta (View) then
            Context.Render_Response;
         end if;
      end if;

   exception
      when E : others =>
         Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Restore;

-----------------------------------------------------------------------
--  asf-lifecycles-restore -- Restore view phase
--  Copyright (C) 2010, 2011, 2015, 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.Exceptions;
with ASF.Components.Root;
with ASF.Requests;
with Util.Log.Loggers;
package body ASF.Lifecycles.Restore is

   use Ada.Exceptions;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Restore");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Restore_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Controller.View_Handler := Views;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Restore_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use ASF.Components;

      Req     : constant ASF.Requests.Request_Access := Context.Get_Request;
      Page    : constant String := Context.Get_View_Name;
      View    : Components.Root.UIViewRoot;
   begin
      Controller.View_Handler.Restore_View (Page, Context, View);

      Context.Set_View_Root (View);

      --  If the view was not found, render the response immediately.
      --  The missing page will be handled by the lifecycle response handler.
      if Components.Root.Get_Root (View) = null then
         Context.Render_Response;

         --  If this is not a postback, check for view parameters.
      elsif Req.Get_Method = "GET" then
         --  We need to process the ASF lifecycle towards the meta data component tree.
         --  This allows some Ada beans to be initialized from the request parameters
         --  and have some component actions called on the http GET (See <f:viewActions)).
         Components.Root.Set_Meta (View);

         --  If the view has no meta data, render the response immediately.
         if not Components.Root.Has_Meta (View) then
            Context.Render_Response;
         end if;
      end if;

   exception
      when E : others =>
         Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Restore;

Remove unused with clauses

Remove unused with clauses


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

with Util.Strings;
with Ada.Unchecked_Deallocation;
package body Util.Serialize.Mappers is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.Mappers",
                                                    Util.Log.WARN_LEVEL);

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.all.Execute (Map, Ctx, Value);
      end if;
   end Execute;

   function Is_Proxy (Controller : in Mapper) return Boolean is
   begin
      return Controller.Is_Proxy_Mapper;
   end Is_Proxy;

   --  -----------------------
   --  Returns true if the mapper is a wildcard node (matches any element).
   --  -----------------------
   function Is_Wildcard (Controller : in Mapper) return Boolean is
   begin
      return Controller.Is_Wildcard;
   end Is_Wildcard;

   --  -----------------------
   --  Returns the mapping name.
   --  -----------------------
   function Get_Name (Controller : in Mapper) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Controller.Name);
   end Get_Name;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   function Find_Mapper (Controller : in Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False) return Mapper_Access is
      use type Ada.Strings.Unbounded.Unbounded_String;
      Node : Mapper_Access := Controller.First_Child;
   begin
      if Node = null and Controller.Mapper /= null then
         return Controller.Mapper.Find_Mapper (Name, Attribute);
      end if;
      while Node /= null loop
         if Node.Is_Wildcard then
            declare
               Result : constant Mapper_Access := Node.Find_Mapper (Name, Attribute);
            begin
               if Result /= null then
                  return Result;
               else
                  return Node;
               end if;
            end;
         end if;
         if Node.Name = Name then
            if (Attribute = False and Node.Mapping = null)
              or else not Node.Mapping.Is_Attribute then
               return Node;
            end if;
            if Attribute and Node.Mapping.Is_Attribute then
               return Node;
            end if;
         end if;
         Node := Node.Next_Mapping;
      end loop;
      return null;
   end Find_Mapper;

   --  -----------------------
   --  Find a path component representing a child mapper under From and
   --  identified by the given Name.  If the mapper is not found, a new
   --  Mapper_Node is created.
   --  -----------------------
   procedure Find_Path_Component (From   : in out Mapper'Class;
                                  Name   : in String;
                                  Result : out Mapper_Access) is
      use Ada.Strings.Unbounded;

      Node     : Mapper_Access := From.First_Child;
      Previous : Mapper_Access := null;
      Wildcard : constant Boolean := Name = "*";
   begin
      if Node = null then
         Result := new Mapper;
         Result.Name := To_Unbounded_String (Name);
         Result.Is_Wildcard := Wildcard;
         From.First_Child := Result;
         return;
      end if;
      loop
         if Node.Name = Name then
            Result := Node;
            return;
         end if;
         if Node.Next_Mapping = null then
            Result := new Mapper;
            Result.Name := To_Unbounded_String (Name);
            Result.Is_Wildcard := Wildcard;
            if Node.Is_Wildcard then
               Result.Next_Mapping := Node;
               if Previous = null then
                  From.First_Child := Result;
               else
                  Previous.Next_Mapping := Result;
               end if;
            else
               Node.Next_Mapping := Result;
            end if;
            return;
         end if;
         Previous := Node;
         Node := Node.Next_Mapping;
      end loop;
   end Find_Path_Component;

   --  -----------------------
   --  Build the mapping tree that corresponds to the given Path.
   --  Each path component is represented by a Mapper_Node element.
   --  The node is created if it does not exists.
   --  -----------------------
   procedure Build_Path (Into     : in out Mapper'Class;
                         Path     : in String;
                         Last_Pos : out Natural;
                         Node     : out Mapper_Access) is
      Pos      : Natural;
   begin
      Node     := Into'Unchecked_Access;
      Last_Pos := Path'First;
      loop
         Pos := Util.Strings.Index (Source => Path,
                                    Char   => '/',
                                    From   => Last_Pos);
         if Pos = 0 then
            Node.Find_Path_Component (Name   => Path (Last_Pos .. Path'Last),
                                      Result => Node);
            Last_Pos := Path'Last + 1;
         else
            Node.Find_Path_Component (Name   => Path (Last_Pos .. Pos - 1),
                                      Result => Node);
            Last_Pos := Pos + 1;
         end if;
         exit when Last_Pos > Path'Last;
      end loop;
   end Build_Path;

   --  -----------------------
   --  Add a mapping to associate the given Path to the mapper defined in Map.
   --  The Path string describes the matching node using a simplified XPath notation.
   --  Example:
   --     info/first_name    matches:  <info><first_name>...</first_name></info>
   --     info/a/b/name      matches:  <info><name>...</name></info>
   --     */a/b/name         matches:  <j><name>...</name></j>
   --  -----------------------
   procedure Add_Mapping (Into : in out Mapper;
                          Path : in String;
                          Map  : in Mapper_Access) is
      procedure Copy (To   : in Mapper_Access;
                      From : in Mapper_Access);

      Node     : Mapper_Access;
      Last_Pos : Natural;

      procedure Copy (To   : in Mapper_Access;
                      From : in Mapper_Access) is
         N   : Mapper_Access;
         Src : Mapper_Access := From;
      begin
         while Src /= null loop
            N := Src.Clone;
            N.Is_Clone := True;
            N.Next_Mapping := To.First_Child;
            To.First_Child := N;
            if Src.First_Child /= null then
               Copy (N, Src.First_Child);
            end if;
            Src := Src.Next_Mapping;
         end loop;
      end Copy;

   begin
      Log.Info ("Mapping '{0}' for mapper X", Path);

      --  Find or build the mapping tree.
      Into.Build_Path (Path, Last_Pos, Node);

      if Last_Pos < Path'Last then
         Log.Warn ("Ignoring the end of mapping path {0}", Path);
      end if;
      if Node.Mapper /= null then
         Log.Warn ("Overriding the mapping {0} for mapper X", Path);
      end if;
      if Map.First_Child /= null then
         Copy (Node, Map.First_Child);
      else
         Node.Mapper := Map;
      end if;
   end Add_Mapping;

   procedure Add_Mapping (Into : in out Mapper;
                          Path : in String;
                          Map  : in Mapping_Access) is
      use Ada.Strings.Unbounded;
      Node     : Mapper_Access;
      Last_Pos : Natural;
   begin
      Log.Info ("Mapping {0}", Path);

      --  Find or build the mapping tree.
      Into.Build_Path (Path, Last_Pos, Node);

      if Last_Pos < Path'Last then
         Log.Warn ("Ignoring the end of mapping path {0}", Path);
      end if;
      if Node.Mapping /= null then
         Log.Warn ("Overriding the mapping {0} for mapper X", Path);
      end if;
      if Length (Node.Name) = 0 then
         Log.Warn ("Mapped name is empty in mapping path {0}", Path);
      elsif Element (Node.Name, 1) = '@' then
         Delete (Node.Name, 1, 1);
         Map.Is_Attribute := True;
      else
         Map.Is_Attribute := False;
      end if;

      Node.Mapping := Map;
      Node.Mapper  := Into'Unchecked_Access;
   end Add_Mapping;

   --  -----------------------
   --  Clone the Handler instance and get a copy of that single object.
   --  -----------------------
   function Clone (Handler : in Mapper) return Mapper_Access is
      Result : constant Mapper_Access := new Mapper;
   begin
      Result.Name            := Handler.Name;
      Result.Mapper          := Handler.Mapper;
      Result.Mapping         := Handler.Mapping;
      Result.Is_Proxy_Mapper := Handler.Is_Proxy_Mapper;
      Result.Is_Clone        := True;
      Result.Is_Wildcard     := Handler.Is_Wildcard;
      return Result;
   end Clone;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   procedure Set_Member (Handler   : in Mapper;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False;
                         Context   : in out Util.Serialize.Contexts.Context'Class) is
      Map : constant Mapper_Access := Mapper'Class (Handler).Find_Mapper (Name, Attribute);
   begin
      if Map /= null and then Map.Mapping /= null and then Map.Mapper /= null then
         Map.Mapper.all.Execute (Map.Mapping.all, Context, Value);
      end if;
   end Set_Member;

   procedure Start_Object (Handler : in Mapper;
                           Context : in out Util.Serialize.Contexts.Context'Class;
                           Name    : in String) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.Start_Object (Context, Name);
      end if;
   end Start_Object;

   procedure Finish_Object (Handler : in Mapper;
                            Context : in out Util.Serialize.Contexts.Context'Class;
                            Name    : in String) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.Finish_Object (Context, Name);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Dump the mapping tree on the logger using the INFO log level.
   --  -----------------------
   procedure Dump (Handler : in Mapper'Class;
                   Log     : in Util.Log.Loggers.Logger'Class;
                   Prefix  : in String := "") is
      procedure Dump (Map : in Mapper'Class);

      --  -----------------------
      --  Dump the mapping description
      --  -----------------------
      procedure Dump (Map : in Mapper'Class) is
      begin
         if Map.Mapping /= null and then Map.Mapping.Is_Attribute then
            Log.Info (" {0}@{1}", Prefix,
                      Ada.Strings.Unbounded.To_String (Map.Mapping.Name));
         else
            Log.Info (" {0}/{1}", Prefix, Ada.Strings.Unbounded.To_String (Map.Name));
            Dump (Map, Log, Prefix & "/" & Ada.Strings.Unbounded.To_String (Map.Name));
         end if;
      end Dump;
   begin
      Iterate (Handler, Dump'Access);
   end Dump;

   procedure Iterate (Controller : in Mapper;
                      Process : not null access procedure (Map : in Mapper'Class)) is
      Node : Mapper_Access := Controller.First_Child;
   begin
      --  Pass 1: process the attributes first
      while Node /= null loop
         if Node.Mapping /= null and then Node.Mapping.Is_Attribute then
            Process.all (Node.all);
         end if;
         Node := Node.Next_Mapping;
      end loop;

      --  Pass 2: process the elements
      Node := Controller.First_Child;
      while Node /= null loop
         if Node.Mapping = null or else not Node.Mapping.Is_Attribute then
            Process.all (Node.all);
         end if;
         Node := Node.Next_Mapping;
      end loop;
   end Iterate;

   --  -----------------------
   --  Finalize the object and release any mapping.
   --  -----------------------
   overriding
   procedure Finalize (Controller : in out Mapper) is
      procedure Free is new Ada.Unchecked_Deallocation (Mapper'Class, Mapper_Access);
      procedure Free is new Ada.Unchecked_Deallocation (Mapping'Class, Mapping_Access);

      Node : Mapper_Access := Controller.First_Child;
      Next : Mapper_Access;
   begin
      Controller.First_Child := null;
      while Node /= null loop
         Next := Node.Next_Mapping;
         Free (Node);
         Node := Next;
      end loop;
      if not Controller.Is_Clone then
         Free (Controller.Mapping);
      else
         Controller.Mapping := null;
      end if;
   end Finalize;

end Util.Serialize.Mappers;

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

with Util.Strings;
with Ada.Unchecked_Deallocation;
package body Util.Serialize.Mappers is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.Mappers",
                                                    Util.Log.WARN_LEVEL);

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.all.Execute (Map, Ctx, Value);
      end if;
   end Execute;

   function Is_Proxy (Controller : in Mapper) return Boolean is
   begin
      return Controller.Is_Proxy_Mapper;
   end Is_Proxy;

   --  -----------------------
   --  Returns true if the mapper is a wildcard node (matches any element).
   --  -----------------------
   function Is_Wildcard (Controller : in Mapper) return Boolean is
   begin
      return Controller.Is_Wildcard;
   end Is_Wildcard;

   --  -----------------------
   --  Returns the mapping name.
   --  -----------------------
   function Get_Name (Controller : in Mapper) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Controller.Name);
   end Get_Name;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   function Find_Mapper (Controller : in Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False) return Mapper_Access is
      use type Ada.Strings.Unbounded.Unbounded_String;
      Node : Mapper_Access := Controller.First_Child;
   begin
      if Node = null and Controller.Mapper /= null then
         return Controller.Mapper.Find_Mapper (Name, Attribute);
      end if;
      while Node /= null loop
         if not Attribute and Node.Is_Wildcard then
            declare
               Result : constant Mapper_Access := Node.Find_Mapper (Name, Attribute);
            begin
               if Result /= null then
                  return Result;
               else
                  return Node;
               end if;
            end;
         end if;
         if Node.Name = Name then
            if (Attribute = False and Node.Mapping = null)
              or else not Node.Mapping.Is_Attribute then
               return Node;
            end if;
            if Attribute and Node.Mapping.Is_Attribute then
               return Node;
            end if;
         end if;
         Node := Node.Next_Mapping;
      end loop;
      return null;
   end Find_Mapper;

   --  -----------------------
   --  Find a path component representing a child mapper under From and
   --  identified by the given Name.  If the mapper is not found, a new
   --  Mapper_Node is created.
   --  -----------------------
   procedure Find_Path_Component (From   : in out Mapper'Class;
                                  Name   : in String;
                                  Result : out Mapper_Access) is
      use Ada.Strings.Unbounded;

      Node     : Mapper_Access := From.First_Child;
      Previous : Mapper_Access := null;
      Wildcard : constant Boolean := Name = "*";
   begin
      if Node = null then
         Result := new Mapper;
         Result.Name := To_Unbounded_String (Name);
         Result.Is_Wildcard := Wildcard;
         From.First_Child := Result;
         return;
      end if;
      loop
         if Node.Name = Name then
            Result := Node;
            return;
         end if;
         if Node.Next_Mapping = null then
            Result := new Mapper;
            Result.Name := To_Unbounded_String (Name);
            Result.Is_Wildcard := Wildcard;
            if Node.Is_Wildcard then
               Result.Next_Mapping := Node;
               if Previous = null then
                  From.First_Child := Result;
               else
                  Previous.Next_Mapping := Result;
               end if;
            else
               Node.Next_Mapping := Result;
            end if;
            return;
         end if;
         Previous := Node;
         Node := Node.Next_Mapping;
      end loop;
   end Find_Path_Component;

   --  -----------------------
   --  Build the mapping tree that corresponds to the given Path.
   --  Each path component is represented by a Mapper_Node element.
   --  The node is created if it does not exists.
   --  -----------------------
   procedure Build_Path (Into     : in out Mapper'Class;
                         Path     : in String;
                         Last_Pos : out Natural;
                         Node     : out Mapper_Access) is
      Pos      : Natural;
   begin
      Node     := Into'Unchecked_Access;
      Last_Pos := Path'First;
      loop
         Pos := Util.Strings.Index (Source => Path,
                                    Char   => '/',
                                    From   => Last_Pos);
         if Pos = 0 then
            Node.Find_Path_Component (Name   => Path (Last_Pos .. Path'Last),
                                      Result => Node);
            Last_Pos := Path'Last + 1;
         else
            Node.Find_Path_Component (Name   => Path (Last_Pos .. Pos - 1),
                                      Result => Node);
            Last_Pos := Pos + 1;
         end if;
         exit when Last_Pos > Path'Last;
      end loop;
   end Build_Path;

   --  -----------------------
   --  Add a mapping to associate the given Path to the mapper defined in Map.
   --  The Path string describes the matching node using a simplified XPath notation.
   --  Example:
   --     info/first_name    matches:  <info><first_name>...</first_name></info>
   --     info/a/b/name      matches:  <info><name>...</name></info>
   --     */a/b/name         matches:  <j><name>...</name></j>
   --  -----------------------
   procedure Add_Mapping (Into : in out Mapper;
                          Path : in String;
                          Map  : in Mapper_Access) is
      procedure Copy (To   : in Mapper_Access;
                      From : in Mapper_Access);

      Node     : Mapper_Access;
      Last_Pos : Natural;

      procedure Copy (To   : in Mapper_Access;
                      From : in Mapper_Access) is
         N   : Mapper_Access;
         Src : Mapper_Access := From;
      begin
         while Src /= null loop
            N := Src.Clone;
            N.Is_Clone := True;
            N.Next_Mapping := To.First_Child;
            To.First_Child := N;
            if Src.First_Child /= null then
               Copy (N, Src.First_Child);
            end if;
            Src := Src.Next_Mapping;
         end loop;
      end Copy;

   begin
      Log.Info ("Mapping '{0}' for mapper X", Path);

      --  Find or build the mapping tree.
      Into.Build_Path (Path, Last_Pos, Node);

      if Last_Pos < Path'Last then
         Log.Warn ("Ignoring the end of mapping path {0}", Path);
      end if;
      if Node.Mapper /= null then
         Log.Warn ("Overriding the mapping {0} for mapper X", Path);
      end if;
      if Map.First_Child /= null then
         Copy (Node, Map.First_Child);
      else
         Node.Mapper := Map;
      end if;
   end Add_Mapping;

   procedure Add_Mapping (Into : in out Mapper;
                          Path : in String;
                          Map  : in Mapping_Access) is
      use Ada.Strings.Unbounded;
      Node     : Mapper_Access;
      Last_Pos : Natural;
   begin
      Log.Info ("Mapping {0}", Path);

      --  Find or build the mapping tree.
      Into.Build_Path (Path, Last_Pos, Node);

      if Last_Pos < Path'Last then
         Log.Warn ("Ignoring the end of mapping path {0}", Path);
      end if;
      if Node.Mapping /= null then
         Log.Warn ("Overriding the mapping {0} for mapper X", Path);
      end if;
      if Length (Node.Name) = 0 then
         Log.Warn ("Mapped name is empty in mapping path {0}", Path);
      elsif Element (Node.Name, 1) = '@' then
         Delete (Node.Name, 1, 1);
         Map.Is_Attribute := True;
      else
         Map.Is_Attribute := False;
      end if;

      Node.Mapping := Map;
      Node.Mapper  := Into'Unchecked_Access;
   end Add_Mapping;

   --  -----------------------
   --  Clone the Handler instance and get a copy of that single object.
   --  -----------------------
   function Clone (Handler : in Mapper) return Mapper_Access is
      Result : constant Mapper_Access := new Mapper;
   begin
      Result.Name            := Handler.Name;
      Result.Mapper          := Handler.Mapper;
      Result.Mapping         := Handler.Mapping;
      Result.Is_Proxy_Mapper := Handler.Is_Proxy_Mapper;
      Result.Is_Clone        := True;
      Result.Is_Wildcard     := Handler.Is_Wildcard;
      return Result;
   end Clone;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   procedure Set_Member (Handler   : in Mapper;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False;
                         Context   : in out Util.Serialize.Contexts.Context'Class) is
      Map : constant Mapper_Access := Mapper'Class (Handler).Find_Mapper (Name, Attribute);
   begin
      if Map /= null and then Map.Mapping /= null and then Map.Mapper /= null then
         Map.Mapper.all.Execute (Map.Mapping.all, Context, Value);
      end if;
   end Set_Member;

   procedure Start_Object (Handler : in Mapper;
                           Context : in out Util.Serialize.Contexts.Context'Class;
                           Name    : in String) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.Start_Object (Context, Name);
      end if;
   end Start_Object;

   procedure Finish_Object (Handler : in Mapper;
                            Context : in out Util.Serialize.Contexts.Context'Class;
                            Name    : in String) is
   begin
      if Handler.Mapper /= null then
         Handler.Mapper.Finish_Object (Context, Name);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Dump the mapping tree on the logger using the INFO log level.
   --  -----------------------
   procedure Dump (Handler : in Mapper'Class;
                   Log     : in Util.Log.Loggers.Logger'Class;
                   Prefix  : in String := "") is
      procedure Dump (Map : in Mapper'Class);

      --  -----------------------
      --  Dump the mapping description
      --  -----------------------
      procedure Dump (Map : in Mapper'Class) is
      begin
         if Map.Mapping /= null and then Map.Mapping.Is_Attribute then
            Log.Info (" {0}@{1}", Prefix,
                      Ada.Strings.Unbounded.To_String (Map.Mapping.Name));
         else
            Log.Info (" {0}/{1}", Prefix, Ada.Strings.Unbounded.To_String (Map.Name));
            Dump (Map, Log, Prefix & "/" & Ada.Strings.Unbounded.To_String (Map.Name));
         end if;
      end Dump;
   begin
      Iterate (Handler, Dump'Access);
   end Dump;

   procedure Iterate (Controller : in Mapper;
                      Process : not null access procedure (Map : in Mapper'Class)) is
      Node : Mapper_Access := Controller.First_Child;
   begin
      --  Pass 1: process the attributes first
      while Node /= null loop
         if Node.Mapping /= null and then Node.Mapping.Is_Attribute then
            Process.all (Node.all);
         end if;
         Node := Node.Next_Mapping;
      end loop;

      --  Pass 2: process the elements
      Node := Controller.First_Child;
      while Node /= null loop
         if Node.Mapping = null or else not Node.Mapping.Is_Attribute then
            Process.all (Node.all);
         end if;
         Node := Node.Next_Mapping;
      end loop;
   end Iterate;

   --  -----------------------
   --  Finalize the object and release any mapping.
   --  -----------------------
   overriding
   procedure Finalize (Controller : in out Mapper) is
      procedure Free is new Ada.Unchecked_Deallocation (Mapper'Class, Mapper_Access);
      procedure Free is new Ada.Unchecked_Deallocation (Mapping'Class, Mapping_Access);

      Node : Mapper_Access := Controller.First_Child;
      Next : Mapper_Access;
   begin
      Controller.First_Child := null;
      while Node /= null loop
         Next := Node.Next_Mapping;
         Free (Node);
         Node := Next;
      end loop;
      if not Controller.Is_Clone then
         Free (Controller.Mapping);
      else
         Controller.Mapping := null;
      end if;
   end Finalize;

end Util.Serialize.Mappers;

Fix mapping of attribute when wildcard mapping is also used


-----------------------------------------------------------------------
--  applications -- Ada Web Application
--  Copyright (C) 2009, 2010 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.Properties.Basic;
package body ASF.Applications is

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return String is
   begin
      return Self.Get (Param.Name.all, Param.Default.all);
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Boolean is
      use Util.Properties.Basic.Boolean_Property;
   begin
      return Get (Self, Param.Name.all, Boolean'Value (Param.Default.all));
   end Get;

end ASF.Applications;

-----------------------------------------------------------------------
--  applications -- Ada Web Application
--  Copyright (C) 2009, 2010, 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 Util.Properties.Basic;
package body ASF.Applications is

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return String is
   begin
      return Self.Get (Param.Name.all, Param.Default.all);
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Boolean is
      use Util.Properties.Basic.Boolean_Property;
   begin
      return Get (Self, Param.Name.all, Boolean'Value (Param.Default.all));
   end Get;

   --  ------------------------------
   --  Create the configuration parameter definition instance.
   --  ------------------------------
   package body Parameter is
      Param       : constant Config_Param := ASF.Applications.P '(Name => PARAM_NAME'Access,
                                                                  Default => PARAM_VALUE'Access);

      --  ------------------------------
      --  Returns the configuration parameter.
      --  ------------------------------
      function P return Config_Param is
      begin
         return Param;
      end P;

   end Parameter;

end ASF.Applications;

Implement the Parameter generic package

Implement the Parameter generic package