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

package body Wiki.Streams.Html.Builders is

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class);

   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wiki.Strings.WChar);

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wiki.Strings.WChar) is
      Code : constant Unicode_Char := Wiki.Strings.WChar'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString) is

   begin
      Stream.Start_Element (Name);
      Stream.Write_Wide_Text (Content);
      Stream.End_Element (Name);
   end Write_Wide_Element;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString) is
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in Content'Range loop
            declare
               C : constant Wiki.Strings.WChar := Content (I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wiki.Strings.WChar := Element (Content, I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
   end Start_Element;

   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String) is
   begin
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
   end End_Element;

   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      for I in Content'Range loop
         Html_Output_Builder_Stream'Class (Stream).Write_Escape (Content (I));
      end loop;
   end Write_Wide_Text;

end Wiki.Streams.Html.Builders;

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

package body Wiki.Streams.Html.Builders is

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class);

   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wiki.Strings.WChar);

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wiki.Strings.WChar) is
      Code : constant Unicode_Char := Wiki.Strings.WChar'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString) is

   begin
      Stream.Start_Element (Name);
      Stream.Write_Wide_Text (Content);
      Stream.End_Element (Name);
   end Write_Wide_Element;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString) is
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in Content'Range loop
            declare
               C : constant Wiki.Strings.WChar := Content (I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString) is
      Count : constant Natural := Wiki.Strings.Length (Content);
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wiki.Strings.WChar := Wiki.Strings.Element (Content, I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
   end Start_Element;

   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String) is
   begin
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
   end End_Element;

   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      for I in Content'Range loop
         Html_Output_Builder_Stream'Class (Stream).Write_Escape (Content (I));
      end loop;
   end Write_Wide_Text;

end Wiki.Streams.Html.Builders;

Use the Wiki.Strings.UString type and operations


-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  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.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;
with Ada.Finalization;

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Readers.Streams.Sockets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is recieved.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is new Ada.Finalization.Limited_Controlled with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

end MAT.Targets;

-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  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.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;
with Ada.Finalization;

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Readers.Streams.Sockets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is recieved.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is new Ada.Finalization.Limited_Controlled with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   procedure Interactive (Target : in out MAT.Targets.Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

end MAT.Targets;

Move the Interactive procedure in MAT.Targets


-----------------------------------------------------------------------
--  awa-storages-stores -- The storage interface
--  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 ADO.Sessions;

with AWA.Storages.Models;
package AWA.Storages.Stores is

   --  ------------------------------
   --  Store Service
   --  ------------------------------
   type Store is limited interface;
   type Store_Access is access all Store'Class;

   procedure Save (Storage : in Store;
                   Into    : in out AWA.Storages.Models.Storage_Ref'Class;
                   Path    : in String) is abstract;

   procedure Load (Storage : in Store;
                   From    : in AWA.Storages.Models.Storage_Ref'Class;
                   Into    : in String) is abstract;

end AWA.Storages.Stores;

-----------------------------------------------------------------------
--  awa-storages-stores -- The storage interface
--  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 ADO.Sessions;

with AWA.Storages.Models;

--  == Store Service ==
--  The `AWA.Storages.Stores` package defines the interface that a store must implement to
--  be able to save and retrieve a data content.
package AWA.Storages.Stores is

   --  ------------------------------
   --  Store Service
   --  ------------------------------
   type Store is limited interface;
   type Store_Access is access all Store'Class;

   --  Save the file represented by the `Path` variable into a store and associate that
   --  content with the storage reference represented by `Into`.
   procedure Save (Storage : in Store;
                   Into    : in out AWA.Storages.Models.Storage_Ref'Class;
                   Path    : in String) is abstract;

   procedure Load (Storage : in Store;
                   From    : in AWA.Storages.Models.Storage_Ref'Class;
                   Into    : in String) is abstract;

end AWA.Storages.Stores;

Update the documentation

Update the documentation


-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for question service
--  Copyright (C) 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.Tests;
with AWA.Tests;

package AWA.Questions.Services.Tests is

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

   type Test is new AWA.Tests.Test with record
      Manager : AWA.Questions.Services.Question_Service_Access;
   end record;

   --  Test creation of a question.
   procedure Test_Create_Question (T : in out Test);

   --  Test list of questions.
   procedure Test_List_Questions (T : in out Test);

end AWA.Questions.Services.Tests;

-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for question service
--  Copyright (C) 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.Tests;
with AWA.Tests;

package AWA.Questions.Services.Tests is

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

   type Test is new AWA.Tests.Test with record
      Manager : AWA.Questions.Services.Question_Service_Access;
   end record;

   --  Test creation of a question.
   procedure Test_Create_Question (T : in out Test);

   --  Test list of questions.
   procedure Test_List_Questions (T : in out Test);

   --  Test anonymous user voting for a question.
   procedure Test_Question_Vote_Anonymous (T : in out Test);

   --  Test voting for a question.
   procedure Test_Question_Vote (T : in out Test);

private

   --  Do a vote on a question through the question vote bean.
   procedure Do_Vote (T : in out Test);

end AWA.Questions.Services.Tests;

Add unit tests for the questionVote bean


-----------------------------------------------------------------------
--  awa-jobs -- AWA Jobs
--  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 Util.Serialize.Tools;
with Util.Log.Loggers;

with Ada.Tags;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with ADO.Sessions.Entities;

with AWA.Users.Models;
with AWA.Events.Models;
with AWA.Services.Contexts;
with AWA.Jobs.Modules;
with AWA.Applications;
with AWA.Events.Services;
with AWA.Modules;
package body AWA.Jobs.Services is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Jobs.Services");

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object) is
   begin
      Job.Props.Include (Name, Value);
      Job.Props_Modified := True;
   end Set_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value into a string.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String is
      Value : constant Util.Beans.Objects.Object := Job.Get_Parameter (Name);
   begin
      return Util.Beans.Objects.To_String (Value);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   --  ------------------------------
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer is
      Pos : constant Util.Beans.Objects.Maps.Cursor := Job.Props.Find (Name);
   begin
      if Util.Beans.Objects.Maps.Has_Element (Pos) then
         declare
            Value : constant Util.Beans.Objects.Object := Util.Beans.Objects.Maps.Element (Pos);
         begin
            if Util.Beans.Objects.Is_Null (Value) then
               return Default;
            else
               return Util.Beans.Objects.To_Integer (Value);
            end if;
         end;
      else
         return Default;
      end if;
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and return it as a typed object.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object is
   begin
      return Job.Props.Element (Name);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job status.
   --  ------------------------------
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type is
   begin
      return Job.Job.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   --  ------------------------------
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type) is
   begin
      case Job.Job.Get_Status is
         when AWA.Jobs.Models.CANCELED | Models.FAILED | Models.TERMINATED =>
            raise Closed_Error;

         when Models.SCHEDULED | Models.RUNNING =>
            Job.Job.Set_Status (Status);

      end case;
   end Set_Status;

   --  ------------------------------
   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   --  ------------------------------
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class) is
   begin
      if Job.Results_Modified then
         Job.Job.Set_Results (Util.Serialize.Tools.To_JSON (Job.Results));
         Job.Results_Modified := False;
      end if;
      Job.Job.Save (DB);
   end Save;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class) is

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
      DB   : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Msg  : AWA.Events.Models.Message_Ref;
      User : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Sess : constant AWA.Users.Models.Session_Ref := Ctx.Get_User_Session;
      App  : constant AWA.Applications.Application_Access := Ctx.Get_Application;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Job_Create_Event.Kind);
         Manager.Set_Event_Queue (Msg, "job-queue");
      end Set_Event;

   begin
      if Job.Job.Is_Inserted then
         Log.Error ("Job is already scheduled");
         raise Schedule_Error with "The job is already scheduled.";
      end if;
      AWA.Jobs.Modules.Create_Event (Msg);
      Job.Job.Set_Create_Date (Msg.Get_Create_Date);

      DB.Begin_Transaction;
      Job.Job.Set_Name (Definition.Get_Name);
      Job.Job.Set_User (User);
      Job.Job.Set_Session (Sess);
      Job.Save (DB);

      --  Create the event
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Job.Props));
      App.Do_Event_Manager (Process => Set_Event'Access);
      Msg.Set_User (User);
      Msg.Set_Session (Sess);
      Msg.Set_Entity_Id (Job.Job.Get_Id);
      Msg.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (Session => DB,
                                                                   Object  => Job.Job.Get_Key));
      Msg.Save (DB);

      Job.Job.Set_Event (Msg);
      Job.Job.Save (DB);
      DB.Commit;
   end Schedule;

   --  ------------------------------
   --  Execute the job and save the job information in the database.
   --  ------------------------------
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class) is
      use type AWA.Jobs.Models.Job_Status_Type;
   begin
      --  Execute the job with an exception guard.
      begin
         Job.Execute;

      exception
         when E : others =>
            Log.Error ("Exception when executing job {0}", Job.Job.Get_Name);
            Log.Error ("Exception: {0}", E, True);
            Job.Job.Set_Status (Models.FAILED);
      end;

      --  If the job did not set a completion status, mark it as terminated.
      if Job.Job.Get_Status = Models.SCHEDULED or Job.Job.Get_Status = Models.RUNNING then
         Job.Job.Set_Status (Models.TERMINATED);
      end if;

      --  And save the job.
      DB.Begin_Transaction;
      Job.Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => True, Value => Ada.Calendar.Clock));
      Job.Save (DB);
      DB.Commit;
   end Execute;

   --  ------------------------------
   --  Execute the job associated with the given event.
   --  ------------------------------
   procedure Execute (Event : in AWA.Events.Module_Event'Class) is
      use AWA.Jobs.Modules;
      use type AWA.Modules.Module_Access;

      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Abstract_Job_Type'Class,
                                         Name   => Abstract_Job_Access);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      App    : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      Module : constant AWA.Modules.Module_Access := App.Find_Module (AWA.Jobs.Modules.NAME);
      DB     : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Job    : AWA.Jobs.Models.Job_Ref;
   begin
      if Module = null then
         Log.Warn ("There is no Job module to execute a job");
         raise Execute_Error;
      end if;
      if not (Module.all in AWA.Jobs.Modules.Job_Module'Class) then
         Log.Warn ("The 'job' module is not a valid module for job execution");
         raise Execute_Error;
      end if;

      DB.Begin_Transaction;
      Job.Load (Session => DB,
                Id      => Event.Get_Entity_Identifier);
      Job.Set_Start_Date (ADO.Nullable_Time '(Is_Null => False, Value => Ada.Calendar.Clock));
      Job.Set_Status (AWA.Jobs.Models.RUNNING);
      Job.Save (Session => DB);
      DB.Commit;

      declare
         Name : constant String := Job.Get_Name;
      begin
         Log.Info ("Restoring job '{0}'", Name);
         declare
            Plugin  : constant Job_Module_Access := Job_Module'Class (Module.all)'Access;
            Factory : constant Job_Factory_Access := Plugin.Find_Factory (Name);
            Work    : AWA.Jobs.Services.Abstract_Job_Access := null;
         begin
            if Factory /= null then
               Work := Factory.Create;
               Work.Job := Job;
               Work.Execute (DB);
               Free (Work);
            else
               Log.Error ("There is no factory to execute job '{0}'", Name);
               Job.Set_Status (AWA.Jobs.Models.FAILED);
               DB.Begin_Transaction;
               Job.Save (Session => DB);
               DB.Commit;
            end if;
         end;
      end;
   end Execute;

   function Get_Name (Factory : in Job_Factory'Class) return String is
   begin
      return Ada.Tags.Expanded_Name (Factory'Tag);
   end Get_Name;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class) is
   begin
      Job.Work := Work.Work;
      Job.Job.Set_Name (Work.Get_Name);
   end Set_Work;

   procedure Execute (Job : in out Job_Type) is
   begin
      Job.Work (Job);
   end Execute;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access is
   begin
      return new Job_Type '(Ada.Finalization.Limited_Controlled with
                              Work => Factory.Work,
                              others => <>);
   end Create;

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   package body Definition is

      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access is
         pragma Unreferenced (Factory);
      begin
         return new T;
      end Create;

   end Definition;

end AWA.Jobs.Services;

-----------------------------------------------------------------------
--  awa-jobs -- AWA Jobs
--  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 Util.Serialize.Tools;
with Util.Log.Loggers;

with Ada.Tags;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with ADO.Sessions.Entities;

with AWA.Users.Models;
with AWA.Events.Models;
with AWA.Services.Contexts;
with AWA.Jobs.Modules;
with AWA.Applications;
with AWA.Events.Services;
with AWA.Modules;
package body AWA.Jobs.Services is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Jobs.Services");

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object) is
   begin
      Job.Props.Include (Name, Value);
      Job.Props_Modified := True;
   end Set_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value into a string.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String is
      Value : constant Util.Beans.Objects.Object := Job.Get_Parameter (Name);
   begin
      return Util.Beans.Objects.To_String (Value);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   --  ------------------------------
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer is
      Pos : constant Util.Beans.Objects.Maps.Cursor := Job.Props.Find (Name);
   begin
      if Util.Beans.Objects.Maps.Has_Element (Pos) then
         declare
            Value : constant Util.Beans.Objects.Object := Util.Beans.Objects.Maps.Element (Pos);
         begin
            if Util.Beans.Objects.Is_Null (Value) then
               return Default;
            else
               return Util.Beans.Objects.To_Integer (Value);
            end if;
         end;
      else
         return Default;
      end if;
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and return it as a typed object.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object is
   begin
      return Job.Props.Element (Name);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job status.
   --  ------------------------------
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type is
   begin
      return Job.Job.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   --  ------------------------------
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type) is
   begin
      case Job.Job.Get_Status is
         when AWA.Jobs.Models.CANCELED | Models.FAILED | Models.TERMINATED =>
            raise Closed_Error;

         when Models.SCHEDULED | Models.RUNNING =>
            Job.Job.Set_Status (Status);

      end case;
   end Set_Status;

   --  ------------------------------
   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   --  ------------------------------
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class) is
   begin
      if Job.Results_Modified then
         Job.Job.Set_Results (Util.Serialize.Tools.To_JSON (Job.Results));
         Job.Results_Modified := False;
      end if;
      Job.Job.Save (DB);
   end Save;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class) is

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
      DB   : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Msg  : AWA.Events.Models.Message_Ref;
      User : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Sess : constant AWA.Users.Models.Session_Ref := Ctx.Get_User_Session;
      App  : constant AWA.Applications.Application_Access := Ctx.Get_Application;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Job_Create_Event.Kind);
         Manager.Set_Event_Queue (Msg, "job-queue");
      end Set_Event;

   begin
      if Job.Job.Is_Inserted then
         Log.Error ("Job is already scheduled");
         raise Schedule_Error with "The job is already scheduled.";
      end if;
      AWA.Jobs.Modules.Create_Event (Msg);
      Job.Job.Set_Create_Date (Msg.Get_Create_Date);

      DB.Begin_Transaction;
      Job.Job.Set_Name (Definition.Get_Name);
      Job.Job.Set_User (User);
      Job.Job.Set_Session (Sess);
      Job.Save (DB);

      --  Create the event
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Job.Props));
      App.Do_Event_Manager (Process => Set_Event'Access);
      Msg.Set_User (User);
      Msg.Set_Session (Sess);
      Msg.Set_Entity_Id (Job.Job.Get_Id);
      Msg.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (Session => DB,
                                                                   Object  => Job.Job.Get_Key));
      Msg.Save (DB);

      Job.Job.Set_Event (Msg);
      Job.Job.Save (DB);
      DB.Commit;
   end Schedule;

   --  ------------------------------
   --  Execute the job and save the job information in the database.
   --  ------------------------------
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class) is
      use type AWA.Jobs.Models.Job_Status_Type;
   begin
      --  Execute the job with an exception guard.
      begin
         Job.Execute;

      exception
         when E : others =>
            Log.Error ("Exception when executing job {0}", Job.Job.Get_Name);
            Log.Error ("Exception:", E, True);
            Job.Job.Set_Status (Models.FAILED);
      end;

      --  If the job did not set a completion status, mark it as terminated.
      if Job.Job.Get_Status = Models.SCHEDULED or Job.Job.Get_Status = Models.RUNNING then
         Job.Job.Set_Status (Models.TERMINATED);
      end if;

      --  And save the job.
      DB.Begin_Transaction;
      Job.Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                   Value   => Ada.Calendar.Clock));
      Job.Save (DB);
      DB.Commit;
   end Execute;

   --  ------------------------------
   --  Execute the job associated with the given event.
   --  ------------------------------
   procedure Execute (Event : in AWA.Events.Module_Event'Class) is
      use AWA.Jobs.Modules;
      use type AWA.Modules.Module_Access;

      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Abstract_Job_Type'Class,
                                         Name   => Abstract_Job_Access);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      App    : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      Module : constant AWA.Modules.Module_Access := App.Find_Module (AWA.Jobs.Modules.NAME);
      DB     : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Job    : AWA.Jobs.Models.Job_Ref;
   begin
      if Module = null then
         Log.Warn ("There is no Job module to execute a job");
         raise Execute_Error;
      end if;
      if not (Module.all in AWA.Jobs.Modules.Job_Module'Class) then
         Log.Warn ("The 'job' module is not a valid module for job execution");
         raise Execute_Error;
      end if;

      DB.Begin_Transaction;
      Job.Load (Session => DB,
                Id      => Event.Get_Entity_Identifier);
      Job.Set_Start_Date (ADO.Nullable_Time '(Is_Null => False, Value => Ada.Calendar.Clock));
      Job.Set_Status (AWA.Jobs.Models.RUNNING);
      Job.Save (Session => DB);
      DB.Commit;

      declare
         Name : constant String := Job.Get_Name;
      begin
         Log.Info ("Restoring job '{0}'", Name);
         declare
            Plugin  : constant Job_Module_Access := Job_Module'Class (Module.all)'Access;
            Factory : constant Job_Factory_Access := Plugin.Find_Factory (Name);
            Work    : AWA.Jobs.Services.Abstract_Job_Access := null;
         begin
            if Factory /= null then
               Work := Factory.Create;
               Work.Job := Job;
               Work.Execute (DB);
               Free (Work);
            else
               Log.Error ("There is no factory to execute job '{0}'", Name);
               Job.Set_Status (AWA.Jobs.Models.FAILED);
               Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                        Value   => Ada.Calendar.Clock));
               DB.Begin_Transaction;
               Job.Save (Session => DB);
               DB.Commit;
            end if;
         end;
      end;
   end Execute;

   function Get_Name (Factory : in Job_Factory'Class) return String is
   begin
      return Ada.Tags.Expanded_Name (Factory'Tag);
   end Get_Name;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class) is
   begin
      Job.Work := Work.Work;
      Job.Job.Set_Name (Work.Get_Name);
   end Set_Work;

   procedure Execute (Job : in out Job_Type) is
   begin
      Job.Work (Job);
   end Execute;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access is
   begin
      return new Job_Type '(Ada.Finalization.Limited_Controlled with
                              Work => Factory.Work,
                              others => <>);
   end Create;

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   package body Definition is

      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access is
         pragma Unreferenced (Factory);
      begin
         return new T;
      end Create;

   end Definition;

end AWA.Jobs.Services;

Fix setting the finish date after job execution


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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test, "Users.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      AWA.Tests.Helpers.Users.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         AWA.Tests.Helpers.Users.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : AWA.Tests.Helpers.Users.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         AWA.Tests.Helpers.Users.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      AWA.Tests.Helpers.Users.Create_User (Principal);
      AWA.Tests.Helpers.Users.Logout (Principal);

      AWA.Tests.Helpers.Users.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         --  Storing a date in the database will loose some precision.
         T.Assert (S1.Get_Start_Date.Value >= T1 - 1.0, "Start date is invalid 1");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type AWA.Users.Principals.Principal_Access;

      Principal : AWA.Tests.Helpers.Users.Test_User;
      Key       : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      AWA.Tests.Helpers.Users.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      AWA.Tests.Helpers.Users.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key       => Key.Get_Access_Key,
                                           Password  => "newadmin",
                                           IpAddr    => "192.168.1.2",
                                           Principal => Principal.Principal);
         T.Assert (Principal.Principal /= null, "No principal returned");

         Principal.User    := Principal.Principal.Get_User;
         Principal.Session := Principal.Principal.Get_Session;

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      AWA.Tests.Helpers.Users.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Modules.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Modules.User_Module_Access := AWA.Users.Modules.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Modules.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Modules.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

Fix indentation

Fix indentation


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

with Bfd.Symbols;
with Bfd.Files;

with Util.Refs;

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

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

   subtype Target_Symbols_Ref is Target_Symbols_Refs.Ref;

end MAT.Symbols.Targets;

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

with Bfd.Symbols;
with Bfd.Files;

with Util.Refs;

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

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

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

   subtype Library_Symbols_Ref is Library_Symbols_Refs.Ref;

   --  The <tt>Symbols_Maps</tt> keeps a sorted list of symbol tables indexed
   --  by their mapping address.
   use type Library_Symbols_Refs.Ref;
   use type MAT.Types.Target_Addr;
   package Symbols_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Library_Symbols_Ref);

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

   subtype Target_Symbols_Ref is Target_Symbols_Refs.Ref;

end MAT.Symbols.Targets;

Define the Library_Symbols type to hold the symbol table of a shared library Define the Symbols_Maps package to hold a sorted list of shared library symbols


-----------------------------------------------------------------------
--  streams.texts.tests -- Unit tests for text streams
--  Copyright (C) 2012, 2021 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 Util.Streams.Texts.Tests is

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

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

   --  Test reading a text stream.
   procedure Test_Read_Line (T : in out Test);

   --  Write on a text stream converting an integer and writing it.
   procedure Test_Write_Integer (T : in out Test);

end Util.Streams.Texts.Tests;

-----------------------------------------------------------------------
--  streams.texts.tests -- Unit tests for text streams
--  Copyright (C) 2012, 2021 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 Util.Streams.Texts.Tests is

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

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

   --  Test reading a text stream.
   procedure Test_Read_Line (T : in out Test);

   --  Write on a text stream converting an integer and writing it.
   procedure Test_Write_Integer (T : in out Test);

   --  Write on a text stream converting an integer and writing it.
   procedure Test_Write_Long_Integer (T : in out Test);

end Util.Streams.Texts.Tests;

Declare the Test_Write_Long_Integer procedure


-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 2021 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 Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 2021, 2022 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 Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   procedure Inline_Iterate (Source  : in Builder) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Inline_Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

Implement Inline_Iterate generic

Implement Inline_Iterate generic