-- @file ibv_controller_process_main.adb
-- @date 11 Feb 2018
-- @author Chester Gillon
-- @details The main for the controller process written in Ada with communicates with
--          worker processing written in C via the ibv_message_transport library.

with ada.Text_IO;
with Interfaces.C;
use Interfaces.C;
with ibv_message_bw_interface_h;
with ibv_controller_worker_messages_h;
with Ada.Assertions;
with Ada.Numerics.Discrete_Random;
with stdint_h;

procedure Ibv_Controller_Process_Main is

   type all_workers is range ibv_controller_worker_messages_h.FIRST_WORKER_NODE_ID .. ibv_controller_worker_messages_h.LAST_WORKER_NODE_ID;
   type paths_to_workers_array is array (all_workers) of
      ibv_message_bw_interface_h.tx_message_context_handle;

   package next_worker_random is new Ada.Numerics.Discrete_Random (all_workers);

   type random_int_range is range 0..65535;
   package data_to_sum_random is new Ada.Numerics.Discrete_Random (random_int_range);

   type num_ints_range is range 1..ibv_controller_worker_messages_h.MAX_INTEGERS_TO_SUM;
   package num_ints_to_sum_random is new Ada.Numerics.Discrete_Random (num_ints_range);

   -- @brief Wait for all worker processes to report they are ready to run the test
   procedure await_workers_ready (communication_context : in ibv_message_bw_interface_h.communication_context_handle) is
      rx_buffer : access ibv_message_bw_interface_h.rx_api_message_buffer;
      num_remaining_workers : natural;
   begin
      num_remaining_workers := ibv_controller_worker_messages_h.NUM_WORKERS;
      while num_remaining_workers > 0 loop
         rx_buffer := ibv_message_bw_interface_h.await_any_rx_message (communication_context);
         declare
            msgs : ibv_controller_worker_messages_h.worker_to_controller_msgs;
            pragma Import (C, msgs);
            for msgs'Address use rx_buffer.data;
            max_name_index : constant Interfaces.C.size_t := Interfaces.C.size_t (msgs.worker_ready.worker_executable_pathname_len) - 1;
         begin
            case ibv_controller_worker_messages_h.controller_worker_msg_ids'Val(rx_buffer.header.message_id) is
               when ibv_controller_worker_messages_h.CW_WORKER_READY =>
                    ada.Text_IO.Put_Line ("worker " & stdint_h.uint32_t'Image (rx_buffer.header.source_instance) & " : " &
                                            Interfaces.C.To_Ada (Item => msgs.worker_ready.worker_executable_pathname(0..max_name_index), Trim_Nul => false));

               when others =>
                  raise Ada.Assertions.Assertion_Error with
                    "await_workers_ready unexpected message_id " & stdint_h.uint32_t'Image (rx_buffer.header.message_id);
            end case;
         end;

         ibv_message_bw_interface_h.free_message (rx_buffer);
         num_remaining_workers := num_remaining_workers - 1;
      end loop;
   end await_workers_ready;

   -- @brief Process all available CW_SUM_RESULT replies from the workers
   -- @detail This verifies that the expected sum has been returned, by using the returned
   --         request_id to seed the same same random number generators for the number and
   --         data values sent to calculate an expected sum.
   --         This avoids needing to keep track of the outstanding request messages.
   procedure process_sum_result_replies (communication_context : in ibv_message_bw_interface_h.communication_context_handle;
                                         num_outstanding_replies : in out natural) is
      rx_buffer : access ibv_message_bw_interface_h.rx_api_message_buffer;
   begin
      loop
         rx_buffer := ibv_message_bw_interface_h.poll_rx_paths (communication_context);
         if rx_buffer /= null then
            declare
               msgs : ibv_controller_worker_messages_h.worker_to_controller_msgs;
               pragma Import (C, msgs);
               for msgs'Address use rx_buffer.data;
               expected_sum : natural;
               data_generator : data_to_sum_random.Generator;
               num_ints_generator : num_ints_to_sum_random.Generator;
            begin
               case ibv_controller_worker_messages_h.controller_worker_msg_ids'Val(rx_buffer.header.message_id) is
                  when ibv_controller_worker_messages_h.CW_SUM_RESULT =>
                     data_to_sum_random.Reset (Gen => data_generator,
                                               Initiator => Standard.Integer(msgs.sum_result.request_id));
                     num_ints_to_sum_random.Reset (Gen => num_ints_generator,
                                                   Initiator => Standard.Integer(msgs.sum_result.request_id));
                     expected_sum := 0;
                     for ints_to_sum in 1 .. num_ints_to_sum_random.Random (num_ints_generator) loop
                        expected_sum := expected_sum + natural (data_to_sum_random.Random (data_generator));
                     end loop;
                     if expected_sum /= natural (msgs.sum_result.sum) then
                        raise Ada.Assertions.Assertion_Error with
                           "expected_sum=" & Natural'Image (expected_sum) & " actual_sum=" & stdint_h.uint32_t'Image (msgs.sum_result.sum);
                     end if;
                     num_outstanding_replies := num_outstanding_replies - 1;
                     ibv_message_bw_interface_h.free_message (rx_buffer);

               when others =>
                  raise Ada.Assertions.Assertion_Error with
                    "process_sum_result_replies unexpected message_id " & stdint_h.uint32_t'Image (rx_buffer.header.message_id);
               end case;
            end;

         else
            exit;
         end if;
      end loop;
   end process_sum_result_replies;

   -- @brief Send a CW_SUM_INTEGERS message to a worker.
   -- @details The number of integers to sum, and their values, are generated with a psuedo-random
   --          pattern. This acts as a test of variable length messages.
   procedure send_sum_integers (tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
                                request_id : in Natural) is
      msgs : ibv_controller_worker_messages_h.controller_to_worker_msgs;
      pragma Import (C, msgs);
      for msgs'Address use tx_buffer.data;
      data_generator : data_to_sum_random.Generator;
      num_ints_generator : num_ints_to_sum_random.Generator;
   begin
      data_to_sum_random.Reset (Gen => data_generator, Initiator => request_id);
      num_ints_to_sum_random.Reset (Gen => num_ints_generator, Initiator => request_id);
      tx_buffer.header.message_id := ibv_controller_worker_messages_h.controller_worker_msg_ids'Pos
        (ibv_controller_worker_messages_h.CW_SUM_INTEGERS);
      msgs.sum_integers.request_id := Interfaces.C.unsigned (request_id);
      msgs.sum_integers.num_integers_to_sum :=
        Interfaces.C.unsigned (num_ints_to_sum_random.Random (num_ints_generator));
      for data_index in 0 .. (msgs.sum_integers.num_integers_to_sum - 1) loop
         msgs.sum_integers.integers_to_sum(Integer(data_index)) :=
           Interfaces.C.unsigned (data_to_sum_random.Random (data_generator));
      end loop;
      tx_buffer.header.message_length := msgs.sum_integers.integers_to_sum'Position +
        ((msgs.sum_integers.num_integers_to_sum * msgs.sum_integers.integers_to_sum(0)'Size) / 8);
      ibv_message_bw_interface_h.send_message (tx_buffer);
   end send_sum_integers;

   -- @details Perform a test by sending a number of CW_SUM_INTEGERS messages to the workers,
   --          and waiting for and then checking the CW_SUM_RESULT reply messages.
   procedure perform_sum_integer_test (communication_context : in ibv_message_bw_interface_h.communication_context_handle;
                                       paths_to_workers : in paths_to_workers_array;
                                       num_requests_per_worker : in out ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array) is
      num_unsent_requests : natural := 10000;
      num_outstanding_replies : natural := 0;
      next_request_id : natural := 1;
      next_worker_generator : next_worker_random.Generator;
      worker_node_id : all_workers;
      tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
   begin
      -- Send requests to the workers, and process the reponses, until all requests
      -- have been sent
      worker_node_id := next_worker_random.Random (next_worker_generator);
      while num_unsent_requests > 0 loop
         process_sum_result_replies (communication_context => communication_context,
                                     num_outstanding_replies => num_outstanding_replies);
         tx_buffer := ibv_message_bw_interface_h.get_send_buffer_no_wait (paths_to_workers(worker_node_id));
         if tx_buffer /= null then
            declare
               worker_node_index : constant Natural := natural(worker_node_id) - natural(all_workers'First);
            begin
               send_sum_integers (tx_buffer => tx_buffer, request_id => next_request_id);
               num_unsent_requests := num_unsent_requests - 1;
               num_outstanding_replies := num_outstanding_replies + 1;
               num_requests_per_worker(worker_node_index) := num_requests_per_worker(worker_node_index) + 1;
               worker_node_id := next_worker_random.Random (next_worker_generator);
               next_request_id := next_request_id + 1;
            end;
         end if;
      end loop;

      -- Wait for outstanding replies from the workers
      while num_outstanding_replies > 0 loop
         process_sum_result_replies (communication_context => communication_context,
                                     num_outstanding_replies => num_outstanding_replies);
      end loop;
   end perform_sum_integer_test;

   -- @brief Send a message to all workers to tell them to shutdown
   procedure shutdown_workers (paths_to_workers : in paths_to_workers_array;
                               num_requests_per_worker : in ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array) is
      tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
   begin
      for node_id in all_workers loop
         tx_buffer := ibv_message_bw_interface_h.get_send_buffer (paths_to_workers (node_id));
         declare
            msgs : ibv_controller_worker_messages_h.controller_to_worker_msgs;
            pragma Import (C, msgs);
            for msgs'Address use tx_buffer.data;
         begin
            msgs.request_shutdown.num_requests_per_worker := num_requests_per_worker;
            tx_buffer.header.message_id := ibv_controller_worker_messages_h.controller_worker_msg_ids'Pos
              (ibv_controller_worker_messages_h.CW_REQUEST_SHUTDOWN);
            tx_buffer.header.message_length := msgs.request_shutdown'Size / 8;
            ibv_message_bw_interface_h.send_message (tx_buffer);
         end;
      end loop;
   end shutdown_workers;

   communication_context : ibv_message_bw_interface_h.communication_context_handle;
   paths_to_workers : paths_to_workers_array;
   num_requests_per_worker : ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array := (others => 0);
begin
   -- Initialise, establishing connection with the workers
   ibv_controller_worker_messages_h.register_controller_worker_messages;
   communication_context :=
     ibv_message_bw_interface_h.communication_context_initialise (Interfaces.C.int (ibv_controller_worker_messages_h.CONTROLLER_NODE_ID));
   for node_id in all_workers loop
      paths_to_workers(node_id) :=
        ibv_message_bw_interface_h.get_tx_path_handle (context => communication_context,
                                                       destination_node => Interfaces.C.int (node_id),
                                                       instance => ibv_controller_worker_messages_h.controller_worker_path_instances'Pos
                                                         (ibv_controller_worker_messages_h.CONTROLLER_TO_WORKER_PATH));
   end loop;
   await_workers_ready (communication_context);

   -- Run the test, communicating with the workers
   perform_sum_integer_test (communication_context => communication_context, paths_to_workers => paths_to_workers,
                             num_requests_per_worker => num_requests_per_worker);

   -- Finalise, shuting down the workers
   shutdown_workers (paths_to_workers => paths_to_workers, num_requests_per_worker => num_requests_per_worker);
   ibv_message_bw_interface_h.communication_context_finalise (communication_context);
end Ibv_Controller_Process_Main;

-- @file ibv_controller_process_main.adb
-- @date 11 Feb 2018
-- @author Chester Gillon
-- @details The main for the controller process written in Ada with communicates with
--          worker processing written in C via the ibv_message_transport library.

pragma Restrictions (No_Exceptions);
with ada.Text_IO;
with Interfaces.C;
use Interfaces.C;
with Interfaces.C.Strings;
with Interfaces.C.Extensions;
with ibv_message_bw_interface_h;
with ibv_controller_worker_messages_h;
with Ada.Assertions;
with Ada.Numerics.Discrete_Random;
with stdint_h;

procedure Ibv_Controller_Process_Main is

   type all_workers is range ibv_controller_worker_messages_h.FIRST_WORKER_NODE_ID .. ibv_controller_worker_messages_h.LAST_WORKER_NODE_ID;
   type paths_to_workers_array is array (all_workers) of
      ibv_message_bw_interface_h.tx_message_context_handle;

   package next_worker_random is new Ada.Numerics.Discrete_Random (all_workers);

   type random_int_range is range 0..65535;
   package data_to_sum_random is new Ada.Numerics.Discrete_Random (random_int_range);

   type num_ints_range is range 1..ibv_controller_worker_messages_h.MAX_INTEGERS_TO_SUM;
   package num_ints_to_sum_random is new Ada.Numerics.Discrete_Random (num_ints_range);

   -- @brief Wait for all worker processes to report they are ready to run the test
   procedure await_workers_ready (communication_context : in ibv_message_bw_interface_h.communication_context_handle) is
      rx_buffer : access ibv_message_bw_interface_h.rx_api_message_buffer;
      num_remaining_workers : natural;
   begin
      num_remaining_workers := ibv_controller_worker_messages_h.NUM_WORKERS;
      while num_remaining_workers > 0 loop
         rx_buffer := ibv_message_bw_interface_h.await_any_rx_message (communication_context);
         declare
            msgs : ibv_controller_worker_messages_h.worker_to_controller_msgs;
            pragma Import (C, msgs);
            for msgs'Address use rx_buffer.data;
            max_name_index : constant Interfaces.C.size_t := Interfaces.C.size_t (msgs.worker_ready.worker_executable_pathname_len) - 1;
         begin
            case ibv_controller_worker_messages_h.controller_worker_msg_ids'Val(rx_buffer.header.message_id) is
               when ibv_controller_worker_messages_h.CW_WORKER_READY =>
                    ada.Text_IO.Put_Line ("worker " & stdint_h.uint32_t'Image (rx_buffer.header.source_instance) & " : " &
                                            Interfaces.C.To_Ada (Item => msgs.worker_ready.worker_executable_pathname(0..max_name_index), Trim_Nul => false));

               when others =>
                  ibv_message_bw_interface_h.check_assert (assertion => Interfaces.C.Extensions.bool (false),
                                                           message => Interfaces.C.Strings.New_String ("await_workers_ready unexpected message"));
            end case;
         end;

         ibv_message_bw_interface_h.free_message (rx_buffer);
         num_remaining_workers := num_remaining_workers - 1;
      end loop;
   end await_workers_ready;

   -- @brief Process all available CW_SUM_RESULT replies from the workers
   -- @detail This verifies that the expected sum has been returned, by using the returned
   --         request_id to seed the same same random number generators for the number and
   --         data values sent to calculate an expected sum.
   --         This avoids needing to keep track of the outstanding request messages.
   procedure process_sum_result_replies (communication_context : in ibv_message_bw_interface_h.communication_context_handle;
                                         num_outstanding_replies : in out natural) is
      rx_buffer : access ibv_message_bw_interface_h.rx_api_message_buffer;
   begin
      loop
         rx_buffer := ibv_message_bw_interface_h.poll_rx_paths (communication_context);
         if rx_buffer /= null then
            declare
               msgs : ibv_controller_worker_messages_h.worker_to_controller_msgs;
               pragma Import (C, msgs);
               for msgs'Address use rx_buffer.data;
               expected_sum : natural;
               data_generator : data_to_sum_random.Generator;
               num_ints_generator : num_ints_to_sum_random.Generator;
            begin
               case ibv_controller_worker_messages_h.controller_worker_msg_ids'Val(rx_buffer.header.message_id) is
                  when ibv_controller_worker_messages_h.CW_SUM_RESULT =>
                     data_to_sum_random.Reset (Gen => data_generator,
                                               Initiator => Standard.Integer(msgs.sum_result.request_id));
                     num_ints_to_sum_random.Reset (Gen => num_ints_generator,
                                                   Initiator => Standard.Integer(msgs.sum_result.request_id));
                     expected_sum := 0;
                     for ints_to_sum in 1 .. num_ints_to_sum_random.Random (num_ints_generator) loop
                        expected_sum := expected_sum + natural (data_to_sum_random.Random (data_generator));
                     end loop;
                     if expected_sum /= natural (msgs.sum_result.sum) then
                        ibv_message_bw_interface_h.check_assert (assertion => Interfaces.C.Extensions.bool (false),
                                                                 message => Interfaces.C.Strings.New_String ("process_sum_result_replies wrong sum"));
                     end if;
                     num_outstanding_replies := num_outstanding_replies - 1;
                     ibv_message_bw_interface_h.free_message (rx_buffer);

                  when others =>
                     ibv_message_bw_interface_h.check_assert (assertion => Interfaces.C.Extensions.bool (false),
                                                              message => Interfaces.C.Strings.New_String ("process_sum_result_replies unexpected message"));
               end case;
            end;

         else
            exit;
         end if;
      end loop;
   end process_sum_result_replies;

   -- @brief Send a CW_SUM_INTEGERS message to a worker.
   -- @details The number of integers to sum, and their values, are generated with a psuedo-random
   --          pattern. This acts as a test of variable length messages.
   procedure send_sum_integers (tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
                                request_id : in Natural) is
      msgs : ibv_controller_worker_messages_h.controller_to_worker_msgs;
      pragma Import (C, msgs);
      for msgs'Address use tx_buffer.data;
      data_generator : data_to_sum_random.Generator;
      num_ints_generator : num_ints_to_sum_random.Generator;
   begin
      data_to_sum_random.Reset (Gen => data_generator, Initiator => request_id);
      num_ints_to_sum_random.Reset (Gen => num_ints_generator, Initiator => request_id);
      tx_buffer.header.message_id := ibv_controller_worker_messages_h.controller_worker_msg_ids'Pos
        (ibv_controller_worker_messages_h.CW_SUM_INTEGERS);
      msgs.sum_integers.request_id := Interfaces.C.unsigned (request_id);
      msgs.sum_integers.num_integers_to_sum :=
        Interfaces.C.unsigned (num_ints_to_sum_random.Random (num_ints_generator));
      for data_index in 0 .. (msgs.sum_integers.num_integers_to_sum - 1) loop
         msgs.sum_integers.integers_to_sum(Integer(data_index)) :=
           Interfaces.C.unsigned (data_to_sum_random.Random (data_generator));
      end loop;
      tx_buffer.header.message_length := msgs.sum_integers.integers_to_sum'Position +
        ((msgs.sum_integers.num_integers_to_sum * msgs.sum_integers.integers_to_sum(0)'Size) / 8);
      ibv_message_bw_interface_h.send_message (tx_buffer);
   end send_sum_integers;

   -- @details Perform a test by sending a number of CW_SUM_INTEGERS messages to the workers,
   --          and waiting for and then checking the CW_SUM_RESULT reply messages.
   procedure perform_sum_integer_test (communication_context : in ibv_message_bw_interface_h.communication_context_handle;
                                       paths_to_workers : in paths_to_workers_array;
                                       num_requests_per_worker : in out ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array) is
      num_unsent_requests : natural := 10000;
      num_outstanding_replies : natural := 0;
      next_request_id : natural := 1;
      next_worker_generator : next_worker_random.Generator;
      worker_node_id : all_workers;
      tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
   begin
      -- Send requests to the workers, and process the reponses, until all requests
      -- have been sent
      worker_node_id := next_worker_random.Random (next_worker_generator);
      while num_unsent_requests > 0 loop
         process_sum_result_replies (communication_context => communication_context,
                                     num_outstanding_replies => num_outstanding_replies);
         tx_buffer := ibv_message_bw_interface_h.get_send_buffer_no_wait (paths_to_workers(worker_node_id));
         if tx_buffer /= null then
            declare
               worker_node_index : constant Natural := natural(worker_node_id) - natural(all_workers'First);
            begin
               send_sum_integers (tx_buffer => tx_buffer, request_id => next_request_id);
               num_unsent_requests := num_unsent_requests - 1;
               num_outstanding_replies := num_outstanding_replies + 1;
               num_requests_per_worker(worker_node_index) := num_requests_per_worker(worker_node_index) + 1;
               worker_node_id := next_worker_random.Random (next_worker_generator);
               next_request_id := next_request_id + 1;
            end;
         end if;
      end loop;

      -- Wait for outstanding replies from the workers
      while num_outstanding_replies > 0 loop
         process_sum_result_replies (communication_context => communication_context,
                                     num_outstanding_replies => num_outstanding_replies);
      end loop;
   end perform_sum_integer_test;

   -- @brief Send a message to all workers to tell them to shutdown
   procedure shutdown_workers (paths_to_workers : in paths_to_workers_array;
                               num_requests_per_worker : in ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array) is
      tx_buffer : access ibv_message_bw_interface_h.tx_api_message_buffer;
   begin
      for node_id in all_workers loop
         tx_buffer := ibv_message_bw_interface_h.get_send_buffer (paths_to_workers (node_id));
         declare
            msgs : ibv_controller_worker_messages_h.controller_to_worker_msgs;
            pragma Import (C, msgs);
            for msgs'Address use tx_buffer.data;
         begin
            msgs.request_shutdown.num_requests_per_worker := num_requests_per_worker;
            tx_buffer.header.message_id := ibv_controller_worker_messages_h.controller_worker_msg_ids'Pos
              (ibv_controller_worker_messages_h.CW_REQUEST_SHUTDOWN);
            tx_buffer.header.message_length := msgs.request_shutdown'Size / 8;
            ibv_message_bw_interface_h.send_message (tx_buffer);
         end;
      end loop;
   end shutdown_workers;

   communication_context : ibv_message_bw_interface_h.communication_context_handle;
   paths_to_workers : paths_to_workers_array;
   num_requests_per_worker : ibv_controller_worker_messages_h.request_shutdown_msg_num_requests_per_worker_array := (others => 0);
begin
   -- Initialise, establishing connection with the workers
   ibv_controller_worker_messages_h.register_controller_worker_messages;
   communication_context :=
     ibv_message_bw_interface_h.communication_context_initialise (Interfaces.C.int (ibv_controller_worker_messages_h.CONTROLLER_NODE_ID));
   for node_id in all_workers loop
      paths_to_workers(node_id) :=
        ibv_message_bw_interface_h.get_tx_path_handle (context => communication_context,
                                                       destination_node => Interfaces.C.int (node_id),
                                                       instance => ibv_controller_worker_messages_h.controller_worker_path_instances'Pos
                                                         (ibv_controller_worker_messages_h.CONTROLLER_TO_WORKER_PATH));
   end loop;
   await_workers_ready (communication_context);

   -- Run the test, communicating with the workers
   perform_sum_integer_test (communication_context => communication_context, paths_to_workers => paths_to_workers,
                             num_requests_per_worker => num_requests_per_worker);

   -- Finalise, shuting down the workers
   shutdown_workers (paths_to_workers => paths_to_workers, num_requests_per_worker => num_requests_per_worker);
   ibv_message_bw_interface_h.communication_context_finalise (communication_context);
end Ibv_Controller_Process_Main;

Use the C check_assert to report a failure, rather than raising an Ada Assertion_Error. This reduces the number of branches reported in the Coverage for ibv_controller_process_main.adb from 129 hit out of 274 to 84 hit out of 158.


-----------------------------------------------------------------------
--  ado-audits-tests -- Audit tests
--  Copyright (C) 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 Util.Test_Caller;
with Util.Strings;

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

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

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      pragma Unreferenced (Manager);

      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

Fix compilation warning

Fix compilation warning


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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Image",
                       Test_ISO8601_Image'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Value",
                       Test_ISO8601_Value'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Value (Errors)",
                       Test_ISO8601_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.Is_Same_Day",
                       Test_Is_Same_Day'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test converting a date in ISO8601.
   --  ------------------------------
   procedure Test_ISO8601_Image (T : in out Test) is
      T1 : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (1980, 1, 2, 10, 30, 23);
   begin
      Util.Tests.Assert_Equals (T, "1980-01-02", ISO8601.Image (T1),
                                "Invalid Image");

      Util.Tests.Assert_Equals (T, "1980", ISO8601.Image (T1, ISO8601.YEAR),
                                "Invalid Image (YEAR precision)");

      Util.Tests.Assert_Equals (T, "1980-01", ISO8601.Image (T1, ISO8601.MONTH),
                                "Invalid Image (MONTH precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02", ISO8601.Image (T1, ISO8601.DAY),
                                "Invalid Image (DAY precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10", ISO8601.Image (T1, ISO8601.HOUR),
                                "Invalid Image (DAY precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10:30", ISO8601.Image (T1, ISO8601.MINUTE),
                                "Invalid Image (MINUTE precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10:30:23", ISO8601.Image (T1, ISO8601.SECOND),
                                "Invalid Image (SECOND precision)");

   end Test_ISO8601_Image;

   --  ------------------------------
   --  Test converting a string in ISO8601 into a date.
   --  ------------------------------
   procedure Test_ISO8601_Value (T : in out Test) is
      Date   : Ada.Calendar.Time;
   begin
      Date := ISO8601.Value ("1980");
      Util.Tests.Assert_Equals (T, "1980-01-01", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-02");
      Util.Tests.Assert_Equals (T, "1980-02", ISO8601.Image (Date, ISO8601.MONTH));

      Date := ISO8601.Value ("1980-03-04");
      Util.Tests.Assert_Equals (T, "1980-03-04", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-03-04");
      Util.Tests.Assert_Equals (T, "1980-03-04", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-12-31");
      Util.Tests.Assert_Equals (T, "1980-12-31", ISO8601.Image (Date));

      Date := ISO8601.Value ("19801231");
      Util.Tests.Assert_Equals (T, "1980-12-31", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-12-31T11:23");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23", ISO8601.Image (Date, ISO8601.MINUTE));

      Date := ISO8601.Value ("1980-12-31T11:23:34");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23:34", ISO8601.Image (Date, ISO8601.SECOND));

      Date := ISO8601.Value ("1980-12-31T11:23:34.123");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23:34.123+00:00",
                                ISO8601.Image (Date, ISO8601.SUBSECOND));

      Date := ISO8601.Value ("1980-12-31T11:23:34.123+04:30");
      --  The date was normalized in GMT
      Util.Tests.Assert_Equals (T, "1980-12-31T06:53:34.123+00:00",
                                ISO8601.Image (Date, ISO8601.SUBSECOND));
   end Test_ISO8601_Value;

   --  ------------------------------
   --  Test value convertion errors.
   --  ------------------------------
   procedure Test_ISO8601_Error (T : in out Test) is
      procedure Check (Date : in String);

      procedure Check (Date : in String) is
      begin
         declare
            Unused : constant Ada.Calendar.Time := ISO8601.Value (Date);
         begin
            T.Fail ("No exception raised for " & Date);

         end;

      exception
         when Constraint_Error =>
            null;
      end Check;

   begin
      Check ("");
      Check ("1980-");
      Check ("1980:02:03");
      Check ("1980-02-03u33:33");
      Check ("1980-02-03u33");
      Check ("1980-13-44");
      Check ("1980-12-00");
      Check ("1980-12-03T25:34");
      Check ("1980-12-03T10x34");
      Check ("1980-12-03T10:34p");
      Check ("1980-12-31T11:23:34123");
      Check ("1980-12-31T11:23:34,1");
      Check ("1980-12-31T11:23:34,12");
      Check ("1980-12-31T11:23:34x123");
      Check ("1980-12-31T11:23:34.1234");
      Check ("1980-12-31T11:23:34Zp");
      Check ("1980-12-31T11:23:34+2");
      Check ("1980-12-31T11:23:34+23x");
      Check ("1980-12-31T11:23:34+99");
      Check ("1980-12-31T11:23:34+10:0");
      Check ("1980-12-31T11:23:34+10:03x");
   end Test_ISO8601_Error;

   --  ------------------------------
   --  Test Is_Same_Day operation.
   --  ------------------------------
   procedure Test_Is_Same_Day (T : in out Test) is
      procedure Check (D1, D2   : in String;
                       Same_Day : in Boolean);

      procedure Check (D1, D2   : in String;
                       Same_Day : in Boolean) is
         T1 : constant Ada.Calendar.Time := ISO8601.Value (D1);
         T2 : constant Ada.Calendar.Time := ISO8601.Value (D2);
      begin
         T.Assert (Same_Day = Is_Same_Day (T1, T2), "Invalid Is_Same_Day for " & D1 & " " & D2);
         T.Assert (Same_Day = Is_Same_Day (T2, T1), "Invalid Is_Same_Day for " & D2 & " " & D1);
      end Check;

   begin
      Check ("1980-12-31T11:23:34.123", "1980-12-31T10:23:34.123", True);
      Check ("1980-12-31T11:23:34.123", "1980-12-30T10:23:34.123", False);
      Check ("1980-12-31T00:00:00", "1980-12-31T23:59:59", True);
   end Test_Is_Same_Day;

end Util.Dates.Tests;

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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Image",
                       Test_ISO8601_Image'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Value",
                       Test_ISO8601_Value'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.ISO8601.Value (Errors)",
                       Test_ISO8601_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.Is_Same_Day",
                       Test_Is_Same_Day'Access);
      Caller.Add_Test (Suite, "Test Util.Dates.Get_Day_Count",
                       Test_Get_Day_Count'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test converting a date in ISO8601.
   --  ------------------------------
   procedure Test_ISO8601_Image (T : in out Test) is
      T1 : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (1980, 1, 2, 10, 30, 23);
   begin
      Util.Tests.Assert_Equals (T, "1980-01-02", ISO8601.Image (T1),
                                "Invalid Image");

      Util.Tests.Assert_Equals (T, "1980", ISO8601.Image (T1, ISO8601.YEAR),
                                "Invalid Image (YEAR precision)");

      Util.Tests.Assert_Equals (T, "1980-01", ISO8601.Image (T1, ISO8601.MONTH),
                                "Invalid Image (MONTH precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02", ISO8601.Image (T1, ISO8601.DAY),
                                "Invalid Image (DAY precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10", ISO8601.Image (T1, ISO8601.HOUR),
                                "Invalid Image (DAY precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10:30", ISO8601.Image (T1, ISO8601.MINUTE),
                                "Invalid Image (MINUTE precision)");

      Util.Tests.Assert_Equals (T, "1980-01-02T10:30:23", ISO8601.Image (T1, ISO8601.SECOND),
                                "Invalid Image (SECOND precision)");

   end Test_ISO8601_Image;

   --  ------------------------------
   --  Test converting a string in ISO8601 into a date.
   --  ------------------------------
   procedure Test_ISO8601_Value (T : in out Test) is
      Date   : Ada.Calendar.Time;
   begin
      Date := ISO8601.Value ("1980");
      Util.Tests.Assert_Equals (T, "1980-01-01", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-02");
      Util.Tests.Assert_Equals (T, "1980-02", ISO8601.Image (Date, ISO8601.MONTH));

      Date := ISO8601.Value ("1980-03-04");
      Util.Tests.Assert_Equals (T, "1980-03-04", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-03-04");
      Util.Tests.Assert_Equals (T, "1980-03-04", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-12-31");
      Util.Tests.Assert_Equals (T, "1980-12-31", ISO8601.Image (Date));

      Date := ISO8601.Value ("19801231");
      Util.Tests.Assert_Equals (T, "1980-12-31", ISO8601.Image (Date));

      Date := ISO8601.Value ("1980-12-31T11:23");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23", ISO8601.Image (Date, ISO8601.MINUTE));

      Date := ISO8601.Value ("1980-12-31T11:23:34");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23:34", ISO8601.Image (Date, ISO8601.SECOND));

      Date := ISO8601.Value ("1980-12-31T11:23:34.123");
      Util.Tests.Assert_Equals (T, "1980-12-31T11:23:34.123+00:00",
                                ISO8601.Image (Date, ISO8601.SUBSECOND));

      Date := ISO8601.Value ("1980-12-31T11:23:34.123+04:30");
      --  The date was normalized in GMT
      Util.Tests.Assert_Equals (T, "1980-12-31T06:53:34.123+00:00",
                                ISO8601.Image (Date, ISO8601.SUBSECOND));
   end Test_ISO8601_Value;

   --  ------------------------------
   --  Test value convertion errors.
   --  ------------------------------
   procedure Test_ISO8601_Error (T : in out Test) is
      procedure Check (Date : in String);

      procedure Check (Date : in String) is
      begin
         declare
            Unused : constant Ada.Calendar.Time := ISO8601.Value (Date);
         begin
            T.Fail ("No exception raised for " & Date);

         end;

      exception
         when Constraint_Error =>
            null;
      end Check;

   begin
      Check ("");
      Check ("1980-");
      Check ("1980:02:03");
      Check ("1980-02-03u33:33");
      Check ("1980-02-03u33");
      Check ("1980-13-44");
      Check ("1980-12-00");
      Check ("1980-12-03T25:34");
      Check ("1980-12-03T10x34");
      Check ("1980-12-03T10:34p");
      Check ("1980-12-31T11:23:34123");
      Check ("1980-12-31T11:23:34,1");
      Check ("1980-12-31T11:23:34,12");
      Check ("1980-12-31T11:23:34x123");
      Check ("1980-12-31T11:23:34.1234");
      Check ("1980-12-31T11:23:34Zp");
      Check ("1980-12-31T11:23:34+2");
      Check ("1980-12-31T11:23:34+23x");
      Check ("1980-12-31T11:23:34+99");
      Check ("1980-12-31T11:23:34+10:0");
      Check ("1980-12-31T11:23:34+10:03x");
   end Test_ISO8601_Error;

   --  ------------------------------
   --  Test Is_Same_Day operation.
   --  ------------------------------
   procedure Test_Is_Same_Day (T : in out Test) is
      procedure Check (D1, D2   : in String;
                       Same_Day : in Boolean);

      procedure Check (D1, D2   : in String;
                       Same_Day : in Boolean) is
         T1 : constant Ada.Calendar.Time := ISO8601.Value (D1);
         T2 : constant Ada.Calendar.Time := ISO8601.Value (D2);
      begin
         T.Assert (Same_Day = Is_Same_Day (T1, T2), "Invalid Is_Same_Day for " & D1 & " " & D2);
         T.Assert (Same_Day = Is_Same_Day (T2, T1), "Invalid Is_Same_Day for " & D2 & " " & D1);
      end Check;

   begin
      Check ("1980-12-31T11:23:34.123", "1980-12-31T10:23:34.123", True);
      Check ("1980-12-31T11:23:34.123", "1980-12-30T10:23:34.123", False);
      Check ("1980-12-31T00:00:00", "1980-12-31T23:59:59", True);
   end Test_Is_Same_Day;

   --  ------------------------------
   --  Test Get_Day_Count operation.
   --  ------------------------------
   procedure Test_Get_Day_Count (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, 366, Natural (Get_Day_Count (2020)));
      Util.Tests.Assert_Equals (T, 365, Natural (Get_Day_Count (1983)));
      Util.Tests.Assert_Equals (T, 366, Natural (Get_Day_Count (2000)));
      Util.Tests.Assert_Equals (T, 365, Natural (Get_Day_Count (2001)));
   end Test_Get_Day_Count;

end Util.Dates.Tests;

Implement Test_Get_Day_Count and register the test for execution


-----------------------------------------------------------------------
--  babel-files-maps -- Hash maps for files and directories
--  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.
-----------------------------------------------------------------------

package body Babel.Files.Maps is

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Type is
      Pos : constant File_Cursor := From.Find (Key => Name'Unrestricted_Access);
   begin
      if File_Maps.Has_Element (Pos) then
         return File_Maps.Element (Pos);
      else
         return NO_FILE;
      end if;
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in the directory map.
   --  ------------------------------
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in the directory map.
   --  ------------------------------
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Type is
      Pos : constant Directory_Cursor := From.Find (Key => Name'Unrestricted_Access);
   begin
      if Directory_Maps.Has_Element (Pos) then
         return Directory_Maps.Element (Pos);
      else
         return NO_DIRECTORY;
      end if;
   end Find;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Files.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Dirs.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type is
   begin
      return Find (From.Known_Files, Name);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type is
   begin
      return Find (From.Known_Dirs, Name);
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type) is
   begin
      Default_Container (Into).Set_Directory (Directory);
      Into.Known_Files.Clear;
      Into.Known_Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   --  ------------------------------
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map)) is
   begin
      Update (Container.Known_Files, Container.Known_Dirs);
   end Prepare;

end Babel.Files.Maps;

-----------------------------------------------------------------------
--  babel-files-maps -- Hash maps for files and directories
--  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.
-----------------------------------------------------------------------

package body Babel.Files.Maps is

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Type is
      Pos : constant File_Cursor := From.Find (Key => Name'Unrestricted_Access);
   begin
      if File_Maps.Has_Element (Pos) then
         return File_Maps.Element (Pos);
      else
         return NO_FILE;
      end if;
   end Find;

   --  ------------------------------
   --  Insert the file in the file map.
   --  ------------------------------
   procedure Insert (Into : in out File_Map;
                     File : in File_Type) is
   begin
      Into.Insert (Key => File.Name'Unrestricted_Access, New_Item => File);
   end Insert;

   --  ------------------------------
   --  Find the directory with the given name in the directory map.
   --  ------------------------------
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in the directory map.
   --  ------------------------------
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Type is
      Pos : constant Directory_Cursor := From.Find (Key => Name'Unrestricted_Access);
   begin
      if Directory_Maps.Has_Element (Pos) then
         return Directory_Maps.Element (Pos);
      else
         return NO_DIRECTORY;
      end if;
   end Find;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Files.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Dirs.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type is
   begin
      return Find (From.Known_Files, Name);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type is
   begin
      return Find (From.Known_Dirs, Name);
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type) is
   begin
      Default_Container (Into).Set_Directory (Directory);
      Into.Known_Files.Clear;
      Into.Known_Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   --  ------------------------------
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map)) is
   begin
      Update (Container.Known_Files, Container.Known_Dirs);
   end Prepare;

end Babel.Files.Maps;

Implement the Insert procedure

Implement the Insert procedure


-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 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 ADO.Queries;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Services.Contexts;
with AWA.Questions.Services;
package body AWA.Questions.Beans is

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
            From.Service.Load_Question (From,
                                        ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Service.Save_Question (Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service := Module.Get_Question_Manager;
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Answer (From,
                                   ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  Delete the question.
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module.Get_Question_Manager;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_Info_List_Bean_Access := new Question_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            AWA.Questions.Models.List (From.Answer_List, Session, Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module.Get_Question_Manager;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 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 ADO.Queries;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
            From.Service.Load_Question (From,
                                        ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service := Module.Get_Question_Manager;
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Answer (From,
                                   ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Identifier (Util.Beans.Objects.To_Integer (Value)));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  Delete the question.
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module.Get_Question_Manager;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_Info_List_Bean_Access := new Question_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            AWA.Questions.Models.List (From.Answer_List, Session, Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module.Get_Question_Manager;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

Add the user identifier (if known) to the query to get his rating for the question


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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Constants;

package body Util.Systems.DLLs is

   function Sys_Dlopen (Path  : in Interfaces.C.Strings.chars_ptr;
                        Mode  : in Flags) return Handle;
   pragma Import (C, Sys_Dlopen, "dlopen");

   function Sys_Dlclose (Lib : in Handle) return Interfaces.C.int;
   pragma Import (C, Sys_Dlclose, "dlclose");

   function Sys_Dlsym (Lib    : in Handle;
                       Symbol : in Interfaces.C.Strings.chars_ptr) return System.Address;
   pragma Import (C, Sys_Dlsym, "dlsym");

   function Sys_Dlerror return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Dlerror, "dlerror");

   function Error_Message return String is
   begin
      return Interfaces.C.Strings.Value (Sys_Dlerror);
   end Error_Message;

   pragma Linker_Options ("-ldl");

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := Util.Systems.Constants.RTLD_LAZY) return Handle is
      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : Handle := Sys_Dlopen (Lib, Mode);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Dlclose (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.Chars_Ptr := Interfaces.C.Strings.New_String (Name);
      Result : System.Address := Sys_Dlsym (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Constants;

package body Util.Systems.DLLs is

   function Sys_Dlopen (Path  : in Interfaces.C.Strings.chars_ptr;
                        Mode  : in Flags) return Handle;
   pragma Import (C, Sys_Dlopen, "dlopen");

   function Sys_Dlclose (Lib : in Handle) return Interfaces.C.int;
   pragma Import (C, Sys_Dlclose, "dlclose");

   function Sys_Dlsym (Lib    : in Handle;
                       Symbol : in Interfaces.C.Strings.chars_ptr) return System.Address;
   pragma Import (C, Sys_Dlsym, "dlsym");

   function Sys_Dlerror return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Dlerror, "dlerror");

   function Error_Message return String is
   begin
      return Interfaces.C.Strings.Value (Sys_Dlerror);
   end Error_Message;

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := Util.Systems.Constants.RTLD_LAZY) return Handle is
      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : Handle := Sys_Dlopen (Lib, Mode);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Dlclose (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.Chars_Ptr := Interfaces.C.Strings.New_String (Name);
      Result : System.Address := Sys_Dlsym (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

Move the linker option in the generated Util.Systems.Constants package