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

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32;

   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Buffer_Ptr) return String;

   --  procedure Put_Uint8 (Buffer : in Buffer_Ptr; Data : in Uint8);

   --  procedure Put_Uint16 (Buffer : in Buffer_Ptr; Data : in Uint16);

   --  procedure Put_Uint32 (Buffer : in Buffer_Ptr; Data : in Uint32);
   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size is new Get_Target_Value (MAT.Types.Target_Size);

   function Get_Target_Addr is new Get_Target_Value (MAT.Types.Target_Addr);

   function Get_Target_Tick is new Get_Target_Value (MAT.Types.Target_Tick_Ref);

   function Get_Target_Thread is new Get_Target_Value (MAT.Types.Target_Thread_Ref);

   procedure Skip (Msg  : in Buffer_Ptr;
                   Size : in Natural);

end MAT.Readers.Marshaller;

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

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32;

   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Buffer_Ptr) return String;

   --  procedure Put_Uint8 (Buffer : in Buffer_Ptr; Data : in Uint8);

   --  procedure Put_Uint16 (Buffer : in Buffer_Ptr; Data : in Uint16);

   --  procedure Put_Uint32 (Buffer : in Buffer_Ptr; Data : in Uint32);
   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size is new Get_Target_Value (MAT.Types.Target_Size);

   function Get_Target_Addr is new Get_Target_Value (MAT.Types.Target_Addr);

   function Get_Target_Tick is new Get_Target_Value (MAT.Types.Target_Tick_Ref);

   function Get_Target_Thread is new Get_Target_Value (MAT.Types.Target_Thread_Ref);

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

Fix definition of Skip procedure

Fix definition of Skip procedure


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

with AWA.Modules;
package AWA.Changelogs.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "changelogs";

   --  ------------------------------
   --  Module changelogs
   --  ------------------------------
   type Changelog_Module is new AWA.Modules.Module with private;
   type Changelog_Module_Access is access all Changelog_Module'Class;

   --  Initialize the changelogs module.
   overriding
   procedure Initialize (Plugin : in out Changelog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the changelogs module.
   function Get_Changelog_Module return Changelog_Module_Access;

private

   type Changelog_Module is new AWA.Modules.Module with null record;

end AWA.Changelogs.Modules;

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

with ADO;

with AWA.Modules;
package AWA.Changelogs.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "changelogs";

   --  ------------------------------
   --  Module changelogs
   --  ------------------------------
   type Changelog_Module is new AWA.Modules.Module with private;
   type Changelog_Module_Access is access all Changelog_Module'Class;

   --  Initialize the changelogs module.
   overriding
   procedure Initialize (Plugin : in out Changelog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the changelogs module.
   function Get_Changelog_Module return Changelog_Module_Access;

   --  Add the log message and associate it with the database entity identified by
   --  the given id and the entity type.  The log message is associated with the current user.
   procedure Add_Log (Model       : in Changelog_Module;
                      Id          : in ADO.Identifier;
                      Entity_Type : in String;
                      Message     : in String);

private

   type Changelog_Module is new AWA.Modules.Module with null record;

end AWA.Changelogs.Modules;

Declare the Add_Log procedure

Declare the Add_Log procedure


-----------------------------------------------------------------------
--  mat-consoles-text - Text console interface
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Glib;
with Gtk.Frame;
with Gtk.List_Store;
with Gtk.Tree_Model;
with Gtk.Cell_Renderer_Text;
with Gtk.Tree_View;
with Gtk.Scrolled_Window;

package MAT.Consoles.Gtkmat is

   type Console_Type is new MAT.Consoles.Console_Type with private;
   type Console_Type_Access is access all Console_Type'Class;

   --  Initialize the console to display the result in the Gtk frame.
   procedure Initialize (Console : in out Console_Type;
                         Frame   : in Gtk.Frame.Gtk_Frame);

   --  Report a notice message.
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String);

   --  Report an error message.
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String);

   --  Print the field value for the given field.
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String);

   --  Print the title for the given field.
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String);

   --  Start a new title in a report.
   overriding
   procedure Start_Title (Console : in out Console_Type);

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type);

   --  Start a new row in a report.
   overriding
   procedure Start_Row (Console : in out Console_Type);

   --  Finish a new row in a report.
   overriding
   procedure End_Row (Console : in out Console_Type);

private

   type Column_Type is record
      Field : Field_Type;
      Title : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Column_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Column_Type;

   type Field_Index_Array is array (Field_Type) of Glib.Gint;

   type Console_Type is new MAT.Consoles.Console_Type with record
      Frame       : Gtk.Frame.Gtk_Frame;
      Scrolled    : Gtk.Scrolled_Window.Gtk_Scrolled_Window;
      List        : Gtk.List_Store.Gtk_List_Store;
      Current_Row : Gtk.Tree_Model.Gtk_Tree_Iter;
      File        : Ada.Text_IO.File_Type;
      Indexes     : Field_Index_Array;
      Columns     : Column_Array;
      Tree        : Gtk.Tree_View.Gtk_Tree_View;
      Col_Text    : Gtk.Cell_Renderer_Text.Gtk_Cell_renderer_Text;
   end record;

end MAT.Consoles.Gtkmat;

-----------------------------------------------------------------------
--  mat-consoles-text - Text console interface
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Glib;
with Gtk.Frame;
with Gtk.List_Store;
with Gtk.Tree_Model;
with Gtk.Cell_Renderer_Text;
with Gtk.Tree_View;
with Gtk.Scrolled_Window;

package MAT.Consoles.Gtkmat is

   type Console_Type is new MAT.Consoles.Console_Type with private;
   type Console_Type_Access is access all Console_Type'Class;

   --  Initialize the console to display the result in the Gtk frame.
   procedure Initialize (Console : in out Console_Type;
                         Frame   : in Gtk.Frame.Gtk_Frame);

   --  Report a notice message.
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String);

   --  Report an error message.
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String);

   --  Print the field value for the given field.
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT);

   --  Print the title for the given field.
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String);

   --  Start a new title in a report.
   overriding
   procedure Start_Title (Console : in out Console_Type);

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type);

   --  Start a new row in a report.
   overriding
   procedure Start_Row (Console : in out Console_Type);

   --  Finish a new row in a report.
   overriding
   procedure End_Row (Console : in out Console_Type);

private

   type Column_Type is record
      Field : Field_Type;
      Title : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Column_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Column_Type;

   type Field_Index_Array is array (Field_Type) of Glib.Gint;

   type Console_Type is new MAT.Consoles.Console_Type with record
      Frame       : Gtk.Frame.Gtk_Frame;
      Scrolled    : Gtk.Scrolled_Window.Gtk_Scrolled_Window;
      List        : Gtk.List_Store.Gtk_List_Store;
      Current_Row : Gtk.Tree_Model.Gtk_Tree_Iter;
      File        : Ada.Text_IO.File_Type;
      Indexes     : Field_Index_Array;
      Columns     : Column_Array;
      Tree        : Gtk.Tree_View.Gtk_Tree_View;
      Col_Text    : Gtk.Cell_Renderer_Text.Gtk_Cell_renderer_Text;
   end record;

end MAT.Consoles.Gtkmat;

Add a Justify parameter to the Print_Field procedure


--
-- 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;
         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, 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, 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",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, 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 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, 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, 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",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, 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;

Fix XML generation if a message contains a " (double quote). This terminates the attribute...


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

with Util.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;
      use Interfaces;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Lock.Write;

      --  Generate the random sequence.
      for I in 0 .. Factory.Id_Size - 1 loop
         declare
            Value : constant Unsigned_32 := Id_Random.Random (Factory.Random);
         begin
            Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
            Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
            Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
            Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
         end;
      end loop;
      Factory.Lock.Release_Write;

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access := new Session_Record;
   begin
      Impl.Ref_Counter  := Util.Concurrent.Counters.ONE;
      Impl.Create_Time  := Ada.Calendar.Clock;
      Impl.Access_Time  := Impl.Create_Time;
      Impl.Max_Inactive := Factory.Max_Inactive;
      Sess.Impl         := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Lock.Write;
      Factory.Sessions.Insert (Impl.Id.all'Access, Sess);
      Factory.Lock.Release_Write;

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      null;
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Null_Session;
      Factory.Lock.Read;
      declare
         Pos : constant Session_Maps.Cursor := Factory.Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            Result := Session_Maps.Element (Pos);
         end if;
      end;
      Factory.Lock.Release_Read;

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Id_Random.Reset (Factory.Random);
   end Initialize;

end ASF.Sessions.Factory;

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

with Util.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;
      use Interfaces;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Lock.Write;

      --  Generate the random sequence.
      for I in 0 .. Factory.Id_Size - 1 loop
         declare
            Value : constant Unsigned_32 := Id_Random.Random (Factory.Random);
         begin
            Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
            Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
            Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
            Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
         end;
      end loop;
      Factory.Lock.Release_Write;

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access
        := new Session_Record '(Ada.Finalization.Limited_Controlled with
                                Ref_Counter  => Util.Concurrent.Counters.ONE,
                                Create_Time  => Ada.Calendar.Clock,
                                Max_Inactive => Factory.Max_Inactive,
                                others       => <>);
   begin
      Impl.Access_Time := Impl.Create_Time;
      Sess.Impl        := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Lock.Write;
      Factory.Sessions.Insert (Impl.Id.all'Access, Sess);
      Factory.Lock.Release_Write;

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      null;
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Null_Session;
      Factory.Lock.Read;
      declare
         Pos : constant Session_Maps.Cursor := Factory.Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            Result := Session_Maps.Element (Pos);
         end if;
      end;
      Factory.Lock.Release_Read;

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Id_Random.Reset (Factory.Random);
   end Initialize;

end ASF.Sessions.Factory;

Fix compilation on arm

Fix compilation on arm


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

--  The HiLo sequence generator.  This sequence generator uses a database table
--  sequence to allocate blocks of identifiers for a given sequence name.
--  The sequence table contains one row for each sequence.  It keeps track of
--  the next available sequence identifier (in the value column).
--
--  To allocate a sequence block, the HiLo generator obtains the next available
--  sequence identified and updates it by adding the sequence block size.  The
--  HiLo sequence generator will allocate the identifiers until the block is
--  full after which a new block will be allocated.

package ADO.Sequences.Hilo is

   --  ------------------------------
   --  High Low sequence generator
   --  ------------------------------
   type HiLoGenerator is new Generator with private;

   DEFAULT_BLOCK_SIZE : constant Identifier := 100;

   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   overriding
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : in out Objects.Object_Record'Class);

   --  Allocate a new sequence block.
   procedure Allocate_Sequence (Gen : in out HiLoGenerator);

   function Create_HiLo_Generator
     (Sess_Factory : in Session_Factory_Access)
      return Generator_Access;

private

   type HiLoGenerator is new Generator with record
      Last_Id    : Identifier := NO_IDENTIFIER;
      Next_Id    : Identifier := NO_IDENTIFIER;
      Block_Size : Identifier := DEFAULT_BLOCK_SIZE;
   end record;

end ADO.Sequences.Hilo;

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

--  === HiLo Sequence Generator ===
--  The HiLo sequence generator.  This sequence generator uses a database table
--  sequence to allocate blocks of identifiers for a given sequence name.
--  The sequence table contains one row for each sequence.  It keeps track of
--  the next available sequence identifier (in the value column).
--
--  To allocate a sequence block, the HiLo generator obtains the next available
--  sequence identified and updates it by adding the sequence block size.  The
--  HiLo sequence generator will allocate the identifiers until the block is
--  full after which a new block will be allocated.

package ADO.Sequences.Hilo is

   --  ------------------------------
   --  High Low sequence generator
   --  ------------------------------
   type HiLoGenerator is new Generator with private;

   DEFAULT_BLOCK_SIZE : constant Identifier := 100;

   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   overriding
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : in out Objects.Object_Record'Class);

   --  Allocate a new sequence block.
   procedure Allocate_Sequence (Gen : in out HiLoGenerator);

   function Create_HiLo_Generator
     (Sess_Factory : in Session_Factory_Access)
      return Generator_Access;

private

   type HiLoGenerator is new Generator with record
      Last_Id    : Identifier := NO_IDENTIFIER;
      Next_Id    : Identifier := NO_IDENTIFIER;
      Block_Size : Identifier := DEFAULT_BLOCK_SIZE;
   end record;

end ADO.Sequences.Hilo;

Add some documentation

Add some documentation


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

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] [-web] [-tool] [-ado] "
                & "NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
      New_Line;
      Put_Line ("  -web   Generate a Web application");
      Put_Line ("  -tool  Generate a command line tool");
      Put_Line ("  -ado   Generate a database tool operation for ADO");
   end Help;

end Gen.Commands.Project;

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

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] [--web] [--tool] [--ado] "
                & "NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
   end Help;

end Gen.Commands.Project;

Update the create-project help message

Update the create-project help message


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

with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.IO.JSON;
with Util.Serialize.Mappers.Record_Mapper;
package body Util.Serialize.Tools is

   type Object_Field is (FIELD_NAME, FIELD_VALUE);
   type Object_Map_Access is access all Util.Beans.Objects.Maps.Map'Class;

   type Object_Mapper_Context is record
      Map  : Object_Map_Access;
      Name : Util.Beans.Objects.Object;
   end record;
   type Object_Mapper_Context_Access is access all Object_Mapper_Context;

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_VALUE =>
            Into.Map.Include (Util.Beans.Objects.To_String (Into.Name), Value);
            Into.Name := Util.Beans.Objects.Null_Object;

      end case;
   end Set_Member;

   package Object_Mapper is new
     Util.Serialize.Mappers.Record_Mapper (Element_Type        => Object_Mapper_Context,
                                           Element_Type_Access => Object_Mapper_Context_Access,
                                           Fields              => Object_Field,
                                           Set_Member          => Set_Member);

   Object_Mapping : aliased Object_Mapper.Mapper;

   procedure To_JSON (Output : in out Util.Serialize.IO.JSON.Output_Stream;
                     Map    : in Util.Beans.Objects.Maps.Map) is
      use type Ada.Containers.Count_Type;

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object) is
      begin
         Output.Start_Entity (Name => "");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_Attribute (Name  => "value",
                                 Value => Value);
         Output.End_Entity (Name => "");
      end Write;

   begin
      if Map.Length > 0 then
         declare
            Iter : Util.Beans.Objects.Maps.Cursor := Map.First;
         begin
            Output.Start_Array (Name   => "params",
                                Length => Map.Length);
            while Util.Beans.Objects.Maps.Has_Element (Iter) loop
               Util.Beans.Objects.Maps.Query_Element (Iter, Write'Access);
               Util.Beans.Objects.Maps.Next (Iter);
            end loop;
            Output.End_Array;
         end;
      end if;
   end To_JSON;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into an XML stream.
   --  Returns the JSON string that contains a serialization of the object maps.
   --  -----------------------
   function To_JSON (Map : in Util.Beans.Objects.Maps.Map) return String is
      use type Ada.Containers.Count_Type;
   begin
      if Map.Length = 0 then
         return "";
      end if;
      declare
         Output : Util.Serialize.IO.JSON.Output_Stream;
      begin
         Output.Initialize (Size => 10000);
         Output.Start_Document;
         To_JSON (Output, Map);
         Output.End_Document;
         return Util.Streams.Texts.To_String (Util.Streams.Buffered.Buffered_Stream (Output));
      end;
   end To_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  which their values.
   --  Returns the object map that was restored.
   --  -----------------------
   function From_JSON (Content : in String) return Util.Beans.Objects.Maps.Map is
      Result  : aliased Util.Beans.Objects.Maps.Map;
      Parser  : Util.Serialize.IO.JSON.Parser;
      Context : aliased Object_Mapper_Context;
   begin
      Context.Map := Result'Unchecked_Access;
      Parser.Add_Mapping ("params", Object_Mapping'Access);
      Object_Mapper.Set_Context (Parser, Context'Unchecked_Access);
      Parser.Parse (Content);
      return Result;
   end From_JSON;

begin
   Object_Mapping.Add_Mapping ("param/@name", FIELD_NAME);
   Object_Mapping.Add_Mapping ("param", FIELD_VALUE);
end Util.Serialize.Tools;

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

with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.IO.JSON;
with Util.Serialize.Mappers.Record_Mapper;
package body Util.Serialize.Tools is

   type Object_Field is (FIELD_NAME, FIELD_VALUE);
   type Object_Map_Access is access all Util.Beans.Objects.Maps.Map'Class;

   type Object_Mapper_Context is record
      Map  : Object_Map_Access;
      Name : Util.Beans.Objects.Object;
   end record;
   type Object_Mapper_Context_Access is access all Object_Mapper_Context;

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_VALUE =>
            Into.Map.Include (Util.Beans.Objects.To_String (Into.Name), Value);
            Into.Name := Util.Beans.Objects.Null_Object;

      end case;
   end Set_Member;

   package Object_Mapper is new
     Util.Serialize.Mappers.Record_Mapper (Element_Type        => Object_Mapper_Context,
                                           Element_Type_Access => Object_Mapper_Context_Access,
                                           Fields              => Object_Field,
                                           Set_Member          => Set_Member);

   Object_Mapping : aliased Object_Mapper.Mapper;

   procedure To_JSON (Output : in out Util.Serialize.IO.JSON.Output_Stream;
                     Map    : in Util.Beans.Objects.Maps.Map) is
      use type Ada.Containers.Count_Type;

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object) is
      begin
         Output.Start_Entity (Name => "");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_Attribute (Name  => "value",
                                 Value => Value);
         Output.End_Entity (Name => "");
      end Write;

   begin
      if Map.Length > 0 then
         declare
            Iter : Util.Beans.Objects.Maps.Cursor := Map.First;
         begin
            Output.Start_Array (Name   => "params",
                                Length => Map.Length);
            while Util.Beans.Objects.Maps.Has_Element (Iter) loop
               Util.Beans.Objects.Maps.Query_Element (Iter, Write'Access);
               Util.Beans.Objects.Maps.Next (Iter);
            end loop;
            Output.End_Array;
         end;
      end if;
   end To_JSON;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into an XML stream.
   --  Returns the JSON string that contains a serialization of the object maps.
   --  -----------------------
   function To_JSON (Map : in Util.Beans.Objects.Maps.Map) return String is
      use type Ada.Containers.Count_Type;
   begin
      if Map.Length = 0 then
         return "";
      end if;
      declare
         Output : Util.Serialize.IO.JSON.Output_Stream;
      begin
         Output.Initialize (Size => 10000);
         Output.Start_Document;
         To_JSON (Output, Map);
         Output.End_Document;
         return Util.Streams.Texts.To_String (Util.Streams.Buffered.Buffered_Stream (Output));
      end;
   end To_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  which their values.
   --  Returns the object map that was restored.
   --  -----------------------
   function From_JSON (Content : in String) return Util.Beans.Objects.Maps.Map is
      Result  : aliased Util.Beans.Objects.Maps.Map;
      Parser  : Util.Serialize.IO.JSON.Parser;
      Context : aliased Object_Mapper_Context;
   begin
      if Content'Length > 0 then
         Context.Map := Result'Unchecked_Access;
         Parser.Add_Mapping ("/params", Object_Mapping'Access);
         Object_Mapper.Set_Context (Parser, Context'Unchecked_Access);
         Parser.Parse_String (Content);
      end if;
      return Result;
   end From_JSON;

begin
   Object_Mapping.Add_Mapping ("name", FIELD_NAME);
   Object_Mapping.Add_Mapping ("value", FIELD_VALUE);
end Util.Serialize.Tools;

Fix JSON deserialization into an object map