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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

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

   use Ada.Strings.Unbounded;

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

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

      --  The column type name.
      Type_Name : Unbounded_String;

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

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

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

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

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

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

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

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

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

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

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

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

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

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Validate the definition by checking and reporting problems to the logger interface.
   overriding
   procedure Validate (Def : in out Column_Definition;
                       Log : in out Util.Log.Logging'Class);

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

   --  Returns true if the column is using a variable length (ex: a string).
   function Is_Variable_Length (From : Column_Definition) return Boolean;

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

   --  Set the column type.
   procedure Set_Type (Into : in out Column_Definition;
                       Name : in String);

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

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

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

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

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

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

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

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

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

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

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

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Validate the definition by checking and reporting problems to the logger interface.
   overriding
   procedure Validate (Def : in out Table_Definition;
                       Log : in out Util.Log.Logging'Class);

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

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

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

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

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

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

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

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

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

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

   subtype Table_Cursor is Table_Map.Cursor;

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

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

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

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

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

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

   use Ada.Strings.Unbounded;

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

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

      --  The column type name.
      Type_Name : Unbounded_String;

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

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

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

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

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

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

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

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

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

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

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

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

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

      --  The type mapping of the column.
      Type_Mapping : Gen.Model.Mappings.Mapping_Definition_Access;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Validate the definition by checking and reporting problems to the logger interface.
   overriding
   procedure Validate (Def : in out Column_Definition;
                       Log : in out Util.Log.Logging'Class);

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

   --  Returns true if the column is using a variable length (ex: a string).
   function Is_Variable_Length (From : Column_Definition) return Boolean;

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

   --  Set the column type.
   procedure Set_Type (Into : in out Column_Definition;
                       Name : in String);

   --  Set the SQL length of the column.
   procedure Set_Sql_Length (Into  : in out Column_Definition;
                             Value : in String;
                             Log   : in out Util.Log.Logging'Class);

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

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

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

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

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

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

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

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

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

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

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

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

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

   --  Validate the definition by checking and reporting problems to the logger interface.
   overriding
   procedure Validate (Def : in out Table_Definition;
                       Log : in out Util.Log.Logging'Class);

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

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

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

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

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

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

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

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

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

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

   subtype Table_Cursor is Table_Map.Cursor;

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

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

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

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

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

Declare Set_Sql_Length procedure to set/verify the sql length of a column


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

------------------------------------------------------------------------------
-- IMPLEMENTATION NOTE:                                                     --
-- In case of synchronized callbacks (same Origin and Period), there is a   --
-- collision on the internal map key. Since it is not expected to happen    --
-- often, a simple but not-so-efficient solution is used:                   --
-- When a collision is encountered, the callback is replaced by an          --
-- Event_List callback seeded with the existing callback and the new one.   --
-- When removing a callback, if it's not found directly, and second linear  --
-- is performed, looking for Event_List objects and removing it from them.  --
------------------------------------------------------------------------------

package body Natools.Cron is

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference;
      --  Create an Event_List object containing Ref_1 and Ref_2,
      --  and return a reference to it.

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function "<" (Left, Right : Periodic_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      return Left.Origin < Right.Origin
        or else (Left.Origin = Right.Origin
           and then Left.Period < Right.Period);
   end "<";

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference
   is
      function Create return Callback'Class;

      function Create return Callback'Class is
         Result : Event_List;
      begin
         Result.Append (Ref_1);
         Result.Append (Ref_2);
         return Result;
      end Create;
   begin
      return Callback_Refs.Create (Create'Access);
   end Create_Event_List;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Time, Callback);
      end return;
   end Create;

   function Create
     (Origin : in Ada.Calendar.Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Origin, Callback);
      end return;
   end Create;

   function Create
     (Period : in Duration;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Period, Callback);
      end return;
   end Create;

   procedure Set
     (Self : in out Cron_Entry;
      Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
   is
      function Create return Cron.Callback'Class;

      function Create return Cron.Callback'Class is
      begin
         return Callback;
      end Create;
   begin
      Self.Reset;
      Self.Callback.Replace (Create'Access);
      Database.Insert (Time, Self.Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Origin : in Ada.Calendar.Time;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Origin, 0.0), Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Period : in Duration;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Ada.Calendar.Clock, Period), Callback);
   end Set;

   overriding procedure Finalize (Object : in out Cron_Entry) is
   begin
      if not Object.Callback.Is_Empty then
         Object.Reset;
      end if;
   end Finalize;

   procedure Reset (Self : in out Cron_Entry) is
   begin
      if not Self.Callback.Is_Empty then
         Database.Remove (Self.Callback);
         Self.Callback.Reset;
      end if;
   end Reset;

   ------------------------
   -- Protected Database --
   ------------------------

   protected body Database is
      procedure Insert
        (Time : in Periodic_Time;
         Callback : in Callback_Refs.Reference)
      is
         use type Ada.Calendar.Time;

         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Actual_Time : Periodic_Time := Time;
      begin
         if Actual_Time.Period > 0.0 then
            while Actual_Time.Origin < Now loop
               Actual_Time.Origin := Actual_Time.Origin + Actual_Time.Period;
            end loop;
         end if;

         if Map.Is_Empty then
            if Global_Worker /= null and then Global_Worker.all'Terminated then
               Unchecked_Free (Global_Worker);
            end if;

            if Global_Worker = null then
               Global_Worker := new Worker;
            end if;
         else
            if Actual_Time < Map.First_Key then
               First_Changed := True;
            end if;
         end if;

         declare
            Position : Entry_Maps.Cursor;
            Inserted : Boolean;
            Previous : Callback_Refs.Reference;
         begin
            Map.Insert (Actual_Time, Callback, Position, Inserted);

            if not Inserted then
               Previous := Entry_Maps.Element (Position);

               if Previous.Update.Data.all in Event_List then
                  Append
                    (Event_List (Previous.Update.Data.all),
                     Callback);
               else
                  Map.Replace_Element
                    (Position,
                     Create_Event_List (Previous, Callback));
               end if;
            end if;
         end;
      end Insert;

      procedure Remove (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;

         Cursor : Entry_Maps.Cursor := Map.First;
         Is_First : Boolean := True;
      begin
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               Map.Delete (Cursor);

               if Is_First then
                  First_Changed := True;
               end if;

               return;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;

         Is_First := True;
         Cursor := Map.First;
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor).Update.Data.all in Event_List then
               declare
                  Mutator : constant Callback_Refs.Mutator
                    := Entry_Maps.Element (Cursor).Update;
                  List : Event_List renames Event_List (Mutator.Data.all);
                  Removed : Boolean;
               begin
                  List.Remove (Callback, Removed);

                  if Removed then
                     if List.Is_Empty then
                        Map.Delete (Cursor);

                        if Is_First then
                           First_Changed := True;
                        end if;
                     end if;

                     return;
                  end if;
               end;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;
      end Remove;

      procedure Update (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;
         Cursor : Entry_Maps.Cursor := Map.First;
      begin
         Search :
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               declare
                  Old_Time : constant Periodic_Time := Entry_Maps.Key (Cursor);
               begin
                  Map.Delete (Cursor);

                  if Old_Time.Period > 0.0 then
                     Insert (Old_Time, Callback);
                  end if;
               end;

               exit Search;
            end if;

            Entry_Maps.Next (Cursor);
         end loop Search;
      end Update;

      procedure Get_First
        (Time : out Periodic_Time;
         Callback : out Callback_Refs.Reference)
      is
         Cursor : constant Entry_Maps.Cursor := Map.First;
      begin
         if Entry_Maps.Has_Element (Cursor) then
            Time := Entry_Maps.Key (Cursor);
            Callback := Entry_Maps.Element (Cursor);
         else
            Callback := Callback_Refs.Null_Reference;
         end if;

         First_Changed := False;
      end Get_First;

      procedure Get_Event_List
        (Source : in Event_List;
         List : out Event_Lists.List) is
      begin
         List := Source.List;
      end Get_Event_List;

      entry Update_Notification when First_Changed is
      begin
         null;
      end Update_Notification;

   end Database;

   -----------------
   -- Worker Task --
   -----------------

   task body Worker is
      Time : Periodic_Time;
      Callback : Callback_Refs.Reference;
      Waiting : Boolean;
   begin
      Main :
      loop
         Waiting := True;

         Wait_Loop :
         while Waiting loop
            Database.Get_First (Time, Callback);
            exit Main when Callback.Is_Empty;

            select
               Database.Update_Notification;
            or
               delay until Time.Origin;
               Waiting := False;
            end select;
         end loop Wait_Loop;

         Callback.Update.Data.Run;
         Database.Update (Callback);
      end loop Main;
   end Worker;

   ----------------
   -- Event List --
   ----------------

   overriding procedure Run (Self : in out Event_List) is
      Local_List : Event_Lists.List;
   begin
      Database.Get_Event_List (Self, Local_List);

      for Ref of Local_List loop
         Ref.Update.Data.Run;
      end loop;
   end Run;

   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference) is
   begin
      Self.List.Append (Ref);
   end Append;

   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean)
   is
      use type Callback_Refs.Reference;
      Cursor : Event_Lists.Cursor := Self.List.First;
   begin
      Removed := False;

      while Event_Lists.Has_Element (Cursor) loop
         if Event_Lists.Element (Cursor) = Ref then
            Self.List.Delete (Cursor);
            Removed := True;
            return;
         end if;

         Event_Lists.Next (Cursor);
      end loop;
   end Remove;

   function Is_Empty (Self : Event_List) return Boolean is
   begin
      return Self.List.Is_Empty;
   end Is_Empty;

end Natools.Cron;

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

------------------------------------------------------------------------------
-- IMPLEMENTATION NOTE:                                                     --
-- In case of synchronized callbacks (same Origin and Period), there is a   --
-- collision on the internal map key. Since it is not expected to happen    --
-- often, a simple but not-so-efficient solution is used:                   --
-- When a collision is encountered, the callback is replaced by an          --
-- Event_List callback seeded with the existing callback and the new one.   --
-- When removing a callback, if it's not found directly, and second linear  --
-- is performed, looking for Event_List objects and removing it from them.  --
------------------------------------------------------------------------------

package body Natools.Cron is

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference;
      --  Create an Event_List object containing Ref_1 and Ref_2,
      --  and return a reference to it.

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function "<" (Left, Right : Periodic_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      return Left.Origin < Right.Origin
        or else (Left.Origin = Right.Origin
           and then Left.Period < Right.Period);
   end "<";

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference
   is
      function Create return Callback'Class;

      function Create return Callback'Class is
         Result : Event_List;
      begin
         Result.Append (Ref_1);
         Result.Append (Ref_2);
         return Result;
      end Create;
   begin
      return Callback_Refs.Create (Create'Access);
   end Create_Event_List;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Time, Callback);
      end return;
   end Create;

   function Create
     (Origin : in Ada.Calendar.Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Origin, Callback);
      end return;
   end Create;

   function Create
     (Period : in Duration;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Period, Callback);
      end return;
   end Create;

   procedure Set
     (Self : in out Cron_Entry;
      Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
   is
      function Create return Cron.Callback'Class;

      function Create return Cron.Callback'Class is
      begin
         return Callback;
      end Create;
   begin
      Self.Reset;
      Self.Callback.Replace (Create'Access);
      Database.Insert (Time, Self.Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Origin : in Ada.Calendar.Time;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Origin, 0.0), Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Period : in Duration;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Ada.Calendar.Clock, Period), Callback);
   end Set;

   overriding procedure Finalize (Object : in out Cron_Entry) is
   begin
      if not Object.Callback.Is_Empty then
         Object.Reset;
      end if;
   end Finalize;

   procedure Reset (Self : in out Cron_Entry) is
   begin
      if not Self.Callback.Is_Empty then
         Database.Remove (Self.Callback);
         Self.Callback.Reset;
      end if;
   end Reset;

   ------------------------
   -- Protected Database --
   ------------------------

   protected body Database is
      procedure Insert
        (Time : in Periodic_Time;
         Callback : in Callback_Refs.Reference)
      is
         use type Ada.Calendar.Time;

         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Actual_Time : Periodic_Time := Time;
      begin
         if Actual_Time.Period > 0.0 then
            while Actual_Time.Origin < Now loop
               Actual_Time.Origin := Actual_Time.Origin + Actual_Time.Period;
            end loop;
         end if;

         if Map.Is_Empty then
            if Global_Worker /= null and then Global_Worker.all'Terminated then
               Unchecked_Free (Global_Worker);
            end if;

            if Global_Worker = null then
               Global_Worker := new Worker;
            end if;
         else
            if Actual_Time < Map.First_Key then
               First_Changed := True;
            end if;
         end if;

         declare
            Position : Entry_Maps.Cursor;
            Inserted : Boolean;
            Previous : Callback_Refs.Reference;
         begin
            Map.Insert (Actual_Time, Callback, Position, Inserted);

            if not Inserted then
               Previous := Entry_Maps.Element (Position);

               if Previous.Query.Data.all in Event_List then
                  if Callback.Query.Data.all in Event_List then
                     for I of Event_List (Callback.Query.Data.all).List loop
                        Append (Event_List (Previous.Update.Data.all), I);
                     end loop;
                  else
                     Append
                       (Event_List (Previous.Update.Data.all),
                        Callback);
                  end if;
               elsif Callback.Query.Data.all in Event_List then
                  Append (Event_List (Callback.Update.Data.all), Previous);
                  Map.Replace_Element (Position, Callback);
               else
                  Map.Replace_Element
                    (Position,
                     Create_Event_List (Previous, Callback));
               end if;
            end if;
         end;
      end Insert;

      procedure Remove (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;

         Cursor : Entry_Maps.Cursor := Map.First;
         Is_First : Boolean := True;
      begin
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               Map.Delete (Cursor);

               if Is_First then
                  First_Changed := True;
               end if;

               return;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;

         Is_First := True;
         Cursor := Map.First;
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor).Update.Data.all in Event_List then
               declare
                  Mutator : constant Callback_Refs.Mutator
                    := Entry_Maps.Element (Cursor).Update;
                  List : Event_List renames Event_List (Mutator.Data.all);
                  Removed : Boolean;
               begin
                  List.Remove (Callback, Removed);

                  if Removed then
                     if List.Is_Empty then
                        Map.Delete (Cursor);

                        if Is_First then
                           First_Changed := True;
                        end if;
                     end if;

                     return;
                  end if;
               end;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;
      end Remove;

      procedure Update (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;
         Cursor : Entry_Maps.Cursor := Map.First;
      begin
         Search :
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               declare
                  Old_Time : constant Periodic_Time := Entry_Maps.Key (Cursor);
               begin
                  Map.Delete (Cursor);

                  if Old_Time.Period > 0.0 then
                     Insert (Old_Time, Callback);
                  end if;
               end;

               exit Search;
            end if;

            Entry_Maps.Next (Cursor);
         end loop Search;
      end Update;

      procedure Get_First
        (Time : out Periodic_Time;
         Callback : out Callback_Refs.Reference)
      is
         Cursor : constant Entry_Maps.Cursor := Map.First;
      begin
         if Entry_Maps.Has_Element (Cursor) then
            Time := Entry_Maps.Key (Cursor);
            Callback := Entry_Maps.Element (Cursor);
         else
            Callback := Callback_Refs.Null_Reference;
         end if;

         First_Changed := False;
      end Get_First;

      procedure Get_Event_List
        (Source : in Event_List;
         List : out Event_Lists.List) is
      begin
         List := Source.List;
      end Get_Event_List;

      entry Update_Notification when First_Changed is
      begin
         null;
      end Update_Notification;

   end Database;

   -----------------
   -- Worker Task --
   -----------------

   task body Worker is
      Time : Periodic_Time;
      Callback : Callback_Refs.Reference;
      Waiting : Boolean;
   begin
      Main :
      loop
         Waiting := True;

         Wait_Loop :
         while Waiting loop
            Database.Get_First (Time, Callback);
            exit Main when Callback.Is_Empty;

            select
               Database.Update_Notification;
            or
               delay until Time.Origin;
               Waiting := False;
            end select;
         end loop Wait_Loop;

         Callback.Update.Data.Run;
         Database.Update (Callback);
      end loop Main;
   end Worker;

   ----------------
   -- Event List --
   ----------------

   overriding procedure Run (Self : in out Event_List) is
      Local_List : Event_Lists.List;
   begin
      Database.Get_Event_List (Self, Local_List);

      for Ref of Local_List loop
         Ref.Update.Data.Run;
      end loop;
   end Run;

   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference) is
   begin
      Self.List.Append (Ref);
   end Append;

   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean)
   is
      use type Callback_Refs.Reference;
      Cursor : Event_Lists.Cursor := Self.List.First;
   begin
      Removed := False;

      while Event_Lists.Has_Element (Cursor) loop
         if Event_Lists.Element (Cursor) = Ref then
            Self.List.Delete (Cursor);
            Removed := True;
            return;
         end if;

         Event_Lists.Next (Cursor);
      end loop;
   end Remove;

   function Is_Empty (Self : Event_List) return Boolean is
   begin
      return Self.List.Is_Empty;
   end Is_Empty;

end Natools.Cron;

fix fusion of even list

cron: fix fusion of even list


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.Numerics.Generic_Elementary_Functions;

with AUnit.Assertions;
with AUnit.Test_Caller;
with AUnit.Test_Fixtures;

package body Generic_Test_Transforms_Quaternions is

   use Orka;
   use Quaternions;

   use AUnit.Assertions;

   use type Vector4;

   subtype Element_Type is Vectors.Element_Type;
   use type Element_Type;

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Element_Type);

   function To_Radians (Angle : Element_Type) return Element_Type renames Vectors.To_Radians;

   function Is_Equivalent (Expected, Result : Element_Type) return Boolean is
     (abs (Result - Expected) <= 2.0 * Element_Type'Model_Epsilon);

   procedure Assert_Equivalent (Expected, Result : Vector4) is
   begin
      for I in Index_4D loop
         Assert (Is_Equivalent (Expected (I), Result (I)),
           "Unexpected element " & Expected (I)'Image & " instead of " & Result (I)'Image &
           " at " & I'Image);
      end loop;
   end Assert_Equivalent;

   procedure Assert_Equivalent (Expected, Result : Quaternion) is
   begin
      for I in Index_4D loop
         Assert (Is_Equivalent (Expected (I), Result (I)),
           "Unexpected element " & Expected (I)'Image & " instead of " & Result (I)'Image &
           " at " & I'Image);
      end loop;
   end Assert_Equivalent;

   type Test is new AUnit.Test_Fixtures.Test_Fixture with null record;

   procedure Test_Multiplication (Object : in out Test) is
      Half_Angle : constant Element_Type := 45.0;
   begin
      declare
         Axis  : constant Vector4 := Vectors.Normalize ((1.0, 2.0, 3.0, 0.0));

         Sin_Value : constant Element_Type := EF.Sin (Half_Angle, 360.0);
         Cos_Value : constant Element_Type := EF.Cos (Half_Angle, 360.0);

         Result   : constant Quaternion :=
           R (Axis, To_Radians (Half_Angle)) * R (Axis, To_Radians (Half_Angle));
         Expected : constant Quaternion := (Axis (X) * Sin_Value,
                                            Axis (Y) * Sin_Value,
                                            Axis (Z) * Sin_Value,
                                            Cos_Value);
      begin
         Assert_Equivalent (Expected, Result);
         Assert (Normalized (Result), "Result not normalized");
      end;

      declare
         Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
         Angle_Radians : constant Element_Type := To_Radians (30.0);

         Rotation : constant Quaternion :=
           R (Axis, Angle_Radians) * R (Axis, Angle_Radians) * R (Axis, Angle_Radians);

         Expected : constant Vector4 := (0.0, 0.0, 1.0, 0.0);
         Result   : constant Vector4 := Rotate ((0.0, 1.0, 0.0, 0.0), Rotation);
      begin
         Assert_Equivalent (Expected, Result);
      end;
   end Test_Multiplication;

   procedure Test_Conjugate (Object : in out Test) is
      Elements : constant Quaternion := (1.0, 2.0, 3.0, 4.0);

      Expected : constant Quaternion := (-1.0, -2.0, -3.0, 4.0);
      Result   : constant Quaternion := Conjugate (Elements);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Conjugate;

   procedure Test_Norm (Object : in out Test) is
      Elements_1 : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
      Elements_2 : constant Quaternion := (-1.0, 2.0, -3.0, 4.0);
      Elements_3 : constant Quaternion := (0.0, 0.0, 0.0, 0.0);

      Result_1   : constant Element_Type := Norm (Elements_1);
      Result_2   : constant Element_Type := Norm (Elements_2);
      Result_3   : constant Element_Type := Norm (Elements_3);

      Expected_1 : constant Element_Type := EF.Sqrt (30.0);
      Expected_2 : constant Element_Type := EF.Sqrt (30.0);
      Expected_3 : constant Element_Type := 0.0;
   begin
      Assert (Is_Equivalent (Expected_1, Result_1), "Unexpected Single " & Result_1'Image);
      Assert (Is_Equivalent (Expected_2, Result_2), "Unexpected Single " & Result_2'Image);
      Assert (Is_Equivalent (Expected_3, Result_3), "Unexpected Single " & Result_3'Image);
   end Test_Norm;

   procedure Test_Normalize (Object : in out Test) is
      Elements : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
   begin
      Assert (not Normalized (Elements), "Elements is unexpectedly a unit quaternion");
      declare
         Result : constant Quaternion := Normalize (Elements);
      begin
         Assert (Normalized (Result), "Result not normalized");
      end;
   end Test_Normalize;

   procedure Test_Normalized (Object : in out Test) is
      Elements_1 : constant Quaternion := (0.0, 0.0, 0.0, 1.0);
      Elements_2 : constant Quaternion := (0.5, 0.5, 0.5, -0.5);
      Elements_3 : constant Quaternion := (0.0, -1.0, 0.0, 0.0);

      Elements_4 : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
   begin
      Assert (Normalized (Elements_1), "Elements_1 not normalized");
      Assert (Normalized (Elements_2), "Elements_2 not normalized");
      Assert (Normalized (Elements_3), "Elements_3 not normalized");

      Assert (not Normalized (Elements_4), "Elements_4 normalized");
   end Test_Normalized;

   procedure Test_Rotate_Axis_Angle (Object : in out Test) is
      Axis  : constant Vector4 := Vectors.Normalize ((1.0, 2.0, 3.0, 0.0));
      Angle : constant Element_Type := 90.0;

      Sin_Value : constant Element_Type := EF.Sin (45.0, 360.0);
      Cos_Value : constant Element_Type := EF.Cos (45.0, 360.0);

      Result   : constant Quaternion := R (Axis, To_Radians (Angle));
      Expected : constant Quaternion := (Axis (X) * Sin_Value,
                                         Axis (Y) * Sin_Value,
                                         Axis (Z) * Sin_Value,
                                         Cos_Value);
   begin
      Assert_Equivalent (Expected, Result);
      Assert (Normalized (Result), "Result not normalized");
   end Test_Rotate_Axis_Angle;

   procedure Test_Rotate_Vectors (Object : in out Test) is
      Start_Vector : constant Vector4 := (0.0, 1.0, 0.0, 0.0);
      End_Vector   : constant Vector4 := (0.0, 0.0, 1.0, 0.0);

      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 90.0;

      Expected_1 : constant Quaternion := R (Axis, To_Radians (Angle));
      Result_1   : constant Quaternion := R (Start_Vector, End_Vector);

      Expected_2 : constant Quaternion := R (Axis, To_Radians (-Angle));
      Result_2   : constant Quaternion := R (End_Vector, Start_Vector);
   begin
      Assert_Equivalent (Expected_1, Result_1);
      Assert_Equivalent (Expected_2, Result_2);
   end Test_Rotate_Vectors;

   procedure Test_Rotate (Object : in out Test) is
      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 90.0;

      Rotation : constant Quaternion := R (Axis, To_Radians (Angle));

      Expected : constant Vector4 := (0.0, 0.0, 1.0, 0.0);
      Result   : constant Vector4 := Rotate ((0.0, 1.0, 0.0, 0.0), Rotation);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Rotate;

   procedure Test_Slerp (Object : in out Test) is
      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 45.0;

      Start_Quaternion : constant Quaternion := R (Axis, To_Radians (0.0));
      End_Quaternion   : constant Quaternion := R (Axis, To_Radians (90.0));

      Expected : constant Quaternion := R (Axis, To_Radians (Angle));
      Result   : constant Quaternion := Slerp (Start_Quaternion, End_Quaternion, 0.5);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Slerp;

   ----------------------------------------------------------------------------

   package Caller is new AUnit.Test_Caller (Test);

   Test_Suite : aliased AUnit.Test_Suites.Test_Suite;

   function Suite return AUnit.Test_Suites.Access_Test_Suite is
      Name : constant String := "(Transforms - " & Suite_Name & " - Quaternions) ";
   begin
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test '*' operator", Test_Multiplication'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Conjugate function", Test_Conjugate'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Norm function", Test_Norm'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Normalize function", Test_Normalize'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Normalized function", Test_Normalized'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate_Axis_Angle function", Test_Rotate_Axis_Angle'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate_Vectors function", Test_Rotate_Vectors'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate function", Test_Rotate'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Slerp function", Test_Slerp'Access));

      return Test_Suite'Access;
   end Suite;

end Generic_Test_Transforms_Quaternions;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.Numerics.Generic_Elementary_Functions;

with AUnit.Assertions;
with AUnit.Test_Caller;
with AUnit.Test_Fixtures;

package body Generic_Test_Transforms_Quaternions is

   use Orka;
   use Quaternions;

   use AUnit.Assertions;

   use type Vector4;

   subtype Element_Type is Vectors.Element_Type;
   use type Element_Type;

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Element_Type);

   function To_Radians (Angle : Element_Type) return Element_Type renames Vectors.To_Radians;

   function Is_Equivalent (Expected, Result : Element_Type) return Boolean is
     (abs (Result - Expected) <= Element_Type'Model_Epsilon + 1.0e-05 * abs Expected);

   procedure Assert_Equivalent (Expected, Result : Vector4) is
   begin
      for I in Index_4D loop
         Assert (Is_Equivalent (Expected (I), Result (I)),
           "Unexpected element " & Expected (I)'Image & " instead of " & Result (I)'Image &
           " at " & I'Image);
      end loop;
   end Assert_Equivalent;

   procedure Assert_Equivalent (Expected, Result : Quaternion) is
   begin
      for I in Index_4D loop
         Assert (Is_Equivalent (Expected (I), Result (I)),
           "Unexpected element " & Expected (I)'Image & " instead of " & Result (I)'Image &
           " at " & I'Image);
      end loop;
   end Assert_Equivalent;

   type Test is new AUnit.Test_Fixtures.Test_Fixture with null record;

   procedure Test_Multiplication (Object : in out Test) is
      Half_Angle : constant Element_Type := 45.0;
   begin
      declare
         Axis  : constant Vector4 := Vectors.Normalize ((1.0, 2.0, 3.0, 0.0));

         Sin_Value : constant Element_Type := EF.Sin (Half_Angle, 360.0);
         Cos_Value : constant Element_Type := EF.Cos (Half_Angle, 360.0);

         Result   : constant Quaternion :=
           R (Axis, To_Radians (Half_Angle)) * R (Axis, To_Radians (Half_Angle));
         Expected : constant Quaternion := (Axis (X) * Sin_Value,
                                            Axis (Y) * Sin_Value,
                                            Axis (Z) * Sin_Value,
                                            Cos_Value);
      begin
         Assert_Equivalent (Expected, Result);
         Assert (Normalized (Result), "Result not normalized");
      end;

      declare
         Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
         Angle_Radians : constant Element_Type := To_Radians (30.0);

         Rotation : constant Quaternion :=
           R (Axis, Angle_Radians) * R (Axis, Angle_Radians) * R (Axis, Angle_Radians);

         Expected : constant Vector4 := (0.0, 0.0, 1.0, 0.0);
         Result   : constant Vector4 := Rotate ((0.0, 1.0, 0.0, 0.0), Rotation);
      begin
         Assert_Equivalent (Expected, Result);
      end;
   end Test_Multiplication;

   procedure Test_Conjugate (Object : in out Test) is
      Elements : constant Quaternion := (1.0, 2.0, 3.0, 4.0);

      Expected : constant Quaternion := (-1.0, -2.0, -3.0, 4.0);
      Result   : constant Quaternion := Conjugate (Elements);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Conjugate;

   procedure Test_Norm (Object : in out Test) is
      Elements_1 : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
      Elements_2 : constant Quaternion := (-1.0, 2.0, -3.0, 4.0);
      Elements_3 : constant Quaternion := (0.0, 0.0, 0.0, 0.0);

      Result_1   : constant Element_Type := Norm (Elements_1);
      Result_2   : constant Element_Type := Norm (Elements_2);
      Result_3   : constant Element_Type := Norm (Elements_3);

      Expected_1 : constant Element_Type := EF.Sqrt (30.0);
      Expected_2 : constant Element_Type := EF.Sqrt (30.0);
      Expected_3 : constant Element_Type := 0.0;
   begin
      Assert (Is_Equivalent (Expected_1, Result_1), "Unexpected Single " & Result_1'Image);
      Assert (Is_Equivalent (Expected_2, Result_2), "Unexpected Single " & Result_2'Image);
      Assert (Is_Equivalent (Expected_3, Result_3), "Unexpected Single " & Result_3'Image);
   end Test_Norm;

   procedure Test_Normalize (Object : in out Test) is
      Elements : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
   begin
      Assert (not Normalized (Elements), "Elements is unexpectedly a unit quaternion");
      declare
         Result : constant Quaternion := Normalize (Elements);
      begin
         Assert (Normalized (Result), "Result not normalized");
      end;
   end Test_Normalize;

   procedure Test_Normalized (Object : in out Test) is
      Elements_1 : constant Quaternion := (0.0, 0.0, 0.0, 1.0);
      Elements_2 : constant Quaternion := (0.5, 0.5, 0.5, -0.5);
      Elements_3 : constant Quaternion := (0.0, -1.0, 0.0, 0.0);

      Elements_4 : constant Quaternion := (1.0, 2.0, 3.0, 4.0);
   begin
      Assert (Normalized (Elements_1), "Elements_1 not normalized");
      Assert (Normalized (Elements_2), "Elements_2 not normalized");
      Assert (Normalized (Elements_3), "Elements_3 not normalized");

      Assert (not Normalized (Elements_4), "Elements_4 normalized");
   end Test_Normalized;

   procedure Test_Rotate_Axis_Angle (Object : in out Test) is
      Axis  : constant Vector4 := Vectors.Normalize ((1.0, 2.0, 3.0, 0.0));
      Angle : constant Element_Type := 90.0;

      Sin_Value : constant Element_Type := EF.Sin (45.0, 360.0);
      Cos_Value : constant Element_Type := EF.Cos (45.0, 360.0);

      Result   : constant Quaternion := R (Axis, To_Radians (Angle));
      Expected : constant Quaternion := (Axis (X) * Sin_Value,
                                         Axis (Y) * Sin_Value,
                                         Axis (Z) * Sin_Value,
                                         Cos_Value);
   begin
      Assert_Equivalent (Expected, Result);
      Assert (Normalized (Result), "Result not normalized");
   end Test_Rotate_Axis_Angle;

   procedure Test_Axis_Angle (Object : in out Test) is
      Axis  : constant Vector4 := Vectors.Normalize ((1.0, 2.0, 3.0, 0.0));
      Angle : constant Element_Type := 90.0;

      Expected : constant Axis_Angle := (Axis  => Vectors.Direction (Axis),
                                         Angle => To_Radians (Angle));
      Actual : constant Axis_Angle := To_Axis_Angle (From_Axis_Angle (Expected));
   begin
      Assert_Equivalent (Vector4 (Expected.Axis), Vector4 (Actual.Axis));
      Assert (Is_Equivalent (Expected.Angle, Actual.Angle),
        "Unexpected angle " & Actual.Angle'Image);
   end Test_Axis_Angle;

   procedure Test_Axis_Angle_No_Rotation (Object : in out Test) is
      Actual   : constant Element_Type := To_Axis_Angle (Identity).Angle;
      Expected : constant Element_Type := 0.0;
   begin
      Assert (Is_Equivalent (Expected, Actual), "Unexpected angle " & Actual'Image);
   end Test_Axis_Angle_No_Rotation;

   procedure Test_Rotate_Vectors (Object : in out Test) is
      Start_Vector : constant Vector4 := (0.0, 1.0, 0.0, 0.0);
      End_Vector   : constant Vector4 := (0.0, 0.0, 1.0, 0.0);

      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 90.0;

      Expected_1 : constant Quaternion := R (Axis, To_Radians (Angle));
      Result_1   : constant Quaternion := R (Start_Vector, End_Vector);

      Expected_2 : constant Quaternion := R (Axis, To_Radians (-Angle));
      Result_2   : constant Quaternion := R (End_Vector, Start_Vector);
   begin
      Assert_Equivalent (Expected_1, Result_1);
      Assert_Equivalent (Expected_2, Result_2);
   end Test_Rotate_Vectors;

   procedure Test_Rotate (Object : in out Test) is
      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 90.0;

      Rotation : constant Quaternion := R (Axis, To_Radians (Angle));

      Expected : constant Vector4 := (0.0, 0.0, 1.0, 0.0);
      Result   : constant Vector4 := Rotate ((0.0, 1.0, 0.0, 0.0), Rotation);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Rotate;

   procedure Test_Difference (Object : in out Test) is
      Axis    : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle_A : constant Element_Type := 30.0;
      Angle_B : constant Element_Type := 90.0;

      Rotation_A : constant Quaternion := R (Axis, To_Radians (Angle_A));
      Rotation_B : constant Quaternion := R (Axis, To_Radians (Angle_B));

      Actual   : constant Axis_Angle := To_Axis_Angle (Difference (Rotation_A, Rotation_B));
      Expected : constant Axis_Angle := (Axis  => Vectors.Direction (Axis),
                                         Angle => To_Radians (60.0));
   begin
      Assert_Equivalent (Vector4 (Expected.Axis), Vector4 (Actual.Axis));
      Assert (Is_Equivalent (Expected.Angle, Actual.Angle),
        "Unexpected angle " & Actual.Angle'Image);
   end Test_Difference;

   procedure Test_Slerp (Object : in out Test) is
      Axis  : constant Vector4 := (1.0, 0.0, 0.0, 0.0);
      Angle : constant Element_Type := 45.0;

      Start_Quaternion : constant Quaternion := R (Axis, To_Radians (0.0));
      End_Quaternion   : constant Quaternion := R (Axis, To_Radians (90.0));

      Expected : constant Quaternion := R (Axis, To_Radians (Angle));
      Result   : constant Quaternion := Slerp (Start_Quaternion, End_Quaternion, 0.5);
   begin
      Assert_Equivalent (Expected, Result);
   end Test_Slerp;

   ----------------------------------------------------------------------------

   package Caller is new AUnit.Test_Caller (Test);

   Test_Suite : aliased AUnit.Test_Suites.Test_Suite;

   function Suite return AUnit.Test_Suites.Access_Test_Suite is
      Name : constant String := "(Transforms - " & Suite_Name & " - Quaternions) ";
   begin
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test '*' operator", Test_Multiplication'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Conjugate function", Test_Conjugate'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Norm function", Test_Norm'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Normalize function", Test_Normalize'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Normalized function", Test_Normalized'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test to/from Axis_Angle functions", Test_Axis_Angle'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test To_Axis_Angle function with Identity", Test_Axis_Angle_No_Rotation'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate_Axis_Angle function", Test_Rotate_Axis_Angle'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate_Vectors function", Test_Rotate_Vectors'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Rotate function", Test_Rotate'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Difference function", Test_Difference'Access));
      Test_Suite.Add_Test (Caller.Create
        (Name & "Test Slerp function", Test_Slerp'Access));

      return Test_Suite'Access;
   end Suite;

end Generic_Test_Transforms_Quaternions;

tests: Increase test coverage of quaternion transforms

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with ASF.Server.Tests;

with Util.Log.Loggers;

with ASF.Tests;

with AWA.Applications.Factory;
package body AWA.Tests is

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

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      pragma Unreferenced (Add_Modules);
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new Test_Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name => "files", Server => App.Files'Unchecked_Access);
      App.Add_Servlet (Name => "ajax", Server => App.Ajax'Unchecked_Access);
      App.Add_Servlet (Name => "measures", Server => App.Measures'Unchecked_Access);
--        App.Add_Servlet (Name => "auth", Server => App.Auth'Unchecked_Access);
--        App.Add_Servlet (Name => "verify-auth", Server => App.Self.Verify_Auth'Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Dump'Access);
      App.Add_Filter (Name => "measures", Filter => App.Measures'Access);
      App.Add_Filter (Name => "service", Filter => App.Service_Filter'Access);
   end Initialize_Filters;

end AWA.Tests;

-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 2011, 2012, 2013, 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.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with ASF.Server.Tests;

with Util.Log.Loggers;

with ASF.Tests;

with AWA.Applications.Factory;
with AWA.Tests.Helpers.Users;
package body AWA.Tests is

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

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   --  ------------------------------
   --  Cleanup after the test execution.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      AWA.Tests.Helpers.Users.Tear_Down;
   end Tear_Down;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      pragma Unreferenced (Add_Modules);
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new Test_Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name => "files", Server => App.Files'Unchecked_Access);
      App.Add_Servlet (Name => "ajax", Server => App.Ajax'Unchecked_Access);
      App.Add_Servlet (Name => "measures", Server => App.Measures'Unchecked_Access);
--        App.Add_Servlet (Name => "auth", Server => App.Auth'Unchecked_Access);
--        App.Add_Servlet (Name => "verify-auth", Server => App.Self.Verify_Auth'Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Dump'Access);
      App.Add_Filter (Name => "measures", Filter => App.Measures'Access);
      App.Add_Filter (Name => "service", Filter => App.Service_Filter'Access);
   end Initialize_Filters;

end AWA.Tests;

Implement Tear_Down to cleanup the users after the test execution


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "71";
   copyright_years     : constant String := "2015-2021";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.35.1";
   previous_binutils : constant String := "2.34";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "72";
   copyright_years     : constant String := "2015-2021";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.35.1";
   previous_binutils : constant String := "2.34";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

bump version for release

bump version for release


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

package body Gen.Artifacts.Docs.Googlecode is

   --  ------------------------------
   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   --  ------------------------------
   overriding
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Document.Name) & ".wiki";
   end Get_Document_Name;

   --  ------------------------------
   --  Write a line in the target document formatting the line if necessary.
   --  ------------------------------
   overriding
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is
   begin
      if Line.Kind = L_LIST then
         Ada.Text_IO.New_Line (File);
         Ada.Text_IO.Put (File, Line.Content);
         Formatter.Need_Newline := True;

      elsif Line.Kind = L_LIST_ITEM then
         Ada.Text_IO.Put (File, Line.Content);
         Formatter.Need_Newline := True;

      else
         if Formatter.Need_Newline then
            Ada.Text_IO.New_Line (File);
            Formatter.Need_Newline := False;
         end if;
         Ada.Text_IO.Put_Line (File, Line.Content);
      end if;
   end Write_Line;

end Gen.Artifacts.Docs.Googlecode;

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

package body Gen.Artifacts.Docs.Googlecode is

   --  ------------------------------
   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   --  ------------------------------
   overriding
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Document.Name) & ".wiki";
   end Get_Document_Name;

   --  ------------------------------
   --  Start a new document.
   --  ------------------------------
   overriding
   procedure Start_Document (Formatter : in out Document_Formatter;
                             Document  : in File_Document;
                             File      : in Ada.Text_IO.File_Type) is
   begin
      Ada.Text_IO.Put_Line (File, "#summary " & Ada.Strings.Unbounded.To_String (Document.Title));
      Ada.Text_IO.New_Line (File);
   end Start_Document;

   --  ------------------------------
   --  Write a line in the target document formatting the line if necessary.
   --  ------------------------------
   overriding
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is
   begin
      if Line.Kind = L_LIST then
         Ada.Text_IO.New_Line (File);
         Ada.Text_IO.Put (File, Line.Content);
         Formatter.Need_Newline := True;

      elsif Line.Kind = L_LIST_ITEM then
         Ada.Text_IO.Put (File, Line.Content);
         Formatter.Need_Newline := True;

      else
         if Formatter.Need_Newline then
            Ada.Text_IO.New_Line (File);
            Formatter.Need_Newline := False;
         end if;
         Ada.Text_IO.Put_Line (File, Line.Content);
      end if;
   end Write_Line;

end Gen.Artifacts.Docs.Googlecode;

Implement the Start_Document procedure

Implement the Start_Document procedure