-----------------------------------------------------------------------
--  awa-events-dispatchers-tasks -- AWA Event Dispatchers
--  Copyright (C) 2012, 2015, 2017, 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

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

   use Util.Log;
   use Ada.Strings.Unbounded;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Tasks");

   --  ------------------------------
   --  Start the dispatcher.
   --  ------------------------------
   overriding
   procedure Start (Manager : in out Task_Dispatcher) is
   begin
      if Manager.Queues.Get_Count > 0 then
         Log.Info ("Starting the tasks");

         if Manager.Workers = null then
            Manager.Workers := new Consumer_Array (1 .. Manager.Task_Count);
         end if;

         for I in Manager.Workers'Range loop
            Manager.Workers (I).Start (Manager'Unchecked_Access);
         end loop;
      else
         Log.Info ("No event dispatcher task started (no event queue to poll)");
      end if;
   end Start;

   --  ------------------------------
   --  Stop the dispatcher.
   --  ------------------------------
   overriding
   procedure Stop (Manager : in out Task_Dispatcher) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Consumer_Array,
                                        Name   => Consumer_Array_Access);
   begin
      if Manager.Workers /= null then
         Log.Info ("Stopping the event dispatcher tasks");

         for I in Manager.Workers'Range loop
            if Manager.Workers (I)'Callable then
               Manager.Workers (I).Stop;
            else
               Log.Error ("Event consumer task terminated abnormally");
            end if;
         end loop;
         Free (Manager.Workers);
      end if;
   end Stop;

   procedure Add_Queue (Manager : in out Task_Dispatcher;
                        Queue   : in AWA.Events.Queues.Queue_Ref;
                        Added   : out Boolean) is
   begin
      Log.Info ("Adding queue {0} to the task dispatcher", Queue.Get_Name);

      Manager.Queues.Enqueue (Queue);
      Added := True;
   end Add_Queue;

   function Create_Dispatcher (Service  : in AWA.Events.Services.Event_Manager_Access;
                               Match    : in String;
                               Count    : in Positive;
                               Priority : in Positive) return Dispatcher_Access is
      Result : constant Task_Dispatcher_Access := new Task_Dispatcher;
   begin
      Result.Task_Count := Count;
      Result.Priority   := Priority;
      Result.Match      := To_Unbounded_String (Match);
      Result.Manager    := Service.all'Access;
      return Result.all'Access;
   end Create_Dispatcher;

   task body Consumer is
      Dispatcher : Task_Dispatcher_Access;
      Time       : Duration := 0.01;
      Do_Work    : Boolean := True;
   begin
      Log.Info ("Event consumer is ready");
      select
         accept Start (D : in Task_Dispatcher_Access) do
            Dispatcher := D;
         end Start;
         Log.Info ("Event consumer is started");

         while Do_Work loop
            declare
               Nb_Queues : constant Natural := Dispatcher.Queues.Get_Count;
               Queue     : AWA.Events.Queues.Queue_Ref;
               Nb_Events : Natural := 0;
               Context   : AWA.Services.Contexts.Service_Context;
            begin
               --  Set the service context.
               Context.Set_Context (Application => Dispatcher.Manager.Get_Application.all'Access,
                                    Principal   => null);

               --  We can have several tasks that dispatch events from several queues.
               --  Each queue in the list must be given the same polling quota.
               --  Pick a queue and dispatch some pending events.
               --  Put back the queue in the fifo.
               for I in 1 .. Nb_Queues loop
                  Dispatcher.Queues.Dequeue (Queue);
                  begin
                     Dispatcher.Dispatch (Queue, Nb_Events);

                  exception
                     when E : others =>
                        Log.Error ("Exception when dispatching events", E, True);
                  end;
                  Dispatcher.Queues.Enqueue (Queue);
               end loop;

               --  If we processed something, reset the timeout delay and continue polling.
               --  Otherwise, double the sleep time.
               if Nb_Events /= 0 then
                  Time := 0.01;
               else
                  Log.Debug ("Sleeping {0} seconds", Duration'Image (Time));

                  select
                     accept Stop do
                        Do_Work := False;
                     end Stop;
                  or
                     accept Start (D : in Task_Dispatcher_Access) do
                        Dispatcher := D;
                     end Start;
                  or
                     delay Time;
                  end select;

                  if Time < 60.0 then
                     Time := Time * 2.0;
                  end if;
               end if;
            end;
         end loop;
      or
         terminate;
      end select;
   end Consumer;

end AWA.Events.Dispatchers.Tasks;

-----------------------------------------------------------------------
--  awa-events-dispatchers-tasks -- AWA Event Dispatchers
--  Copyright (C) 2012, 2015, 2017, 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

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

   use Util.Log;
   use Ada.Strings.Unbounded;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Tasks");

   --  ------------------------------
   --  Start the dispatcher.
   --  ------------------------------
   overriding
   procedure Start (Manager : in out Task_Dispatcher) is
   begin
      if Manager.Queues.Get_Count > 0 then
         Log.Info ("Starting the tasks");

         if Manager.Workers = null then
            Manager.Workers := new Consumer_Array (1 .. Manager.Task_Count);
         end if;

         for I in Manager.Workers'Range loop
            Manager.Workers (I).Start (Manager'Unchecked_Access);
         end loop;
      else
         Log.Info ("No event dispatcher task started (no event queue to poll)");
      end if;
   end Start;

   --  ------------------------------
   --  Stop the dispatcher.
   --  ------------------------------
   overriding
   procedure Stop (Manager : in out Task_Dispatcher) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Consumer_Array,
                                        Name   => Consumer_Array_Access);
   begin
      if Manager.Workers /= null then
         Log.Info ("Stopping the event dispatcher tasks");

         for I in Manager.Workers'Range loop
            if Manager.Workers (I)'Callable then
               Manager.Workers (I).Stop;
            else
               Log.Error ("Event consumer task terminated abnormally");
            end if;
         end loop;
         Free (Manager.Workers);
      end if;
   end Stop;

   --  ------------------------------
   --  Inform the dispatch that some events may have been queued.
   --  ------------------------------
   overriding
   procedure Update (Manager : in Task_Dispatcher;
                     Queue   : in Queues.Queue_Ref) is
      pragma Unreferenced (Queue);
   begin
      if Manager.Workers /= null then
         Log.Debug ("Wakeup dispatcher tasks");

         for I in Manager.Workers'Range loop
            if Manager.Workers (I)'Callable then
               Manager.Workers (I).Wakeup;
            else
               Log.Error ("Event consumer task terminated abnormally");
            end if;
         end loop;
      end if;
   end Update;

   procedure Add_Queue (Manager : in out Task_Dispatcher;
                        Queue   : in AWA.Events.Queues.Queue_Ref;
                        Added   : out Boolean) is
   begin
      Log.Info ("Adding queue {0} to the task dispatcher", Queue.Get_Name);

      Manager.Queues.Enqueue (Queue);
      Queue.Add_Listener (Manager'Unchecked_Access);
      Added := True;
   end Add_Queue;

   function Create_Dispatcher (Service  : in AWA.Events.Services.Event_Manager_Access;
                               Match    : in String;
                               Count    : in Positive;
                               Priority : in Positive) return Dispatcher_Access is
      Result : constant Task_Dispatcher_Access := new Task_Dispatcher;
   begin
      Result.Task_Count := Count;
      Result.Priority   := Priority;
      Result.Match      := To_Unbounded_String (Match);
      Result.Manager    := Service.all'Access;
      return Result.all'Access;
   end Create_Dispatcher;

   task body Consumer is
      Dispatcher : Task_Dispatcher_Access;
      Time       : Duration := 0.01;
      Do_Work    : Boolean := True;
   begin
      Log.Info ("Event consumer is ready");
      select
         accept Start (D : in Task_Dispatcher_Access) do
            Dispatcher := D;
         end Start;
         Log.Info ("Event consumer is started");

         while Do_Work loop
            declare
               Nb_Queues : constant Natural := Dispatcher.Queues.Get_Count;
               Queue     : AWA.Events.Queues.Queue_Ref;
               Nb_Events : Natural := 0;
               Context   : AWA.Services.Contexts.Service_Context;
            begin
               --  Set the service context.
               Context.Set_Context (Application => Dispatcher.Manager.Get_Application.all'Access,
                                    Principal   => null);

               --  We can have several tasks that dispatch events from several queues.
               --  Each queue in the list must be given the same polling quota.
               --  Pick a queue and dispatch some pending events.
               --  Put back the queue in the fifo.
               for I in 1 .. Nb_Queues loop
                  Dispatcher.Queues.Dequeue (Queue);
                  begin
                     Dispatcher.Dispatch (Queue, Nb_Events);

                  exception
                     when E : others =>
                        Log.Error ("Exception when dispatching events", E, True);
                  end;
                  Dispatcher.Queues.Enqueue (Queue);
               end loop;

               --  If we processed something, reset the timeout delay and continue polling.
               --  Otherwise, double the sleep time.
               if Nb_Events /= 0 then
                  Time := 0.01;
               else
                  Log.Debug ("Sleeping {0} seconds", Duration'Image (Time));

                  select
                     accept Stop do
                        Do_Work := False;
                     end Stop;
                  or
                     accept Wakeup do
                        Do_Work := True;
                     end Wakeup;
                  or
                     accept Start (D : in Task_Dispatcher_Access) do
                        Dispatcher := D;
                     end Start;
                  or
                     delay Time;
                  end select;

                  if Time < 60.0 then
                     Time := Time * 2.0;
                  end if;
               end if;
            end;
         end loop;
      or
         terminate;
      end select;
   end Consumer;

end AWA.Events.Dispatchers.Tasks;

Implement the Update procedure and wakeup the tasks if necessary


-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 2011, 2012, 2013, 2014, 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.
-----------------------------------------------------------------------

with Interfaces;

with Ada.IO_Exceptions;
with Ada.Directories;
with Ada.Unchecked_Deallocation;

with ADO.Drivers.Connections;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers.Connections;
   use Interfaces;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Base_Time : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year  => 1970,
                                                                   Month => 1,
                                                                   Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Unsigned_32 := 60;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Last_Query  : Query_Index := 0;
   Last_File   : File_Index := 0;

   --  Convert a Time to an Unsigned_32.
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32;
   pragma Inline_Always (To_Unsigned_32);

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (File : in Query_File_Info) return Unsigned_32;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Last_Query   := Last_Query + 1;
      Query.File   := File;
      Query.Next   := File.Queries;
      Query.Query  := Last_Query;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         Last_File := Last_File + 1;
         File.Next := Query_Files;
         File.File := Last_File;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant Drivers.Connections.Driver_Access
           := Drivers.Connections.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Convert a Time to an Unsigned_32.
   --  ------------------------------
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32 is
      D : constant Duration := Duration '(T - Base_Time);
   begin
      return Unsigned_32 (D);
   end To_Unsigned_32;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (File : in Query_File_Info) return Unsigned_32 is
   begin
      return To_Unsigned_32 (Ada.Directories.Modification_Time (File.Path.all));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", File.Path.all);
         return 0;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (File : in out Query_File_Info) return Boolean is
      Now : constant Unsigned_32 := To_Unsigned_32 (Ada.Calendar.Clock);
   begin
      --  Have we passed the next check time?
      if File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Unsigned_32 := Modification_Time (File);
      begin
         if File.Last_Modified = M then
            return False;
         end if;
         File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Manager : in Query_Manager;
                         File    : in out Query_File_Info) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT, FIELD_QUERY);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is record
         --  File       : Query_File_Access;
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Ref.Ref;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
         use ADO.Drivers;
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (File, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            if Into.Query_Def /= null then
               Into.Query := Query_Info_Ref.Create;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Main_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Count_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_QUERY =>
            if Into.Query_Def /= null then
               --  Now we can safely setup the query info associated with the query definition.
               Manager.Queries (Into.Query_Def.Query).Set (Into.Query);
            end if;
            Into.Query_Def := null;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
      Mapper     : Util.Serialize.Mappers.Processing;
   begin
      Log.Info ("Reading XML query {0}", File.Path.all);
      --  Loader.File   := Into;
      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Sql_Mapper.Add_Mapping ("query", FIELD_QUERY);
      Mapper.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Mapper, Loader'Access);

      --  Read the XML query file.
      Reader.Parse (File.Path.all, Mapper);

      File.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", File.Path.all);

   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Manager : in Query_Manager;
                         Into    : in Query_Definition_Access) is
   begin
      if Manager.Queries (Into.Query).Get.Is_Null or else Is_Modified (Manager.Files (Into.File.File)) then
         Read_Query (Manager, Manager.Files (Into.File.File));
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Manager : in out Query_Manager;
                         Config  : in ADO.Drivers.Connections.Configuration'Class) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => String,
                                         Name   => Ada.Strings.Unbounded.String_Access);

      Paths : constant String := Config.Get_Property ("ado.queries.paths");
      Load  : constant Boolean := Config.Get_Property ("ado.queries.load") = "true";
      File : Query_File_Access := Query_Files;
      Pos  : Query_Index_Table := 1;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      if Manager.Queries = null then
         Manager.Queries := new Query_Table (1 .. Last_Query);
      end if;
      if Manager.Files = null then
         Manager.Files := new File_Table (1 .. Last_File);
      end if;
      Manager.Driver := Config.Get_Driver;
      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Name.all,
                                                                 Paths => Paths);
            Query : Query_Definition_Access := File.Queries;
         begin
            Manager.Files (File.File).File := File;
            Manager.Files (File.File).Path := new String '(Path);

            if Load then
               Read_Query (Manager, Manager.Files (File.File));
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body File is
   begin
      File.Name := Name'Access;
      File.Sha1_Map := Hash'Access;
   end File;

   package body Query is
   begin
      Query.Name := Query_Name'Access;
      Query.Query := 0;
      Query.File  := File;
      Query.Next  := null;
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

-----------------------------------------------------------------------
--  ado-queries-loaders -- Loader for Database Queries
--  Copyright (C) 2011, 2012, 2013, 2014, 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.
-----------------------------------------------------------------------

with Interfaces;

with Ada.IO_Exceptions;
with Ada.Directories;
with Ada.Unchecked_Deallocation;

with ADO.Drivers.Connections;

with Util.Files;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package body ADO.Queries.Loaders is

   use Util.Log;
   use ADO.Drivers.Connections;
   use Interfaces;
   use Ada.Calendar;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Queries.Loaders");

   Base_Time : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year  => 1970,
                                                                   Month => 1,
                                                                   Day   => 1);

   --  Check for file modification time at most every 60 seconds.
   FILE_CHECK_DELTA_TIME : constant Unsigned_32 := 60;

   --  The list of query files defined by the application.
   Query_Files : Query_File_Access := null;

   Last_Query  : Query_Index := 0;
   Last_File   : File_Index := 0;

   --  Convert a Time to an Unsigned_32.
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32;
   pragma Inline_Always (To_Unsigned_32);

   --  Get the modification time of the XML query file associated with the query.
   function Modification_Time (File : in Query_File_Info) return Unsigned_32;

   --  Initialize the query SQL pattern with the value
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Register the query definition in the query file.  Registration is done
   --  in the package elaboration phase.
   --  ------------------------------
   procedure Register (File  : in Query_File_Access;
                       Query : in Query_Definition_Access) is
   begin
      Last_Query   := Last_Query + 1;
      Query.File   := File;
      Query.Next   := File.Queries;
      Query.Query  := Last_Query;
      File.Queries := Query;
      if File.Next = null and then Query_Files /= File then
         Last_File := Last_File + 1;
         File.Next := Query_Files;
         File.File := Last_File;
         Query_Files := File;
      end if;
   end Register;

   function Find_Driver (Name : in String) return Integer;

   function Find_Driver (Name : in String) return Integer is
   begin
      if Name'Length = 0 then
         return 0;
      end if;
      declare
         Driver : constant Drivers.Connections.Driver_Access
           := Drivers.Connections.Get_Driver (Name);
      begin
         if Driver = null then
            --  There is no problem to have an SQL query for unsupported drivers, but still
            --  report some warning.
            Log.Warn ("Database driver {0} not found", Name);
            return -1;
         end if;
         return Integer (Driver.Get_Driver_Index);
      end;
   end Find_Driver;

   --  ------------------------------
   --  Convert a Time to an Unsigned_32.
   --  ------------------------------
   function To_Unsigned_32 (T : in Ada.Calendar.Time) return Unsigned_32 is
      D : constant Duration := Duration '(T - Base_Time);
   begin
      return Unsigned_32 (D);
   end To_Unsigned_32;

   --  ------------------------------
   --  Get the modification time of the XML query file associated with the query.
   --  ------------------------------
   function Modification_Time (File : in Query_File_Info) return Unsigned_32 is
      Path : constant String := To_String (File.Path);
   begin
      return To_Unsigned_32 (Ada.Directories.Modification_Time (Path));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Path);
         return 0;
   end Modification_Time;

   --  ------------------------------
   --  Returns True if the XML query file must be reloaded.
   --  ------------------------------
   function Is_Modified (File : in out Query_File_Info) return Boolean is
      Now : constant Unsigned_32 := To_Unsigned_32 (Ada.Calendar.Clock);
   begin
      --  Have we passed the next check time?
      if File.Next_Check > Now then
         return False;
      end if;

      --  Next check in N seconds (60 by default).
      File.Next_Check := Now + FILE_CHECK_DELTA_TIME;

      --  See if the file was changed.
      declare
         M : constant Unsigned_32 := Modification_Time (File);
      begin
         if File.Last_Modified = M then
            return False;
         end if;
         File.Last_Modified := M;
         return True;
      end;
   end Is_Modified;

   --  ------------------------------
   --  Initialize the query SQL pattern with the value
   --  ------------------------------
   procedure Set_Query_Pattern (Into  : in out Query_Pattern;
                                Value : in Util.Beans.Objects.Object) is
   begin
      Into.SQL := Util.Beans.Objects.To_Unbounded_String (Value);
   end Set_Query_Pattern;

   procedure Read_Query (Manager : in Query_Manager;
                         File    : in out Query_File_Info) is

      type Query_Info_Fields is (FIELD_CLASS_NAME, FIELD_PROPERTY_TYPE,
                                 FIELD_PROPERTY_NAME, FIELD_QUERY_NAME,
                                 FIELD_SQL_DRIVER,
                                 FIELD_SQL, FIELD_SQL_COUNT, FIELD_QUERY);

      --  The Query_Loader holds context and state information for loading
      --  the XML query file and initializing the Query_Definition.
      type Query_Loader is record
         --  File       : Query_File_Access;
         Hash_Value : Unbounded_String;
         Query_Def  : Query_Definition_Access;
         Query      : Query_Info_Ref.Ref;
         Driver     : Integer;
      end record;
      type Query_Loader_Access is access all Query_Loader;

      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Called by the de-serialization when a given field is recognized.
      --  ------------------------------
      procedure Set_Member (Into  : in out Query_Loader;
                            Field : in Query_Info_Fields;
                            Value : in Util.Beans.Objects.Object) is
         use ADO.Drivers;
      begin
         case Field is
         when FIELD_CLASS_NAME =>
            Append (Into.Hash_Value, " class=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_TYPE =>
            Append (Into.Hash_Value, " type=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_PROPERTY_NAME =>
            Append (Into.Hash_Value, " name=");
            Append (Into.Hash_Value, Util.Beans.Objects.To_Unbounded_String (Value));

         when FIELD_QUERY_NAME =>
            Into.Query_Def  := Find_Query (File, Util.Beans.Objects.To_String (Value));
            Into.Driver := 0;
            if Into.Query_Def /= null then
               Into.Query := Query_Info_Ref.Create;
            end if;

         when FIELD_SQL_DRIVER =>
            Into.Driver := Find_Driver (Util.Beans.Objects.To_String (Value));

         when FIELD_SQL =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Main_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_SQL_COUNT =>
            if not Into.Query.Is_Null and Into.Driver >= 0 and Into.Query_Def /= null then
               Set_Query_Pattern (Into.Query.Value.Count_Query (Driver_Index (Into.Driver)),
                                  Value);
            end if;
            Into.Driver := 0;

         when FIELD_QUERY =>
            if Into.Query_Def /= null then
               --  Now we can safely setup the query info associated with the query definition.
               Manager.Queries (Into.Query_Def.Query).Set (Into.Query);
            end if;
            Into.Query_Def := null;

         end case;
      end Set_Member;

      package Query_Mapper is
        new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Query_Loader,
                                                  Element_Type_Access => Query_Loader_Access,
                                                  Fields              => Query_Info_Fields,
                                                  Set_Member          => Set_Member);

      Loader     : aliased Query_Loader;
      Sql_Mapper : aliased Query_Mapper.Mapper;
      Reader     : Util.Serialize.IO.XML.Parser;
      Mapper     : Util.Serialize.Mappers.Processing;
      Path       : constant String := To_String (File.Path);
   begin
      Log.Info ("Reading XML query {0}", Path);
      --  Loader.File   := Into;
      Loader.Driver := 0;

      --  Create the mapping to load the XML query file.
      Sql_Mapper.Add_Mapping ("class/@name", FIELD_CLASS_NAME);
      Sql_Mapper.Add_Mapping ("class/property/@type", FIELD_PROPERTY_TYPE);
      Sql_Mapper.Add_Mapping ("class/property/@name", FIELD_PROPERTY_NAME);
      Sql_Mapper.Add_Mapping ("query/@name", FIELD_QUERY_NAME);
      Sql_Mapper.Add_Mapping ("query/sql", FIELD_SQL);
      Sql_Mapper.Add_Mapping ("query/sql/@driver", FIELD_SQL_DRIVER);
      Sql_Mapper.Add_Mapping ("query/sql-count", FIELD_SQL_COUNT);
      Sql_Mapper.Add_Mapping ("query", FIELD_QUERY);
      Mapper.Add_Mapping ("query-mapping", Sql_Mapper'Unchecked_Access);

      --  Set the context for Set_Member.
      Query_Mapper.Set_Context (Mapper, Loader'Access);

      --  Read the XML query file.
      Reader.Parse (Path, Mapper);

      File.Next_Check := To_Unsigned_32 (Ada.Calendar.Clock) + FILE_CHECK_DELTA_TIME;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Log.Error ("XML query file '{0}' does not exist", Path);

   end Read_Query;

   --  ------------------------------
   --  Read the query definition.
   --  ------------------------------
   procedure Read_Query (Manager : in Query_Manager;
                         Into    : in Query_Definition_Access) is
   begin
      if Manager.Queries (Into.Query).Get.Is_Null or else Is_Modified (Manager.Files (Into.File.File)) then
         Read_Query (Manager, Manager.Files (Into.File.File));
      end if;
   end Read_Query;

   --  ------------------------------
   --  Initialize the queries to look in the list of directories specified by Paths.
   --  Each search directory is separated by ';' (yes, even on Unix).
   --  When Load is true, read the XML query file and initialize the query
   --  definitions from that file.
   --  ------------------------------
   procedure Initialize (Manager : in out Query_Manager;
                         Config  : in ADO.Drivers.Connections.Configuration'Class) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => String,
                                         Name   => Ada.Strings.Unbounded.String_Access);

      Paths : constant String := Config.Get_Property ("ado.queries.paths");
      Load  : constant Boolean := Config.Get_Property ("ado.queries.load") = "true";
      File : Query_File_Access := Query_Files;
      Pos  : Query_Index_Table := 1;
   begin
      Log.Info ("Initializing query search paths to {0}", Paths);

      if Manager.Queries = null then
         Manager.Queries := new Query_Table (1 .. Last_Query);
      end if;
      if Manager.Files = null then
         Manager.Files := new File_Table (1 .. Last_File);
      end if;
      Manager.Driver := Config.Get_Driver;
      while File /= null loop
         declare
            Path : constant String := Util.Files.Find_File_Path (Name  => File.Name.all,
                                                                 Paths => Paths);
            Query : Query_Definition_Access := File.Queries;
         begin
            Manager.Files (File.File).File := File;
            Manager.Files (File.File).Path := To_Unbounded_String (Path);

            if Load then
               Read_Query (Manager, Manager.Files (File.File));
            end if;
         end;
         File := File.Next;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Find the query identified by the given name.
   --  ------------------------------
   function Find_Query (Name : in String) return Query_Definition_Access is
      File : Query_File_Access := Query_Files;
   begin
      while File /= null loop
         declare
            Query : Query_Definition_Access := File.Queries;
         begin
            while Query /= null loop
               if Query.Name.all = Name then
                  return Query;
               end if;
               Query := Query.Next;
            end loop;
         end;
         File := File.Next;
      end loop;
      Log.Warn ("Query {0} not found", Name);
      return null;
   end Find_Query;

   package body File is
   begin
      File.Name := Name'Access;
      File.Sha1_Map := Hash'Access;
   end File;

   package body Query is
   begin
      Query.Name := Query_Name'Access;
      Query.Query := 0;
      Query.File  := File;
      Query.Next  := null;
      Register (File  => File, Query => Query'Access);
   end Query;

end ADO.Queries.Loaders;

Use a Unbounded_String to hold the file's path


-- t0047.adb - Sat Feb  1 16:15:50 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO, System;

with Posix;
use Posix;

procedure T0047 is
   use Ada.Text_IO;

   I, J, L :   int_t;
   K :         ushort_t;
   Ctl_Buf :   uchar_array(1..128);
   Ctl_Len :   uint64_t;
   Len :       Natural;
   Ctl_Level : int_t;
   Ctl_Type :  int_t;
   Offset :    uint64_t;
   Data_Len :  uint64_t;
   Accepted :  Boolean;
   Received :  Boolean;

   Fd1, Fd2 :  fd_t := -1;
   Fd3 :       fd_t := -1;
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0047 - Put/Get_Cmsg");

   I := 98;
   J := 95;
   K := 23;
   L := 29;

   -- Put control messages into Ctl_Buf
   Ctl_Len := 0;
   Put_Cmsg(Ctl_Buf,Ctl_Len,1,11,I'Address,I'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,2,12,J'Address,J'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,3,13,K'Address,K'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,4,14,L'Address,L'Size/8,Accepted);
   pragma Assert(Accepted);
   pragma Assert(Ctl_Len > 8);

   Put_Line("Ctl_Len =" & uint64_t'Image(Ctl_Len));

   I := 0;
   J := 0;
   K := 0;
   L := 0;

   -- Get control messages back from Ctl_Buf

   Offset := 0;
   Len := Natural(Ctl_Len);
   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 1);
   pragma Assert(Ctl_Type = 11);

   Data_Len := I'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,I'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= I'Size/8);
   pragma Assert(I = 98);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 2);
   pragma Assert(Ctl_Type = 12);

   Data_Len := J'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,J'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= J'Size/8);
   pragma Assert(J = 95);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 3);
   pragma Assert(Ctl_Type = 13);

   Data_Len := K'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,K'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= K'Size/8);
   pragma Assert(K = 23);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 4);
   pragma Assert(Ctl_Type = 14);

   Data_Len := L'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,L'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= L'Size/8);
   pragma Assert(L = 29);

   Put_Line("Offset =" & uint64_t'Image(Offset));
   pragma Assert(Offset = Ctl_Len);

   -- There should be no next message

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(not Received);

   -- This should faile due to small buffer size

   Ctl_Len := 0;
   Put_Cmsg(Ctl_Buf(1..12),Ctl_Len,1,11,I'Address,I'Size/8,Accepted);
   pragma Assert(not Accepted);

   -- Perform a networked test of the control message

   Socketpair(PF_LOCAL,SOCK_STREAM,0,Fd1,Fd2,Error);
   pragma Assert(Error = 0);
   pragma Assert(Fd1 >= 0);
   pragma Assert(Fd2 >= 0);

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child > 0 then
      -- Child process
      Close(Fd1,Error);
      pragma Assert(Error = 0);

      pragma Warnings(Off);
      Fd1 := -1;
      pragma Warnings(On);

      declare
         Data :   String(1..32);
         Iov :    s_iovec_array := (
                     0 => ( iov_base => Data'Address, iov_len => Data'Length )
                  );
         Msg :    s_msghdr;
      begin
         Msg.msg_name := System.Null_Address;
         Msg.msg_namelen := 0;
         Msg.msg_iov := Iov'Address;
         Msg.msg_iovlen := Iov'Length;
         Msg.msg_control := Ctl_Buf'Address;
         Msg.msg_controllen := Ctl_Buf'Length;
         Msg.msg_flags := 0;

         Recvmsg(Fd2,Msg,0,Error);
         pragma Assert(Error = 0);

         Offset := 0;
         Len := Natural(Msg.msg_controllen);
         Fd3 := -1;

Put_Line("Child: Read msg with controllen=" & Natural'Image(Len));

         loop
            Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
            exit when not Received;

Put_Line("Child: Read Level=" & int_t'Image(Ctl_Level) & ", Type=" & int_t'Image(Ctl_Type));

            case Ctl_Level is
               when SOL_SOCKET =>
Put_Line("Child: SOL_SOCKET");
                  case Ctl_Type is
                     when SCM_RIGHTS =>
Put_Line("Child: SCM_RIGHTS");
                        declare
                           Rights :    fd_array_t(1..8);
                           Fd_Count :  Natural := 0;
                        begin
                           Get_Cmsg(Ctl_Buf(1..Len),Offset,Rights,Fd_Count,Received);
                           pragma Assert(Error = 0);
Put_Line("Child: Count =" & Natural'Image(Fd_Count));
                           pragma Assert(Fd_Count = 1);

                           Fd3 := Rights(Rights'First);
Put_Line("Child: Fd3 =" & fd_t'Image(Fd3));
                        end;
                     when others =>
Put_Line("Child: SCM_OTHER");
                        null;
                  end case;
               when others =>
Put_Line("Child: LEV_OTHER");
                  null;
            end case;
         end loop;
      end;

      Close(Fd3,Error);
      pragma Assert(Error = 0);     -- Success proves Fd came over to child proc

      Close(Fd2,Error);
      pragma Assert(Error = 0);     -- Close socket
      return;
   end if;

   -- Parent process
   Close(Fd2,Error);
   pragma Assert(Error = 0);

   pragma Warnings(Off);
   Fd2 := -1;
   pragma Warnings(On);

   -- Send File Descriptor to Child process
   Open("Makefile",O_RDONLY,Fd3,Error);
   pragma Assert(Error = 0);
   pragma Assert(Fd3 >= 0);

   declare
      Fds : constant fd_array_t(1..1) := ( 1 => Fd3 );
   begin
      Ctl_Len := 0;
      Put_Cmsg(Ctl_Buf,Ctl_Len,Fds,Accepted);
      pragma Assert(Accepted);
      pragma Assert(Ctl_Len > 0);
   end;

   declare
      Byte :   String(1..1) := "X";
      Iov :    s_iovec_array := (
                  0 => ( iov_base => Byte'Address, iov_len => Byte'Length )
               );
      Msg :    s_msghdr;
   begin
      Msg.msg_name := System.Null_Address;
      Msg.msg_namelen := 0;
      Msg.msg_iov := Iov'Address;
      Msg.msg_iovlen := Iov'Length;
      Msg.msg_control := Ctl_Buf'Address;
#if POSIX_FAMILY = "Linux"
      Msg.msg_controllen := Ctl_Len;
#end if;
#if POSIX_FAMILY = "FreeBSD"
      Msg.msg_controllen := uint_t(Ctl_Len);
#end if;
#if POSIX_FAMILY = "Darwin"
      Msg.msg_controllen := uint_t(Ctl_Len);
#end if;
      Msg.msg_flags := 0;

      Sendmsg(Fd1,Msg,0,Error);
      pragma Assert(Error = 0);
Put_Line("Parent sent msg..");
   end;

   Shutdown(Fd1,SHUT_RD,Error);
   pragma Assert(Error = 0);
Put_Line("Parent SHUT_RD for " & fd_t'Image(Fd3));

   Close(Fd3,Error);
   pragma Assert(Error = 0);

   Close(Fd1,Error);
   pragma Assert(Error = 0);

   -- Wait for child process to exit
   declare
      Status : int_t := -1;
   begin
      Wait_Pid(Child,0,Status,Error);
      pragma Assert(WIFEXITED(Status));
      pragma Assert(WEXITSTATUS(Status) = 0);
Put_Line("Child" & pid_t'Image(Child) & " exited with rc=" & int_t'Image(WEXITSTATUS(Status)));
   end;

   Put_Line("Test 0047 Passed.");

end T0047;

-- t0047.adb - Sat Feb  1 16:15:50 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO, System;

with Posix;
use Posix;

procedure T0047 is
   use Ada.Text_IO;

   I, J, L :   int_t;
   K :         ushort_t;
   Ctl_Buf :   uchar_array(1..128);
   Ctl_Len :   uint64_t;
   Len :       Natural;
   Ctl_Level : int_t;
   Ctl_Type :  int_t;
   Offset :    uint64_t;
   Data_Len :  uint64_t;
   Accepted :  Boolean;
   Received :  Boolean;

   Fd1, Fd2 :  fd_t := -1;
   Fd3 :       fd_t := -1;
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0047 - Put/Get_Cmsg");

   I := 98;
   J := 95;
   K := 23;
   L := 29;

   -- Put control messages into Ctl_Buf
   Ctl_Len := 0;
   Put_Cmsg(Ctl_Buf,Ctl_Len,1,11,I'Address,I'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,2,12,J'Address,J'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,3,13,K'Address,K'Size/8,Accepted);
   pragma Assert(Accepted);
   Put_Cmsg(Ctl_Buf,Ctl_Len,4,14,L'Address,L'Size/8,Accepted);
   pragma Assert(Accepted);
   pragma Assert(Ctl_Len > 8);

   Put_Line("Ctl_Len =" & uint64_t'Image(Ctl_Len));

   I := 0;
   J := 0;
   K := 0;
   L := 0;

   -- Get control messages back from Ctl_Buf

   Offset := 0;
   Len := Natural(Ctl_Len);
   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 1);
   pragma Assert(Ctl_Type = 11);

   Data_Len := I'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,I'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= I'Size/8);
   pragma Assert(I = 98);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 2);
   pragma Assert(Ctl_Type = 12);

   Data_Len := J'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,J'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= J'Size/8);
   pragma Assert(J = 95);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 3);
   pragma Assert(Ctl_Type = 13);

   Data_Len := K'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,K'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= K'Size/8);
   pragma Assert(K = 23);

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(Received);
   pragma Assert(Ctl_Level = 4);
   pragma Assert(Ctl_Type = 14);

   Data_Len := L'Size/8;
   Get_Cmsg(Ctl_Buf(1..Len),Offset,L'Address,Data_Len,Received);
   pragma Assert(Received);
   pragma Assert(Data_Len >= L'Size/8);
   pragma Assert(L = 29);

   Put_Line("Offset =" & uint64_t'Image(Offset));
   pragma Assert(Offset = Ctl_Len);

   -- There should be no next message

   Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
   pragma Assert(not Received);

   -- This should faile due to small buffer size

   Ctl_Len := 0;
   Put_Cmsg(Ctl_Buf(1..12),Ctl_Len,1,11,I'Address,I'Size/8,Accepted);
   pragma Assert(not Accepted);

   -- Perform a networked test of the control message

   Socketpair(PF_LOCAL,SOCK_STREAM,0,Fd1,Fd2,Error);
   pragma Assert(Error = 0);
   pragma Assert(Fd1 >= 0);
   pragma Assert(Fd2 >= 0);

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child > 0 then
      -- Child process
      Close(Fd1,Error);
      pragma Assert(Error = 0);

      pragma Warnings(Off);
      Fd1 := -1;
      pragma Warnings(On);

      declare
         Data :   String(1..32);
         Iov :    s_iovec_array := (
                     0 => ( iov_base => Data'Address, iov_len => Data'Length )
                  );
         Msg :    s_msghdr;
      begin
         Msg.msg_name := System.Null_Address;
         Msg.msg_namelen := 0;
         Msg.msg_iov := Iov'Address;
         Msg.msg_iovlen := Iov'Length;
         Msg.msg_control := Ctl_Buf'Address;
         Msg.msg_controllen := Ctl_Buf'Length;
         Msg.msg_flags := 0;

         Recvmsg(Fd2,Msg,0,Error);
         pragma Assert(Error = 0);

         Offset := 0;
         Len := Natural(Msg.msg_controllen);
         Fd3 := -1;

         loop
            Get_Cmsg(Ctl_Buf(1..Len),Offset,Ctl_Level,Ctl_Type,Received);
            exit when not Received;

            case Ctl_Level is
               when SOL_SOCKET =>
                  case Ctl_Type is
                     when SCM_RIGHTS =>
                        declare
                           Rights :    fd_array_t(1..8);
                           Fd_Count :  Natural := 0;
                        begin
                           Get_Cmsg(Ctl_Buf(1..Len),Offset,Rights,Fd_Count,Received);
                           pragma Assert(Error = 0);
                           pragma Assert(Fd_Count = 1);

                           Fd3 := Rights(Rights'First);
                        end;
                     when others =>
                        null;
                  end case;
               when others =>
                  null;
            end case;
         end loop;
      end;

      Close(Fd3,Error);
      pragma Assert(Error = 0);     -- Success proves Fd came over to child proc

      Close(Fd2,Error);
      pragma Assert(Error = 0);     -- Close socket
      return;
   end if;

   -- Parent process
   Close(Fd2,Error);
   pragma Assert(Error = 0);

   pragma Warnings(Off);
   Fd2 := -1;
   pragma Warnings(On);

   -- Send File Descriptor to Child process
   Open("Makefile",O_RDONLY,Fd3,Error);
   pragma Assert(Error = 0);
   pragma Assert(Fd3 >= 0);

   declare
      Fds : constant fd_array_t(1..1) := ( 1 => Fd3 );
   begin
      Ctl_Len := 0;
      Put_Cmsg(Ctl_Buf,Ctl_Len,Fds,Accepted);
      pragma Assert(Accepted);
      pragma Assert(Ctl_Len > 0);
   end;

   declare
      Byte :   String(1..1) := "X";
      Iov :    s_iovec_array := (
                  0 => ( iov_base => Byte'Address, iov_len => Byte'Length )
               );
      Msg :    s_msghdr;
   begin
      Msg.msg_name := System.Null_Address;
      Msg.msg_namelen := 0;
      Msg.msg_iov := Iov'Address;
      Msg.msg_iovlen := Iov'Length;
      Msg.msg_control := Ctl_Buf'Address;
#if POSIX_FAMILY = "Linux"
      Msg.msg_controllen := Ctl_Len;
#end if;
#if POSIX_FAMILY = "FreeBSD"
      Msg.msg_controllen := uint_t(Ctl_Len);
#end if;
#if POSIX_FAMILY = "Darwin"
      Msg.msg_controllen := uint_t(Ctl_Len);
#end if;
      Msg.msg_flags := 0;

      Sendmsg(Fd1,Msg,0,Error);
      pragma Assert(Error = 0);
   end;

   Shutdown(Fd1,SHUT_RD,Error);
   pragma Assert(Error = 0);

   Close(Fd3,Error);
   pragma Assert(Error = 0);

   Close(Fd1,Error);
   pragma Assert(Error = 0);

   -- Wait for child process to exit
   declare
      Status : int_t := -1;
   begin
      Wait_Pid(Child,0,Status,Error);
      pragma Assert(WIFEXITED(Status));
      pragma Assert(WEXITSTATUS(Status) = 0);
   end;

   Put_Line("Test 0047 Passed.");

end T0047;

Test 47 finalized and cleaned up

Test 47 finalized and cleaned up


-- t0048.adb - Thu Feb 20 16:54:37 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO;

with Posix;
use Posix;

with System;
use System;

procedure T0048 is
   use Ada.Text_IO;

   Connect_Addr : constant String := "127.0.0.1";

   Inet_C_Addr :  s_sockaddr_in;
   Port_C_No :    constant ushort_t := 19199;

   S, L :      fd_t := -1;       -- Connecting socket
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0048 - IPv4 socket/connect/etc.");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child /= 0 then
      -- Parent process

      -- Create socket:
      Socket(PF_INET,SOCK_STREAM,0,S,Error);
      pragma Assert(Error = 0);
      pragma Assert(S >= 0);

      -- Create address to connect with:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Test Inet_Ntop -- should return same IPv4 String
      declare
         Str_Addr :  String(1..300);
         Last :      Natural := 0;
      begin
         Inet_Ntop(Inet_C_Addr.sin_addr,Str_Addr,Last,Error);
         pragma Assert(Error = 0);
         pragma Assert(Str_Addr(1..Last) = Connect_Addr);
      end;

      -- Test port
      declare
         Test_Port : constant ushort_t := Ntohs(Inet_C_Addr.sin_port);
      begin
         pragma Assert(Test_Port = Port_C_No);
         null;
      end;

      -- Wait for client to setup and listen
      Sleep(2);

      -- Connect to the client process
      Connect(S,Inet_C_Addr,Error);
      pragma Assert(Error = 0);

      -- Write something
      declare
         Msg :    constant uchar_array := To_uchar_array("Hello!");
         Count :  Natural;
      begin
         Write(S,uchar_array(Msg),Count,Error);
         pragma Assert(Error = 0);
         pragma Assert(Count = Msg'Length);
      end;

      -- Close the socket
      Close(S,Error);
      pragma Assert(Error = 0);

      -- Wait for child process to exit
      declare
         Status : int_t := -1;
      begin
         Wait_Pid(Child,0,Status,Error);
         pragma Assert(WIFEXITED(Status));
         pragma Assert(WEXITSTATUS(Status) = 0);
      end;

      Put_Line("Test 0048 Passed.");
   else
      -- Child process

      -- Create a listening socket:
      Socket(PF_INET,SOCK_STREAM,0,L,Error);
      pragma Assert(Error = 0);
      pragma Assert(L >= 0);

      -- Create the address to bind to:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Bind to the address:
      Bind(L,Inet_C_Addr,Error);
      pragma Assert(Error = 0);

      loop
         Listen(L,10,Error);
         exit when Error = 0;
         pragma Assert(Error = EINTR);
      end loop;

      -- Accept one connect
      declare
         Peer :      u_sockaddr;
         Peer_Len :  socklen_t;
      begin
         loop
            Accept_Connect(L,Peer,Peer_Len,S,Error);
            exit when Error = 0;
            pragma Assert(Error = EINTR);
         end loop;

         pragma Assert(S >= 0);
         pragma Assert(Peer.addr_sock.sa_family = AF_INET);

         -- Display local socket address
         declare
            Local_Addr :   u_sockaddr;
            Addr_Len :     socklen_t;
            Str_Addr :     String(1..300);
            Last :         Natural := 0;
         begin
            Getsockname(S,Local_Addr,Addr_Len,Error);
            pragma Assert(Error = 0);
            pragma Assert(Local_Addr.addr_sock.sa_family = AF_INET);
            Inet_Ntop(Local_Addr.addr_in.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);
            Put_Line("Local name is " & Str_Addr(1..Last) & ":" & ushort_t'Image(Ntohs(Local_Addr.addr_in.sin_port)));
         end;

         -- Display peer's address
         declare
            Str_Addr :  String(1..300);
            Last :      Natural := 0;
            Port :      constant ushort_t := Ntohs(Peer.addr_in.sin_port);
         begin
            Inet_Ntop(Peer.addr_in.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);

            Put_Line("Received connect from " & Str_Addr(1..Last) & ":" & ushort_t'Image(Port));

            -- Test Getpeername
            declare
               Peer_Name : u_sockaddr;
               Name_Len :  socklen_t;
               Buf2 :      String(1..300);
               Last2 :     Natural := 0;
            begin
               Getpeername(S,Peer_Name,Name_Len,Error);
               pragma Assert(Error = 0);
               pragma Assert(Peer_Name.addr_sock.sa_family = AF_INET);
               Inet_Ntop(Peer_Name.addr_in.sin_addr,Buf2,Last2,Error);
               pragma Assert(Error = 0);
               pragma Assert(Buf2(1..Last2) = Str_Addr(1..Last));

               Put_Line("Peer name is " & Str_Addr(1..Last) & ":" & ushort_t'Image(Ntohs(Peer_Name.addr_in.sin_port)));
            end;
         end;
      end;

#if POSIX_FAMILY = "FreeBSD" or POSIX_FAMILY = "Darwin"

      -- Test KQueue
      declare
         Kq :        fd_t;
         Chgs :      s_kevent_array(1..1);
         Evts :      s_kevent_array(1..1);
         N_Evts :    Natural := 0;
         Timeout :   constant s_timespec := ( tv_sec => 1, tv_nsec => 0 );
      begin
         KQueue(Kq,Error);
         pragma Assert(Kq >= 0);

         Chgs(1).ident := uint64_t(S);
         Chgs(1).filter := EVFILT_READ;
         Chgs(1).flags := EV_ADD;
         Chgs(1).fflags := 0;
         Chgs(1).udata := Null_Address;

         loop
            KEvent(Kq,Chgs,1,Timeout,Evts,N_Evts,Error);
            pragma assert(Error = 0);

            exit when N_Evts > 0;
         end loop;

         pragma Assert(N_Evts > 0);
         pragma Assert(Evts(1).ident = uint64_t(S));
         pragma Assert(Evts(1).filter = EVFILT_READ);
         pragma Assert(Evts(1).data > 0);
         pragma Assert(Evts(1).udata = Null_Address);

         declare
            Rx_Avail :  constant Natural := Natural(Evts(1).data);
            Rx_Buf :    uchar_array(1..Rx_Avail);
            Last :      Natural;
         begin
            Read(S,Rx_Buf,Last,Error);
            pragma Assert(Error = 0);
            pragma Assert(Last = Rx_Avail);

            Put("Got msg '");
            Put(To_String(Rx_Buf(1..Last)));
            Put_Line("'");
         end;

         Close(Kq,Error);
         pragma Assert(Error = 0);
      end;

#end if;

      -- Close listening socket
      Close(L,Error);
      pragma Assert(Error = 0);

      -- Test getsockopt(2)
      declare
         Sock_Error : int_t := -33;
         Keep_Alive : int_t := -33;
      begin
         Get_Sockopt(S,SOL_SOCKET,SO_ERROR,Sock_Error,Error);
         pragma Assert(Error = 0);
         pragma Assert(Sock_Error = 0);

         Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
         pragma Assert(Error = 0);
         pragma Assert(Keep_Alive >= 0);

         if Keep_Alive /= 0 then
            Keep_Alive := 0;        -- Turn it off
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive = 0);
         else
            Keep_Alive := 1;        -- Turn it on
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive /= 0);
         end if;
      end;

      declare
         Linger : s_linger := ( l_onoff => 1, l_linger => 2 );
      begin
         Set_Sockopt(S,SOL_SOCKET,SO_LINGER,Linger,Error);
         pragma Assert(Error = 0);

         Linger.l_onoff := 0;
         Linger.l_linger := 23;
         Get_Sockopt(S,SOL_SOCKET,SO_LINGER,Linger,Error);
         pragma Assert(Error = 0);
         pragma Assert(Linger.l_onoff /= 0);
         pragma Assert(Linger.l_linger = 2);
      end;

      -- Close accepted socket
      Close(S,Error);
      pragma Assert(Error = 0);

   end if;

end T0048;

-- t0048.adb - Thu Feb 20 16:54:37 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- $Id$
--
-- Protected under the GNU GENERAL PUBLIC LICENSE v2, June 1991

with Ada.Text_IO;

with Posix;
use Posix;

with System;
use System;

procedure T0048 is
   use Ada.Text_IO;

   Connect_Addr : constant String := "127.0.0.1";

   Inet_C_Addr :  s_sockaddr_in;
   Port_C_No :    constant ushort_t := 19199;

   S, L :      fd_t := -1;       -- Connecting socket
   Child :     pid_t := -1;
   Error :     errno_t;
begin

   Put_Line("Test 0048 - IPv4 socket/connect/etc.");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child /= 0 then
      -- Parent process

      -- Create socket:
      Socket(PF_INET,SOCK_STREAM,0,S,Error);
      pragma Assert(Error = 0);
      pragma Assert(S >= 0);

      -- Create address to connect with:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Test Inet_Ntop -- should return same IPv4 String
      declare
         Str_Addr :  String(1..300);
         Last :      Natural := 0;
      begin
         Inet_Ntop(Inet_C_Addr.sin_addr,Str_Addr,Last,Error);
         pragma Assert(Error = 0);
         pragma Assert(Str_Addr(1..Last) = Connect_Addr);
      end;

      -- Test port
      declare
         Test_Port : constant ushort_t := Ntohs(Inet_C_Addr.sin_port);
      begin
         pragma Assert(Test_Port = Port_C_No);
         null;
      end;

      -- Wait for client to setup and listen
      Sleep(2);

      -- Connect to the client process
      Connect(S,Inet_C_Addr,Error);
      pragma Assert(Error = 0);

      -- Write something
      declare
         Msg :    constant uchar_array := To_uchar_array("Hello!");
         Count :  Natural;
      begin
         Write(S,uchar_array(Msg),Count,Error);
         pragma Assert(Error = 0);
         pragma Assert(Count = Msg'Length);
      end;

      -- Test Shutdown(2)
      Shutdown(S,SHUT_RD,Error);
      pragma Assert(Error = 0);

      -- Close the socket
      Close(S,Error);
      pragma Assert(Error = 0);

      -- Wait for child process to exit
      declare
         Status : int_t := -1;
      begin
         Wait_Pid(Child,0,Status,Error);
         pragma Assert(WIFEXITED(Status));
         pragma Assert(WEXITSTATUS(Status) = 0);
      end;

      Put_Line("Test 0048 Passed.");
   else
      -- Child process

      -- Create a listening socket:
      Socket(PF_INET,SOCK_STREAM,0,L,Error);
      pragma Assert(Error = 0);
      pragma Assert(L >= 0);

      -- Create the address to bind to:
      Inet_C_Addr.sin_family := AF_INET;
      Inet_C_Addr.sin_port   := Htons(Port_C_No);
      Inet_Aton(Connect_Addr,Inet_C_Addr.sin_addr,Error);
      pragma Assert(Error = 0);

      -- Bind to the address:
      Bind(L,Inet_C_Addr,Error);
      pragma Assert(Error = 0);

      loop
         Listen(L,10,Error);
         exit when Error = 0;
         pragma Assert(Error = EINTR);
      end loop;

      -- Accept one connect
      declare
         Peer :      u_sockaddr;
         Peer_Len :  socklen_t;
      begin
         loop
            Accept_Connect(L,Peer,Peer_Len,S,Error);
            exit when Error = 0;
            pragma Assert(Error = EINTR);
         end loop;

         pragma Assert(S >= 0);
         pragma Assert(Peer.addr_sock.sa_family = AF_INET);

         -- Display local socket address
         declare
            Local_Addr :   u_sockaddr;
            Addr_Len :     socklen_t;
            Str_Addr :     String(1..300);
            Last :         Natural := 0;
         begin
            Getsockname(S,Local_Addr,Addr_Len,Error);
            pragma Assert(Error = 0);
            pragma Assert(Local_Addr.addr_sock.sa_family = AF_INET);
            Inet_Ntop(Local_Addr.addr_in.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);
            Put_Line("Local name is " & Str_Addr(1..Last) & ":" & ushort_t'Image(Ntohs(Local_Addr.addr_in.sin_port)));
         end;

         -- Display peer's address
         declare
            Str_Addr :  String(1..300);
            Last :      Natural := 0;
            Port :      constant ushort_t := Ntohs(Peer.addr_in.sin_port);
         begin
            Inet_Ntop(Peer.addr_in.sin_addr,Str_Addr,Last,Error);
            pragma Assert(Error = 0);

            Put_Line("Received connect from " & Str_Addr(1..Last) & ":" & ushort_t'Image(Port));

            -- Test Getpeername
            declare
               Peer_Name : u_sockaddr;
               Name_Len :  socklen_t;
               Buf2 :      String(1..300);
               Last2 :     Natural := 0;
            begin
               Getpeername(S,Peer_Name,Name_Len,Error);
               pragma Assert(Error = 0);
               pragma Assert(Peer_Name.addr_sock.sa_family = AF_INET);
               Inet_Ntop(Peer_Name.addr_in.sin_addr,Buf2,Last2,Error);
               pragma Assert(Error = 0);
               pragma Assert(Buf2(1..Last2) = Str_Addr(1..Last));

               Put_Line("Peer name is " & Str_Addr(1..Last) & ":" & ushort_t'Image(Ntohs(Peer_Name.addr_in.sin_port)));
            end;
         end;
      end;

#if POSIX_FAMILY = "FreeBSD" or POSIX_FAMILY = "Darwin"

      -- Test KQueue
      declare
         Kq :        fd_t;
         Chgs :      s_kevent_array(1..1);
         Evts :      s_kevent_array(1..1);
         N_Evts :    Natural := 0;
         Timeout :   constant s_timespec := ( tv_sec => 1, tv_nsec => 0 );
      begin
         KQueue(Kq,Error);
         pragma Assert(Kq >= 0);

         Chgs(1).ident := uint64_t(S);
         Chgs(1).filter := EVFILT_READ;
         Chgs(1).flags := EV_ADD;
         Chgs(1).fflags := 0;
         Chgs(1).udata := Null_Address;

         loop
            KEvent(Kq,Chgs,1,Timeout,Evts,N_Evts,Error);
            pragma assert(Error = 0);

            exit when N_Evts > 0;
         end loop;

         pragma Assert(N_Evts > 0);
         pragma Assert(Evts(1).ident = uint64_t(S));
         pragma Assert(Evts(1).filter = EVFILT_READ);
         pragma Assert(Evts(1).data > 0);
         pragma Assert(Evts(1).udata = Null_Address);

         declare
            Rx_Avail :  constant Natural := Natural(Evts(1).data);
            Rx_Buf :    uchar_array(1..Rx_Avail);
            Last :      Natural;
         begin
            Read(S,Rx_Buf,Last,Error);
            pragma Assert(Error = 0);
            pragma Assert(Last = Rx_Avail);

            Put("Got msg '");
            Put(To_String(Rx_Buf(1..Last)));
            Put_Line("'");
         end;

         Close(Kq,Error);
         pragma Assert(Error = 0);
      end;

#end if;

      -- Close listening socket
      Close(L,Error);
      pragma Assert(Error = 0);

      -- Test getsockopt(2)
      declare
         Sock_Error : int_t := -33;
         Keep_Alive : int_t := -33;
      begin
         Get_Sockopt(S,SOL_SOCKET,SO_ERROR,Sock_Error,Error);
         pragma Assert(Error = 0);
         pragma Assert(Sock_Error = 0);

         Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
         pragma Assert(Error = 0);
         pragma Assert(Keep_Alive >= 0);

         if Keep_Alive /= 0 then
            Keep_Alive := 0;        -- Turn it off
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive = 0);
         else
            Keep_Alive := 1;        -- Turn it on
            Set_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);

            Keep_Alive := -95;
            Get_Sockopt(S,SOL_SOCKET,SO_KEEPALIVE,Keep_Alive,Error);
            pragma Assert(Error = 0);
            pragma Assert(Keep_Alive /= 0);
         end if;
      end;

      declare
         Linger : s_linger := ( l_onoff => 1, l_linger => 2 );
      begin
         Set_Sockopt(S,SOL_SOCKET,SO_LINGER,Linger,Error);
         pragma Assert(Error = 0);

         Linger.l_onoff := 0;
         Linger.l_linger := 23;
         Get_Sockopt(S,SOL_SOCKET,SO_LINGER,Linger,Error);
         pragma Assert(Error = 0);
         pragma Assert(Linger.l_onoff /= 0);
         pragma Assert(Linger.l_linger = 2);
      end;

      -- Close accepted socket
      Close(S,Error);
      pragma Assert(Error = 0);

   end if;

end T0048;

Test Shutdown()

Test Shutdown()


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

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
with ASF.Applications.Views;
package ASF.Lifecycles.Response is

   --  ------------------------------
   --  Response controller
   --  ------------------------------
   type Response_Controller is new Phase_Controller with private;

   --  Initialize the phase controller.
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         App        : access ASF.Applications.Main.Application'Class);

   --  Execute the restore view phase.
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class);

private

   type Response_Controller is new Phase_Controller with record
      View_Handler : access ASF.Applications.Views.View_Handler'Class;
   end record;

end ASF.Lifecycles.Response;

-----------------------------------------------------------------------
--  asf-lifecycles-response -- Response phase
--  Copyright (C) 2010, 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.
-----------------------------------------------------------------------

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
with ASF.Applications.Views;
package ASF.Lifecycles.Response is

   --  ------------------------------
   --  Response controller
   --  ------------------------------
   type Response_Controller is new Phase_Controller with private;

   --  Initialize the phase controller.
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class);

   --  Execute the restore view phase.
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class);

private

   type Response_Controller is new Phase_Controller with record
      View_Handler : access ASF.Applications.Views.View_Handler'Class;
   end record;

end ASF.Lifecycles.Response;

Update Initialize to use a ASF.Applications.Views.View_Handler'Class


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

with Ada.Streams;

generic
   type Dictionary_Code is (<>);

   with procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Dictionary_Code;
      Verbatim_Length : out Natural;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean);

   with procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String);

   with procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive);

   with function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count;

   with procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Dictionary_Code);

   with procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean);

package Natools.Smaz_Generic is
   pragma Pure;

   type Offset_Array is array (Dictionary_Code range <>) of Positive;

   type Dictionary
     (Last_Code : Dictionary_Code;
      Values_Last : Natural)
   is record
      Variable_Length_Verbatim : Boolean;
      Max_Word_Length : Positive;
      Offsets : Offset_Array
        (Dictionary_Code'Succ (Dictionary_Code'First) .. Last_Code);
      Values : String (1 .. Values_Last);
      Hash : not null access function (Value : String) return Natural;
   end record;

   function Code_First
     (Offsets : in Offset_Array;
      Code : in Dictionary_Code;
      Fallback : in Positive)
     return Positive
     is (if Code in Offsets'Range then Offsets (Code) else Fallback);
      --  Return the first index of the value for Code in Dictionary.Values

   function Code_Last
     (Offsets : in Offset_Array;
      Code : in Dictionary_Code;
      Fallback : in Natural)
     return Natural
     is (if Dictionary_Code'Succ (Code) in Offsets'Range
         then Offsets (Dictionary_Code'Succ (Code)) - 1
         else Fallback);
      --  Return the value index of the value for Code in Dictionary.Values

   function Is_Valid_Code
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return Boolean
     is (Code in Dictionary_Code'First .. Dict.Last_Code);
      --  Return whether Code exists in Dict

   function Dict_Entry
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return String
     is (Dict.Values (Code_First (Dict.Offsets, Code, Dict.Values'First)
                    .. Code_Last (Dict.Offsets, Code, Dict.Values'Last)))
     with Pre => Is_Valid_Code (Dict, Code);
      --  Return the string for at the given Index in Dict

   function Dict_Entry_Length
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return Positive
     is (1 + Code_Last (Dict.Offsets, Code, Dict.Values'Last)
           - Code_First (Dict.Offsets, Code, Dict.Values'First))
     with Pre => Is_Valid_Code (Dict, Code);
      --  Return the length of the string for at the given Index in Dict

   function Is_Valid (Dictionary : in Smaz_Generic.Dictionary) return Boolean
     is ((for all Code in Dictionary.Offsets'Range
            => Dictionary.Offsets (Code) in Dictionary.Values'Range)
        and then (for all Code in Dictionary_Code'First .. Dictionary.Last_Code
            => Code_Last (Dictionary.Offsets, Code, Dictionary.Values'Last) + 1
               - Code_First (Dictionary.Offsets, Code, Dictionary.Values'First)
               in 1 .. Dictionary.Max_Word_Length)
        and then (for all Code in Dictionary_Code'First .. Dictionary.Last_Code
            => Dictionary_Code'Val (Dictionary.Hash
                                      (Dict_Entry (Dictionary, Code)))
               = Code));
      --  Check all the assumptions made on Dictionary objects.

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count;
      --  Return the maximum number of bytes needed to encode Input

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset);
      --  Encode Input into Output_Buffer

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array;
      --  Return an encoded buffer for Input

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural;
      --  Return the exact length when Input is decoded

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural);
      --  Decode Input into Output_Buffer

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String;
      --  Return a decoded buffer for Input

end Natools.Smaz_Generic;

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

------------------------------------------------------------------------------
-- Natools.Smaz_Generic provides a generic implementation of the Smaz       --
-- algorithm, leaving encoding and decoding to the formal subprograms.      --
-- This factors all the logic common to standard byte-based Smaz, the       --
-- the base-64 variant, and the base-4096 variant.                          --
--                                                                          --
-- WARNING: an important assumption that is not checked/asserted, is that   --
-- it is never preferable to use verbatim encoding rather than a code,      --
-- except when merging to verbatim sections and the code between them. This --
-- means in particular that a dictionary must never contain an entry        --
-- shorter than its encoded counterpart.                                    --
------------------------------------------------------------------------------

with Ada.Streams;

generic
   type Dictionary_Code is (<>);

   with procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Dictionary_Code;
      Verbatim_Length : out Natural;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean);

   with procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String);

   with procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive);

   with function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count;

   with procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Dictionary_Code);

   with procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Dictionary_Code;
      Variable_Length_Verbatim : in Boolean);

package Natools.Smaz_Generic is
   pragma Pure;

   type Offset_Array is array (Dictionary_Code range <>) of Positive;

   type Dictionary
     (Last_Code : Dictionary_Code;
      Values_Last : Natural)
   is record
      Variable_Length_Verbatim : Boolean;
      Max_Word_Length : Positive;
      Offsets : Offset_Array
        (Dictionary_Code'Succ (Dictionary_Code'First) .. Last_Code);
      Values : String (1 .. Values_Last);
      Hash : not null access function (Value : String) return Natural;
   end record;

   function Code_First
     (Offsets : in Offset_Array;
      Code : in Dictionary_Code;
      Fallback : in Positive)
     return Positive
     is (if Code in Offsets'Range then Offsets (Code) else Fallback);
      --  Return the first index of the value for Code in Dictionary.Values

   function Code_Last
     (Offsets : in Offset_Array;
      Code : in Dictionary_Code;
      Fallback : in Natural)
     return Natural
     is (if Dictionary_Code'Succ (Code) in Offsets'Range
         then Offsets (Dictionary_Code'Succ (Code)) - 1
         else Fallback);
      --  Return the value index of the value for Code in Dictionary.Values

   function Is_Valid_Code
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return Boolean
     is (Code in Dictionary_Code'First .. Dict.Last_Code);
      --  Return whether Code exists in Dict

   function Dict_Entry
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return String
     is (Dict.Values (Code_First (Dict.Offsets, Code, Dict.Values'First)
                    .. Code_Last (Dict.Offsets, Code, Dict.Values'Last)))
     with Pre => Is_Valid_Code (Dict, Code);
      --  Return the string for at the given Index in Dict

   function Dict_Entry_Length
     (Dict : in Dictionary;
      Code : in Dictionary_Code)
     return Positive
     is (1 + Code_Last (Dict.Offsets, Code, Dict.Values'Last)
           - Code_First (Dict.Offsets, Code, Dict.Values'First))
     with Pre => Is_Valid_Code (Dict, Code);
      --  Return the length of the string for at the given Index in Dict

   function Is_Valid (Dictionary : in Smaz_Generic.Dictionary) return Boolean
     is ((for all Code in Dictionary.Offsets'Range
            => Dictionary.Offsets (Code) in Dictionary.Values'Range)
        and then (for all Code in Dictionary_Code'First .. Dictionary.Last_Code
            => Code_Last (Dictionary.Offsets, Code, Dictionary.Values'Last) + 1
               - Code_First (Dictionary.Offsets, Code, Dictionary.Values'First)
               in 1 .. Dictionary.Max_Word_Length)
        and then (for all Code in Dictionary_Code'First .. Dictionary.Last_Code
            => Dictionary_Code'Val (Dictionary.Hash
                                      (Dict_Entry (Dictionary, Code)))
               = Code));
      --  Check all the assumptions made on Dictionary objects.

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count;
      --  Return the maximum number of bytes needed to encode Input

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset);
      --  Encode Input into Output_Buffer

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array;
      --  Return an encoded buffer for Input

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural;
      --  Return the exact length when Input is decoded

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural);
      --  Decode Input into Output_Buffer

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String;
      --  Return a decoded buffer for Input

end Natools.Smaz_Generic;

smaz_generic: add a description and an important warning


-----------------------------------------------------------------------
--  pipe -- Print the GNAT version by using a pipe
--  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 Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
procedure Popen is

   Command : constant String := "gnatmake --version";

   Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   Buffer  : Util.Streams.Buffered.Input_Buffer_Stream;
   Content : Ada.Strings.Unbounded.Unbounded_String;
begin
   Pipe.Open (Command, Util.Processes.READ);
   Buffer.Initialize (Pipe'Unchecked_Access, 1024);
   Buffer.Read (Content);
   Pipe.Close;

   if Pipe.Get_Exit_Status /= 0 then
      Ada.Text_IO.Put_Line (Command & " exited with status "
                            & Integer'Image (Pipe.Get_Exit_Status));
      return;
   end if;

   Ada.Text_IO.Put_Line ("Result: " & Ada.Strings.Unbounded.To_String (Content));
end Popen;

-----------------------------------------------------------------------
--  pipe -- Print the GNAT version by using a pipe
--  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 Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
procedure Popen is

   Command : constant String := "gnatmake --version";

   Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   Buffer  : Util.Streams.Buffered.Input_Buffer_Stream;
   Content : Ada.Strings.Unbounded.Unbounded_String;
begin
   Pipe.Open (Command, Util.Processes.READ);
   Buffer.Initialize (Pipe'Access, 1024);
   Buffer.Read (Content);
   Pipe.Close;

   if Pipe.Get_Exit_Status /= 0 then
      Ada.Text_IO.Put_Line (Command & " exited with status "
                            & Integer'Image (Pipe.Get_Exit_Status));
      return;
   end if;

   Ada.Text_IO.Put_Line ("Result: " & Ada.Strings.Unbounded.To_String (Content));
end Popen;

Replace Unchecked_Access by Access in stream initialization