--  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 := "15";
   copyright_years     : constant String := "2015-2018";

   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";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc8";
   compiler_version  : constant String := "8.2.0";
   previous_compiler : constant String := "7.3.0";
   binutils_version  : constant String := "2.31.1";
   previous_binutils : constant String := "2.30";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   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 .. 32;
   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/pkg-static";
   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 := "16";
   copyright_years     : constant String := "2015-2019";

   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";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc8";
   compiler_version  : constant String := "8.2.0";
   previous_compiler : constant String := "7.3.0";
   binutils_version  : constant String := "2.31.1";
   previous_binutils : constant String := "2.30";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   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 .. 32;
   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/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Bump copyright years and version

Bump copyright years and version

The version bump is in anticipation of major updates.


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

package body Util.Beans.Objects.Maps is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object is
      Pos : constant Cursor := From.Find (Name);
   begin
      if Has_Element (Pos) then
         return Element (Pos);
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object) is
   begin
      From.Include (Name, Value);
   end Set_Value;

   --  ------------------------------
   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   --  ------------------------------
   function Create return Object is
      M : constant access Map_Bean'Class := new Map_Bean;
   begin
      return To_Object (Value => M, Storage => DYNAMIC);
   end Create;

end Util.Beans.Objects.Maps;

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

package body Util.Beans.Objects.Maps is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object is
      Pos : constant Cursor := From.Find (Name);
   begin
      if Has_Element (Pos) then
         return Element (Pos);
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object) is
   begin
      From.Include (Name, Value);
   end Set_Value;

   --  ------------------------------
   --  Iterate over the members of the map.
   --  ------------------------------
   procedure Iterate (From    : in Object;
                      Process : not null access procedure (Name : in String;
                                                           Item : in Object)) is
      procedure Process_One (Pos : in Maps.Cursor);

      procedure Process_One (Pos : in Maps.Cursor) is
      begin
         Process (Maps.Key (Pos), Maps.Element (Pos));
      end Process_One;

      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (From);
   begin
      if Bean /= null and then Bean.all in Util.Beans.Objects.Maps.Map_Bean'Class then
         Map_Bean'Class (Bean.all).Iterate (Process_One'Access);
      end if;
   end Iterate;

   --  ------------------------------
   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   --  ------------------------------
   function Create return Object is
      M : constant access Map_Bean'Class := new Map_Bean;
   begin
      return To_Object (Value => M, Storage => DYNAMIC);
   end Create;

end Util.Beans.Objects.Maps;

Implement the Iterate procedure to call a Process procedure for each element of the object map


-----------------------------------------------------------------------
--  awa-events-services -- AWA Event Manager
--  Copyright (C) 2012, 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.Unchecked_Deallocation;

with Util.Log.Loggers;

with ADO.SQL;
with ADO.Sessions;

with AWA.Events.Dispatchers.Tasks;
with AWA.Events.Dispatchers.Actions;
package body AWA.Events.Services is

   use type Util.Strings.Name_Access;

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

   --  ------------------------------
   --  Send the event to the modules that subscribed to it.
   --  The event is sent on each event queue.  Event queues will dispatch the event
   --  by invoking immediately or later on the Dispatch operation.  The synchronous
   --  or asynchronous reception of the event depends on the event queue.
   --  ------------------------------
   procedure Send (Manager : in Event_Manager;
                   Event   : in Module_Event'Class) is
      procedure Send_Queue (Queue : in Queue_Dispatcher);

      procedure Send_Queue (Queue : in Queue_Dispatcher) is
      begin
         if Queue.Queue.Is_Null then
            Queue.Dispatcher.Dispatch (Event);
         else
            Queue.Queue.Enqueue (Event);
         end if;
      end Send_Queue;

      Name : constant Util.Strings.Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      --  Find the event queues associated with the event.  Post the event on each queue.
      --  Some queue can dispatch the event immediately while some others may dispatched it
      --  asynchronously.
      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Sending event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Sending event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Send_Queue'Access);
               Queue_Dispatcher_Lists.Next (Pos);
               exit when not Queue_Dispatcher_Lists.Has_Element (Pos);
            end loop;
         end if;
      end;
   end Send;

   --  ------------------------------
   --  Set the event message type which correspond to the <tt>Kind</tt> event index.
   --  ------------------------------
   procedure Set_Message_Type (Manager : in Event_Manager;
                               Event   : in out AWA.Events.Models.Message_Ref;
                               Kind    : in Event_Index) is
   begin
      if not Event_Arrays.Is_Valid (Kind) then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Kind));
         raise Not_Found;
      end if;
      Event.Set_Status (AWA.Events.Models.QUEUED);
      Event.Set_Message_Type (Manager.Actions (Kind).Event);
   end Set_Message_Type;

   --  ------------------------------
   --  Set the event queue associated with the event message.  The event queue identified by
   --  <tt>Name</tt> is searched to find the <tt>Queue_Ref</tt> instance.
   --  ------------------------------
   procedure Set_Event_Queue (Manager : in Event_Manager;
                              Event   : in out AWA.Events.Models.Message_Ref;
                              Name    : in String) is
      Queue : constant AWA.Events.Queues.Queue_Ref := Manager.Find_Queue (Name);
   begin
      Event.Set_Queue (Queue.Get_Queue);
   end Set_Event_Queue;

   --  ------------------------------
   --  Dispatch the event identified by Event and associated with the event
   --  queue Queue.  The event actions which are associated with the event are
   --  executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Event_Manager;
                       Queue   : in AWA.Events.Queues.Queue_Ref;
                       Event   : in Module_Event'Class) is
      procedure Find_Queue (List : in Queue_Dispatcher);

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         if List.Queue = Queue then
            List.Dispatcher.Dispatch (Event);
            Found := True;
         end if;
      end Find_Queue;

      Name : constant Util.Strings.Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot dispatch event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Dispatching event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Dispatching event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
               exit when Found;
               Queue_Dispatcher_Lists.Next (Pos);
               if not Queue_Dispatcher_Lists.Has_Element (Pos) then
                  Log.Debug ("Dispatched event {0} but there was no listener", Name.all);
                  exit;
               end if;
            end loop;
         end if;
      end;
   end Dispatch;

   --  ------------------------------
   --  Find the event queue identified by the given name.
   --  ------------------------------
   function Find_Queue (Manager : in Event_Manager;
                        Name    : in String) return AWA.Events.Queues.Queue_Ref is
      Pos : constant Queues.Maps.Cursor := Manager.Queues.Find (Name);
   begin
      if Queues.Maps.Has_Element (Pos) then
         return Queues.Maps.Element (Pos);
      else
         Log.Error ("Event queue {0} not found", Name);
         return AWA.Events.Queues.Null_Queue;
      end if;
   end Find_Queue;

   --  ------------------------------
   --  Add the event queue in the registry.
   --  ------------------------------
   procedure Add_Queue (Manager : in out Event_Manager;
                        Queue   : in AWA.Events.Queues.Queue_Ref) is
      Name : constant String := Queue.Get_Name;
   begin
      if Manager.Queues.Contains (Name) then
         Log.Error ("Event queue {0} already defined");
      else
         Log.Info ("Adding event queue {0}", Name);
      end if;
      Manager.Queues.Include (Key      => Name,
                              New_Item => Queue);
   end Add_Queue;

   --  ------------------------------
   --  Add an action invoked when the event identified by Event is sent.
   --  The event is posted on the queue identified by Queue.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   procedure Add_Action (Manager : in out Event_Manager;
                         Event   : in String;
                         Queue   : in AWA.Events.Queues.Queue_Ref;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is
      procedure Find_Queue (List : in Queue_Dispatcher);
      procedure Add_Action (List : in out Queue_Dispatcher);

      procedure Add_Action (List : in out Queue_Dispatcher) is
         use type AWA.Events.Dispatchers.Dispatcher_Access;
      begin
         if List.Dispatcher = null then
            List.Dispatcher := AWA.Events.Dispatchers.Actions.Create_Dispatcher
              (Application => Manager.Application.all'Access);
         end if;
         List.Dispatcher.Add_Action (Action, Params);
      end Add_Action;

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         Found := List.Queue = Queue;
      end Find_Queue;

      Index : constant Event_Index := Find_Event_Index (Event);
      Pos   : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Index).Queues.First;
   begin
      Log.Info ("Adding action {0} to event {1}", Action.Get_Expression, Event);

      --  Find the queue.
      while Queue_Dispatcher_Lists.Has_Element (Pos) loop
         Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
         exit when Found;
         Queue_Dispatcher_Lists.Next (Pos);
      end loop;

      --  Create it if it does not exist.
      if not Found then
         declare
            New_Queue : Queue_Dispatcher;
         begin
            New_Queue.Queue := Queue;
            Manager.Actions (Index).Queues.Append (New_Queue);
            Pos := Manager.Actions (Index).Queues.Last;
         end;
      end if;

      --  And append the new action to the event queue.
      Manager.Actions (Index).Queues.Update_Element (Pos, Add_Action'Access);
   end Add_Action;

   --  ------------------------------
   --  Add a dispatcher to process the event queues matching the Match string.
   --  The dispatcher can create up to Count tasks running at the priority Priority.
   --  ------------------------------
   procedure Add_Dispatcher (Manager  : in out Event_Manager;
                             Match    : in String;
                             Count    : in Positive;
                             Priority : in Positive) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Adding event dispatcher with {0} tasks prio {1} and dispatching queues '{2}'",
                Positive'Image (Count), Positive'Image (Priority), Match);

      for I in Manager.Dispatchers'Range loop
         if Manager.Dispatchers (I) = null then
            Manager.Dispatchers (I) :=
              AWA.Events.Dispatchers.Tasks.Create_Dispatcher (Manager'Unchecked_Access,
                                                              Match, Count, Priority);
            return;
         end if;
      end loop;
      Log.Error ("Implementation limit is reached.  Too many dispatcher.");
   end Add_Dispatcher;

   --  ------------------------------
   --  Initialize the event manager.
   --  ------------------------------
   procedure Initialize (Manager : in out Event_Manager;
                         App     : in Application_Access) is
      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref);

      Msg_Types : AWA.Events.Models.Message_Type_Vector;

      Query     : ADO.SQL.Query;

      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref) is
         Name : constant String := Msg.Get_Name;
      begin
         declare
            Index : constant Event_Index := Find_Event_Index (Name);
         begin
            Manager.Actions (Index).Event := Msg;
         end;

      exception
         when others =>
            Log.Warn ("Event {0} is no longer used", Name);
      end Set_Events;

      DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
   begin
      Log.Info ("Initializing {0} events", Event_Index'Image (Event_Arrays.Get_Last));

      Manager.Application := App;
      DB.Begin_Transaction;
      Manager.Actions := new Event_Queues_Array (1 .. Event_Arrays.Get_Last);

      AWA.Events.Models.List (Object  => Msg_Types,
                              Session => DB,
                              Query   => Query);
      declare
         Pos : AWA.Events.Models.Message_Type_Vectors.Cursor := Msg_Types.First;
      begin
         while AWA.Events.Models.Message_Type_Vectors.Has_Element (Pos) loop
            AWA.Events.Models.Message_Type_Vectors.Query_Element (Pos, Set_Events'Access);
            AWA.Events.Models.Message_Type_Vectors.Next (Pos);
         end loop;
      end;

      for I in Manager.Actions'Range loop
         if Manager.Actions (I).Event.Is_Null then
            declare
               Name : constant Util.Strings.Name_Access := Get_Event_Type_Name (I);
            begin
               Log.Info ("Creating event type {0} in database", Name.all);
               Manager.Actions (I).Event.Set_Name (Name.all);
               Manager.Actions (I).Event.Save (DB);
            end;
         end if;
      end loop;
      DB.Commit;
   end Initialize;

   --  ------------------------------
   --  Start the event manager.  The dispatchers are configured to dispatch the event queues
   --  and tasks are started to process asynchronous events.
   --  ------------------------------
   procedure Start (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref);

      --  ------------------------------
      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      --  ------------------------------
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref) is
         pragma Unreferenced (Key);

         Added : Boolean := False;
      begin
         for I in reverse Manager.Dispatchers'Range loop
            if Manager.Dispatchers (I) /= null then
               Manager.Dispatchers (I).Add_Queue (Queue, Added);
               exit when Added;
            end if;
         end loop;
      end Associate_Dispatcher;

      Iter : AWA.Events.Queues.Maps.Cursor := Manager.Queues.First;
   begin
      Log.Info ("Starting the event manager");

      while AWA.Events.Queues.Maps.Has_Element (Iter) loop
         Manager.Queues.Update_Element (Iter, Associate_Dispatcher'Access);
         AWA.Events.Queues.Maps.Next (Iter);
      end loop;

      --  Start the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Start;
      end loop;
   end Start;

   --  ------------------------------
   --  Get the application associated with the event manager.
   --  ------------------------------
   function Get_Application (Manager : in Event_Manager) return Application_Access is
   begin
      return Manager.Application;
   end Get_Application;

   --  ------------------------------
   --  Finalize the queue dispatcher releasing the dispatcher memory.
   --  ------------------------------
   procedure Finalize (Object : in out Queue_Dispatcher) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      Free (Object.Dispatcher);
   end Finalize;

   --  ------------------------------
   --  Finalize the event queues and the dispatchers.
   --  ------------------------------
   procedure Finalize (Object : in out Event_Queues) is
   begin
      loop
         declare
            Pos : constant Queue_Dispatcher_Lists.Cursor := Object.Queues.First;
         begin
            exit when not Queue_Dispatcher_Lists.Has_Element (Pos);

            Object.Queues.Update_Element (Position => Pos,
                                          Process  => Finalize'Access);
            Object.Queues.Delete_First;
         end;
      end loop;
   end Finalize;

   --  ------------------------------
   --  Finalize the event manager by releasing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Event_Queues_Array,
                                        Name   => Event_Queues_Array_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      --  Stop the dispatcher first.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Free (Manager.Dispatchers (I));
      end loop;
      if Manager.Actions /= null then
         for I in Manager.Actions'Range loop
            Finalize (Manager.Actions (I));
         end loop;
         Free (Manager.Actions);
      end if;
   end Finalize;

end AWA.Events.Services;

-----------------------------------------------------------------------
--  awa-events-services -- AWA Event Manager
--  Copyright (C) 2012, 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.Unchecked_Deallocation;

with Util.Log.Loggers;

with ADO.SQL;
with ADO.Sessions;

with AWA.Events.Dispatchers.Tasks;
with AWA.Events.Dispatchers.Actions;
package body AWA.Events.Services is

   use type Util.Strings.Name_Access;

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

   --  ------------------------------
   --  Send the event to the modules that subscribed to it.
   --  The event is sent on each event queue.  Event queues will dispatch the event
   --  by invoking immediately or later on the Dispatch operation.  The synchronous
   --  or asynchronous reception of the event depends on the event queue.
   --  ------------------------------
   procedure Send (Manager : in Event_Manager;
                   Event   : in Module_Event'Class) is
      procedure Send_Queue (Queue : in Queue_Dispatcher);

      procedure Send_Queue (Queue : in Queue_Dispatcher) is
      begin
         if Queue.Queue.Is_Null then
            Queue.Dispatcher.Dispatch (Event);
         else
            Queue.Queue.Enqueue (Event);
         end if;
      end Send_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      --  Find the event queues associated with the event.  Post the event on each queue.
      --  Some queue can dispatch the event immediately while some others may dispatched it
      --  asynchronously.
      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Sending event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Sending event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Send_Queue'Access);
               Queue_Dispatcher_Lists.Next (Pos);
               exit when not Queue_Dispatcher_Lists.Has_Element (Pos);
            end loop;
         end if;
      end;
   end Send;

   --  ------------------------------
   --  Set the event message type which correspond to the <tt>Kind</tt> event index.
   --  ------------------------------
   procedure Set_Message_Type (Manager : in Event_Manager;
                               Event   : in out AWA.Events.Models.Message_Ref;
                               Kind    : in Event_Index) is
   begin
      if not Event_Arrays.Is_Valid (Kind) then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Kind));
         raise Not_Found;
      end if;
      Event.Set_Status (AWA.Events.Models.QUEUED);
      Event.Set_Message_Type (Manager.Actions (Kind).Event);
   end Set_Message_Type;

   --  ------------------------------
   --  Set the event queue associated with the event message.  The event queue identified by
   --  <tt>Name</tt> is searched to find the <tt>Queue_Ref</tt> instance.
   --  ------------------------------
   procedure Set_Event_Queue (Manager : in Event_Manager;
                              Event   : in out AWA.Events.Models.Message_Ref;
                              Name    : in String) is
      Queue : constant AWA.Events.Queues.Queue_Ref := Manager.Find_Queue (Name);
   begin
      Event.Set_Queue (Queue.Get_Queue);
   end Set_Event_Queue;

   --  ------------------------------
   --  Dispatch the event identified by Event and associated with the event
   --  queue Queue.  The event actions which are associated with the event are
   --  executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Event_Manager;
                       Queue   : in AWA.Events.Queues.Queue_Ref;
                       Event   : in Module_Event'Class) is
      procedure Find_Queue (List : in Queue_Dispatcher);

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         if List.Queue = Queue then
            List.Dispatcher.Dispatch (Event);
            Found := True;
         end if;
      end Find_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot dispatch event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Dispatching event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Dispatching event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
               exit when Found;
               Queue_Dispatcher_Lists.Next (Pos);
               if not Queue_Dispatcher_Lists.Has_Element (Pos) then
                  Log.Debug ("Dispatched event {0} but there was no listener", Name.all);
                  exit;
               end if;
            end loop;
         end if;
      end;
   end Dispatch;

   --  ------------------------------
   --  Find the event queue identified by the given name.
   --  ------------------------------
   function Find_Queue (Manager : in Event_Manager;
                        Name    : in String) return AWA.Events.Queues.Queue_Ref is
      Pos : constant Queues.Maps.Cursor := Manager.Queues.Find (Name);
   begin
      if Queues.Maps.Has_Element (Pos) then
         return Queues.Maps.Element (Pos);
      else
         Log.Error ("Event queue {0} not found", Name);
         return AWA.Events.Queues.Null_Queue;
      end if;
   end Find_Queue;

   --  ------------------------------
   --  Add the event queue in the registry.
   --  ------------------------------
   procedure Add_Queue (Manager : in out Event_Manager;
                        Queue   : in AWA.Events.Queues.Queue_Ref) is
      Name : constant String := Queue.Get_Name;
   begin
      if Manager.Queues.Contains (Name) then
         Log.Error ("Event queue {0} already defined");
      else
         Log.Info ("Adding event queue {0}", Name);
      end if;
      Manager.Queues.Include (Key      => Name,
                              New_Item => Queue);
   end Add_Queue;

   --  ------------------------------
   --  Add an action invoked when the event identified by Event is sent.
   --  The event is posted on the queue identified by Queue.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   procedure Add_Action (Manager : in out Event_Manager;
                         Event   : in String;
                         Queue   : in AWA.Events.Queues.Queue_Ref;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is
      procedure Find_Queue (List : in Queue_Dispatcher);
      procedure Add_Action (List : in out Queue_Dispatcher);

      procedure Add_Action (List : in out Queue_Dispatcher) is
         use type AWA.Events.Dispatchers.Dispatcher_Access;
      begin
         if List.Dispatcher = null then
            List.Dispatcher := AWA.Events.Dispatchers.Actions.Create_Dispatcher
              (Application => Manager.Application.all'Access);
         end if;
         List.Dispatcher.Add_Action (Action, Params);
      end Add_Action;

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         Found := List.Queue = Queue;
      end Find_Queue;

      Index : constant Event_Index := Find_Event_Index (Event);
      Pos   : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Index).Queues.First;
   begin
      Log.Info ("Adding action {0} to event {1}", Action.Get_Expression, Event);

      --  Find the queue.
      while Queue_Dispatcher_Lists.Has_Element (Pos) loop
         Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
         exit when Found;
         Queue_Dispatcher_Lists.Next (Pos);
      end loop;

      --  Create it if it does not exist.
      if not Found then
         declare
            New_Queue : Queue_Dispatcher;
         begin
            New_Queue.Queue := Queue;
            Manager.Actions (Index).Queues.Append (New_Queue);
            Pos := Manager.Actions (Index).Queues.Last;
         end;
      end if;

      --  And append the new action to the event queue.
      Manager.Actions (Index).Queues.Update_Element (Pos, Add_Action'Access);
   end Add_Action;

   --  ------------------------------
   --  Add a dispatcher to process the event queues matching the Match string.
   --  The dispatcher can create up to Count tasks running at the priority Priority.
   --  ------------------------------
   procedure Add_Dispatcher (Manager  : in out Event_Manager;
                             Match    : in String;
                             Count    : in Positive;
                             Priority : in Positive) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Adding event dispatcher with {0} tasks prio {1} and dispatching queues '{2}'",
                Positive'Image (Count), Positive'Image (Priority), Match);

      for I in Manager.Dispatchers'Range loop
         if Manager.Dispatchers (I) = null then
            Manager.Dispatchers (I) :=
              AWA.Events.Dispatchers.Tasks.Create_Dispatcher (Manager'Unchecked_Access,
                                                              Match, Count, Priority);
            return;
         end if;
      end loop;
      Log.Error ("Implementation limit is reached.  Too many dispatcher.");
   end Add_Dispatcher;

   --  ------------------------------
   --  Initialize the event manager.
   --  ------------------------------
   procedure Initialize (Manager : in out Event_Manager;
                         App     : in Application_Access) is
      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref);

      Msg_Types : AWA.Events.Models.Message_Type_Vector;

      Query     : ADO.SQL.Query;

      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref) is
         Name : constant String := Msg.Get_Name;
      begin
         declare
            Index : constant Event_Index := Find_Event_Index (Name);
         begin
            Manager.Actions (Index).Event := Msg;
         end;

      exception
         when others =>
            Log.Warn ("Event {0} is no longer used", Name);
      end Set_Events;

      DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
   begin
      Log.Info ("Initializing {0} events", Event_Index'Image (Event_Arrays.Get_Last));

      Manager.Application := App;
      DB.Begin_Transaction;
      Manager.Actions := new Event_Queues_Array (1 .. Event_Arrays.Get_Last);

      AWA.Events.Models.List (Object  => Msg_Types,
                              Session => DB,
                              Query   => Query);
      declare
         Pos : AWA.Events.Models.Message_Type_Vectors.Cursor := Msg_Types.First;
      begin
         while AWA.Events.Models.Message_Type_Vectors.Has_Element (Pos) loop
            AWA.Events.Models.Message_Type_Vectors.Query_Element (Pos, Set_Events'Access);
            AWA.Events.Models.Message_Type_Vectors.Next (Pos);
         end loop;
      end;

      for I in Manager.Actions'Range loop
         if Manager.Actions (I).Event.Is_Null then
            declare
               Name : constant Name_Access := Get_Event_Type_Name (I);
            begin
               Log.Info ("Creating event type {0} in database", Name.all);
               Manager.Actions (I).Event.Set_Name (Name.all);
               Manager.Actions (I).Event.Save (DB);
            end;
         end if;
      end loop;
      DB.Commit;
   end Initialize;

   --  ------------------------------
   --  Start the event manager.  The dispatchers are configured to dispatch the event queues
   --  and tasks are started to process asynchronous events.
   --  ------------------------------
   procedure Start (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref);

      --  ------------------------------
      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      --  ------------------------------
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref) is
         pragma Unreferenced (Key);

         Added : Boolean := False;
      begin
         for I in reverse Manager.Dispatchers'Range loop
            if Manager.Dispatchers (I) /= null then
               Manager.Dispatchers (I).Add_Queue (Queue, Added);
               exit when Added;
            end if;
         end loop;
      end Associate_Dispatcher;

      Iter : AWA.Events.Queues.Maps.Cursor := Manager.Queues.First;
   begin
      Log.Info ("Starting the event manager");

      while AWA.Events.Queues.Maps.Has_Element (Iter) loop
         Manager.Queues.Update_Element (Iter, Associate_Dispatcher'Access);
         AWA.Events.Queues.Maps.Next (Iter);
      end loop;

      --  Start the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Start;
      end loop;
   end Start;

   --  ------------------------------
   --  Get the application associated with the event manager.
   --  ------------------------------
   function Get_Application (Manager : in Event_Manager) return Application_Access is
   begin
      return Manager.Application;
   end Get_Application;

   --  ------------------------------
   --  Finalize the queue dispatcher releasing the dispatcher memory.
   --  ------------------------------
   procedure Finalize (Object : in out Queue_Dispatcher) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      Free (Object.Dispatcher);
   end Finalize;

   --  ------------------------------
   --  Finalize the event queues and the dispatchers.
   --  ------------------------------
   procedure Finalize (Object : in out Event_Queues) is
   begin
      loop
         declare
            Pos : constant Queue_Dispatcher_Lists.Cursor := Object.Queues.First;
         begin
            exit when not Queue_Dispatcher_Lists.Has_Element (Pos);

            Object.Queues.Update_Element (Position => Pos,
                                          Process  => Finalize'Access);
            Object.Queues.Delete_First;
         end;
      end loop;
   end Finalize;

   --  ------------------------------
   --  Finalize the event manager by releasing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Event_Queues_Array,
                                        Name   => Event_Queues_Array_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      --  Stop the dispatcher first.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Free (Manager.Dispatchers (I));
      end loop;
      if Manager.Actions /= null then
         for I in Manager.Actions'Range loop
            Finalize (Manager.Actions (I));
         end loop;
         Free (Manager.Actions);
      end if;
   end Finalize;

end AWA.Events.Services;

Use the event Name_Access type

Use the event Name_Access type


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

with ADO.Queries.Loaders;
with AWA.Services.Contexts;
package body AWA.Helpers.Selectors is

   --  ------------------------------
   --  Create a selector list from the definition of a discrete type such as an enum.
   --  The select item has the enum value as value and the label is created by
   --  localizing the string Prefix_enum name.
   --  ------------------------------
   function Create_From_Enum (Bundle : in Util.Properties.Bundles.Manager'Class)
                              return ASF.Models.Selects.Select_Item_List is
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      for I in T'Range loop
         declare
            Value : constant String := T'Image (I);
            Name  : constant String := Prefix & "_" & Value;
            Label : constant String := Bundle.Get (Name, Name);
         begin
            Result.Append (ASF.Models.Selects.Create_Select_Item (Label, Value));
         end;
      end loop;
      return Result;
   end Create_From_Enum;

   --  ------------------------------
   --  Append the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   procedure Append_From_Query (Into  : in out ASF.Models.Selects.Select_Item_List;
                                Query : in out ADO.Statements.Query_Statement'Class) is
   begin
      Query.Execute;
      while Query.Has_Elements loop
         declare
            Id    : constant String := Query.Get_String (1);
            Label : constant String := Query.Get_String (2);
         begin
            Into.Append (ASF.Models.Selects.Create_Select_Item (Id, Label));
         end;
         Query.Next;
      end loop;
   end Append_From_Query;

   --  ------------------------------
   --  Create the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   function Create_From_Query (Session : in ADO.Sessions.Session'Class;
                               Query   : in ADO.Queries.Context'Class)
                               return ASF.Models.Selects.Select_Item_List is
      Stmt   : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      Append_From_Query (Result, Stmt);
      return Result;
   end Create_From_Query;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Select_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "list" then
         return ASF.Models.Selects.To_Object (From.List);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   procedure Set_Value (From  : in out Select_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      use type AWA.Services.Contexts.Service_Context_Access;
      use type ADO.Queries.Query_Definition_Access;
   begin
      if Name = "query" then
         declare
            Query_Name : constant String := Util.Beans.Objects.To_String (Value);
            Ctx : constant AWA.Services.Contexts.Service_Context_Access
              := AWA.Services.Contexts.Current;
            Query_Def : constant ADO.Queries.Query_Definition_Access
              := ADO.Queries.Loaders.Find_Query (Query_Name);
            Query     : ADO.Queries.Context;
         begin
            if Ctx = null or Query_Def = null then
               return;
            end if;

            Query.Set_Query (Query_Def);
            From.List := Create_From_Query (Session => AWA.Services.Contexts.Get_Session (Ctx),
                                            Query   => Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the select list bean instance.
   --  ------------------------------
   function Create_Select_List_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Select_List_Bean_Access := new Select_List_Bean;
   begin
      return Result.all'Access;
   end Create_Select_List_Bean;

end AWA.Helpers.Selectors;

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

with ADO.Queries.Loaders;
with ADO.Schemas;

with Util.Strings;
with Util.Log.Loggers;

with AWA.Services.Contexts;
package body AWA.Helpers.Selectors is

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

   --  ------------------------------
   --  Create a selector list from the definition of a discrete type such as an enum.
   --  The select item has the enum value as value and the label is created by
   --  localizing the string Prefix_enum name.
   --  ------------------------------
   function Create_From_Enum (Bundle : in Util.Properties.Bundles.Manager'Class)
                              return ASF.Models.Selects.Select_Item_List is
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      for I in T'Range loop
         declare
            Value : constant String := T'Image (I);
            Name  : constant String := Prefix & "_" & Value;
            Label : constant String := Bundle.Get (Name, Name);
         begin
            Result.Append (ASF.Models.Selects.Create_Select_Item (Label, Value));
         end;
      end loop;
      return Result;
   end Create_From_Enum;

   --  ------------------------------
   --  Append the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   procedure Append_From_Query (Into  : in out ASF.Models.Selects.Select_Item_List;
                                Query : in out ADO.Statements.Query_Statement'Class) is
      use ADO.Schemas;

      Id_Type    : ADO.Schemas.Column_Type := T_UNKNOWN;
      Label_Type : ADO.Schemas.Column_Type := T_UNKNOWN;

      function Get_Column (Id : in Natural;
                           Of_Type : in ADO.Schemas.Column_Type) return String is
      begin
         case Of_Type is
            when T_CHAR | T_VARCHAR =>
               return Query.Get_String (Id);

            when T_INTEGER | T_TINYINT | T_SMALLINT | T_ENUM =>
               return Util.Strings.Image (Query.Get_Integer (Id));

            when T_LONG_INTEGER =>
               return Util.Strings.Image (Long_Long_Integer (Query.Get_Int64 (Id)));

            when others =>
               return "";

         end case;
      end Get_Column;

   begin
      Query.Execute;
      while Query.Has_Elements loop
         if Id_Type = T_UNKNOWN then
            Id_Type    := Query.Get_Column_Type (0);
            Label_Type := Query.Get_Column_Type (1);
         end if;
         declare
            Id    : constant String := Get_Column (0, Id_Type);
            Label : constant String := Get_Column (1, Label_Type);
         begin
            Into.Append (ASF.Models.Selects.Create_Select_Item (Label => Label, Value => Id));
         end;
         Query.Next;
      end loop;
   end Append_From_Query;

   --  ------------------------------
   --  Create the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   function Create_From_Query (Session : in ADO.Sessions.Session'Class;
                               Query   : in ADO.Queries.Context'Class)
                               return ASF.Models.Selects.Select_Item_List is
      Stmt   : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      Append_From_Query (Result, Stmt);
      return Result;
   end Create_From_Query;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Select_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "list" then
         return ASF.Models.Selects.To_Object (From.List);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   procedure Set_Value (From  : in out Select_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      use type AWA.Services.Contexts.Service_Context_Access;
      use type ADO.Queries.Query_Definition_Access;
   begin
      if Name = "query" then
         declare
            Query_Name : constant String := Util.Beans.Objects.To_String (Value);
            Ctx : constant AWA.Services.Contexts.Service_Context_Access
              := AWA.Services.Contexts.Current;
            Query_Def : constant ADO.Queries.Query_Definition_Access
              := ADO.Queries.Loaders.Find_Query (Query_Name);
            Query     : ADO.Queries.Context;
         begin
            if Ctx = null or Query_Def = null then
               return;
            end if;

            Query.Set_Query (Query_Def);
            From.List := Create_From_Query (Session => AWA.Services.Contexts.Get_Session (Ctx),
                                            Query   => Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the select list bean instance.
   --  ------------------------------
   function Create_Select_List_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Select_List_Bean_Access := new Select_List_Bean;
   begin
      return Result.all'Access;
   end Create_Select_List_Bean;

end AWA.Helpers.Selectors;

Use the column type to decide which column fetch operation must be used


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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Wikis.Parsers.Tests;
with AWA.Wikis.Writers.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;

with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Wikis.Parsers.Tests.Add_Tests (Ret);
      AWA.Wikis.Writers.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

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

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Application.Start;
            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

-----------------------------------------------------------------------
--  Util testsuite - Util Testsuite
--  Copyright (C) 2009, 2010, 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 AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Wikis.Parsers.Tests;
with AWA.Wikis.Writers.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;
with AWA.Comments.Modules.Tests;

with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Comments       : aliased AWA.Comments.Modules.Comment_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Wikis.Parsers.Tests.Add_Tests (Ret);
      AWA.Wikis.Writers.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Comments.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

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

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Comments.Modules.NAME,
                      URI    => "comments",
                      Module => Comments'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Application.Start;
            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

Add the comments module unit tests

Add the comments module unit tests


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

   type Memory_Servant is new MAT.Readers.Reader_Base with record
      Data  : MAT.Memory.Targets.Client_Memory;
--        Slots : Client_Memory_Ref;
--        Impl        : Client_Memory_Ref;
   end record;
   --  The memory servant is a proxy for the generic communication
   --  channel to process incomming events (such as memory allocations).

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

   procedure Bind (For_Servant : in out Memory_Servant);
   --  Bind the servant with the object adapter to register the
   --  events it recognizes.

end MAT.Memory.Readers;

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

   type Memory_Servant is new MAT.Readers.Reader_Base with record
      Data  : MAT.Memory.Targets.Client_Memory;
--        Slots : Client_Memory_Ref;
--        Impl        : Client_Memory_Ref;
   end record;
   type Memory_Reader_Access is access all Memory_Servant'Class;
   --  The memory servant is a proxy for the generic communication
   --  channel to process incomming events (such as memory allocations).

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

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

end MAT.Memory.Readers;

Remove the Bind procedure and define a Register procedure