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

with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Targets.Probes");

   MSG_BEGIN     : constant MAT.Events.Targets.Probe_Index_Type := 0;
   MSG_END       : constant MAT.Events.Targets.Probe_Index_Type := 1;

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Id          : in MAT.Events.Targets.Probe_Index_Type;
                          Defs        : in MAT.Events.Attribute_Table;
                          Msg         : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size       := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path       := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MSG_BEGIN then
         Probe.Probe_Begin (Event.Index, Params.all, Msg);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MSG_END,
                           Process_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

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

with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Targets.Probes");

   MSG_BEGIN     : constant MAT.Events.Targets.Probe_Index_Type := 0;
   MSG_END       : constant MAT.Events.Targets.Probe_Index_Type := 1;
   MSG_LIBRARY   : constant MAT.Events.Targets.Probe_Index_Type := 2;

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Id          : in MAT.Events.Targets.Probe_Index_Type;
                          Defs        : in MAT.Events.Attribute_Table;
                          Msg         : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size       := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path       := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MSG_BEGIN then
         Probe.Probe_Begin (Event.Index, Params.all, Msg);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

Declare the Library_Attributes array with the description of shared library event Register the Library_Attributes instance


-----------------------------------------------------------------------
--  ado-datasets-tests -- Test executing queries and using datasets
--  Copyright (C) 2013, 2014, 2015, 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 Util.Test_Caller;
with Util.Properties;

with Regtests.Simple.Model;
with Regtests.Statements.Model;

with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

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

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   package User_List_Count_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list-count",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (from <sql>)",
                       Test_List'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql>)",
                       Test_Count'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql-count>)",
                       Test_Count_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (<sql> with null)",
                       Test_List_Nullable'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
      Props  : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List;

   --  ------------------------------
   --  Test dataset lists with null columns.
   --  ------------------------------
   procedure Test_List_Nullable (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_SQL ("SELECT COUNT(*) FROM test_nullable_table");
      Count := ADO.Datasets.Get_Count (DB, Query);

      for I in 1 .. 100 loop
         declare
            Item : Regtests.Statements.Model.Nullable_Table_Ref;
         begin
            Item.Set_Bool_Value (False);
            if (I mod 2) = 0 then
               Item.Set_Int_Value (ADO.Nullable_Integer '(123, False));
            end if;
            if (I mod 4) = 0 then
               Item.Set_Time_Value (ADO.Nullable_Time '(Value => Ada.Calendar.Clock,
                                                        Is_Null => False));
            end if;
            Item.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_SQL ("SELECT * FROM test_nullable_table");
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List_Nullable;

   procedure Test_Count (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Props  : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      Query.Set_Query (User_List_Count_Query.Query'Access);
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count;

   procedure Test_Count_Query (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Props  : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count_Query;

end ADO.Datasets.Tests;

-----------------------------------------------------------------------
--  ado-datasets-tests -- Test executing queries and using datasets
--  Copyright (C) 2013, 2014, 2015, 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 Util.Test_Caller;

with Regtests.Simple.Model;
with Regtests.Statements.Model;

with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

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

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   package User_List_Count_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list-count",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (from <sql>)",
                       Test_List'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql>)",
                       Test_Count'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql-count>)",
                       Test_Count_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (<sql> with null)",
                       Test_List_Nullable'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List;

   --  ------------------------------
   --  Test dataset lists with null columns.
   --  ------------------------------
   procedure Test_List_Nullable (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_SQL ("SELECT COUNT(*) FROM test_nullable_table");
      Count := ADO.Datasets.Get_Count (DB, Query);

      for I in 1 .. 100 loop
         declare
            Item : Regtests.Statements.Model.Nullable_Table_Ref;
         begin
            Item.Set_Bool_Value (False);
            if (I mod 2) = 0 then
               Item.Set_Int_Value (ADO.Nullable_Integer '(123, False));
            end if;
            if (I mod 4) = 0 then
               Item.Set_Time_Value (ADO.Nullable_Time '(Value => Ada.Calendar.Clock,
                                                        Is_Null => False));
            end if;
            Item.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_SQL ("SELECT * FROM test_nullable_table");
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List_Nullable;

   procedure Test_Count (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Query (User_List_Count_Query.Query'Access);
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count;

   procedure Test_Count_Query (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count_Query;

end ADO.Datasets.Tests;

Remove unused Properties

Remove unused Properties


-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");
   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", " 42");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", " 43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "Joe is#{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
   end Test_Parse_Error;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));

   end Add_Tests;

end EL.Expressions.Tests;

-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");

      declare
         E2 : constant Expression := E.Reduce_Expression (Context => T.Context);
         V2 : constant Object := E2.Get_Value (Context => T.Context);
      begin
         Assert (To_String (V2) = Expect,
                 "Reduce produced incorrect result: " & To_String (V2));
      end;

   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", " 42");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", " 43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "Joe is#{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
   end Test_Parse_Error;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));

   end Add_Tests;

end EL.Expressions.Tests;

Add unit test for Reduce_Expression

Add unit test for Reduce_Expression


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

with MAT.Readers.Marshaller;
package body MAT.Readers.Streams.Sockets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Sockets");

   BUFFER_SIZE  : constant Natural := 100 * 1024;
   MAX_MSG_SIZE : constant Ada.Streams.Stream_Element_Offset := 2048;

   task body Socket_Listener_Task is
      use type GNAT.Sockets.Socket_Type;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
      Status   : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (S : in Socket_Reader_Type_Access;
                       Address : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := S;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      while not Instance.Stop loop
         GNAT.Sockets.Accept_Socket (Server, Socket, Peer, 1.0, null, Status);
         if Socket /= GNAT.Sockets.No_Socket then
            Instance.Socket.Open (Socket);
            Instance.Read_All;
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);
   end Socket_Listener_Task;

   task body Socket_Reader_Task is
      use type GNAT.Sockets.Socket_Type;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
      Status   : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (S : in Socket_Reader_Type_Access;
                       Address : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := S;
            --              Address.Addr := GNAT.Sockets.Addresses (Get_Host_By_Name (S.Get_Host), 1);
--              Address.Addr := GNAT.Sockets.Any_Inet_Addr;
--              Address.Port := 4096;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
--              Address := GNAT.Sockets.Get_Socket_Name (Server);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      while not Instance.Stop loop
         GNAT.Sockets.Accept_Socket (Server, Socket, Peer, 1.0, null, Status);
         if Socket /= GNAT.Sockets.No_Socket then
            Instance.Socket.Open (Socket);
            Instance.Read_All;
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);

   exception
      when E : others =>
         Log.Error ("Exception", E);

   end Socket_Reader_Task;

   --  Open the socket to accept connections.
   procedure Open (Reader  : in out Socket_Reader_Type;
                   Address : in GNAT.Sockets.Sock_Addr_Type) is
   begin
      Log.Info ("Reading server stream");

      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Reader.Socket'Unchecked_Access,
                                Output => null);
      Reader.Server.Start (Reader'Unchecked_Access, Address);
   end Open;

   procedure Close (Reader : in out Socket_Reader_Type) is
   begin
      Reader.Stop := True;
   end Close;

end MAT.Readers.Streams.Sockets;

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

with MAT.Readers.Marshaller;
package body MAT.Readers.Streams.Sockets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Sockets");

   BUFFER_SIZE  : constant Natural := 100 * 1024;
   MAX_MSG_SIZE : constant Ada.Streams.Stream_Element_Offset := 2048;

   --  ------------------------------
   --  Stop the listener socket.
   --  ------------------------------
   procedure Stop (Listener : in out Socket_Listener) is
   begin
      GNAT.Sockets.Abort_Selector (Listener.Accept_Selector);
   end Stop;

   task body Socket_Listener_Task is
      use type GNAT.Sockets.Socket_Type;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
      Status   : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (S : in Socket_Reader_Type_Access;
                       Address : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := S;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      while not Instance.Stop loop
         GNAT.Sockets.Accept_Socket (Server, Socket, Peer, 1.0, null, Status);
         if Socket /= GNAT.Sockets.No_Socket then
            Instance.Socket.Open (Socket);
            Instance.Read_All;
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);
   end Socket_Listener_Task;

   task body Socket_Reader_Task is
      use type GNAT.Sockets.Socket_Type;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
      Status   : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (S : in Socket_Reader_Type_Access;
                       Address : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := S;
            --              Address.Addr := GNAT.Sockets.Addresses (Get_Host_By_Name (S.Get_Host), 1);
--              Address.Addr := GNAT.Sockets.Any_Inet_Addr;
--              Address.Port := 4096;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
--              Address := GNAT.Sockets.Get_Socket_Name (Server);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      while not Instance.Stop loop
         GNAT.Sockets.Accept_Socket (Server, Socket, Peer, 1.0, null, Status);
         if Socket /= GNAT.Sockets.No_Socket then
            Instance.Socket.Open (Socket);
            Instance.Read_All;
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);

   exception
      when E : others =>
         Log.Error ("Exception", E);

   end Socket_Reader_Task;

   --  Open the socket to accept connections.
   procedure Open (Reader  : in out Socket_Reader_Type;
                   Address : in GNAT.Sockets.Sock_Addr_Type) is
   begin
      Log.Info ("Reading server stream");

      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Reader.Socket'Unchecked_Access,
                                Output => null);
      Reader.Server.Start (Reader'Unchecked_Access, Address);
   end Open;

   procedure Close (Reader : in out Socket_Reader_Type) is
   begin
      Reader.Stop := True;
   end Close;

end MAT.Readers.Streams.Sockets;

Implement the Stop operation

Implement the Stop operation


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

with Util.Streams.Sockets;
with GNAT.Sockets;
package MAT.Readers.Streams.Sockets is

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

   --  Initialize the socket listener.
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type);

   --  Destroy the socket listener.
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type);

   --  Open the socket to accept connections and start the listener task.
   procedure Start (Listener : in out Socket_Listener_Type;
                    Address  : in GNAT.Sockets.Sock_Addr_Type);

   --  Stop the listener socket.
   procedure Stop (Listener : in out Socket_Listener_Type);

   --  Create a target instance for the new client.
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type);

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with private;
   type Socket_Reader_Type_Access is access all Socket_Reader_Type'Class;

   procedure Close (Reader : in out Socket_Reader_Type);

private

   type Socket_Listener_Type_Access is access all Socket_Listener_Type;

   task type Socket_Listener_Task is
      entry Start (Listener : in Socket_Listener_Type_Access;
                   Address  : in GNAT.Sockets.Sock_Addr_Type);
   end Socket_Listener_Task;

   task type Socket_Reader_Task is
      entry Start (Reader  : in Socket_Reader_Type_Access;
                   Client  : in GNAT.Sockets.Socket_Type);
   end Socket_Reader_Task;

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with record
      Socket : aliased Util.Streams.Sockets.Socket_Stream;
      Server : Socket_Reader_Task;
      Client : GNAT.Sockets.Socket_Type;
      Stop   : Boolean := False;
   end record;

   package Socket_Client_Lists is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Socket_Reader_Type_Access);

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with record
      Accept_Selector : aliased GNAT.Sockets.Selector_Type;
      Listener        : Socket_Listener_Task;
      Clients         : Socket_Client_Lists.List;
   end record;

end MAT.Readers.Streams.Sockets;

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

with Util.Streams.Sockets;
with GNAT.Sockets;
package MAT.Readers.Streams.Sockets is

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

   --  Initialize the socket listener.
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type);

   --  Destroy the socket listener.
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type);

   --  Open the socket to accept connections and start the listener task.
   procedure Start (Listener : in out Socket_Listener_Type;
                    List     : in MAT.Readers.Reader_List_Type_Access;
                    Address  : in GNAT.Sockets.Sock_Addr_Type);

   --  Stop the listener socket.
   procedure Stop (Listener : in out Socket_Listener_Type);

   --  Create a target instance for the new client.
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type);

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with private;
   type Socket_Reader_Type_Access is access all Socket_Reader_Type'Class;

   procedure Close (Reader : in out Socket_Reader_Type);

private

   type Socket_Listener_Type_Access is access all Socket_Listener_Type;

   task type Socket_Listener_Task is
      entry Start (Listener : in Socket_Listener_Type_Access;
                   Address  : in GNAT.Sockets.Sock_Addr_Type);
   end Socket_Listener_Task;

   task type Socket_Reader_Task is
      entry Start (Reader  : in Socket_Reader_Type_Access;
                   Client  : in GNAT.Sockets.Socket_Type);
   end Socket_Reader_Task;

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with record
      Socket : aliased Util.Streams.Sockets.Socket_Stream;
      Server : Socket_Reader_Task;
      Client : GNAT.Sockets.Socket_Type;
      Stop   : Boolean := False;
   end record;

   package Socket_Client_Lists is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Socket_Reader_Type_Access);

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with record
      List            : MAT.Readers.Reader_List_Type_Access;
      Accept_Selector : aliased GNAT.Sockets.Selector_Type;
      Listener        : Socket_Listener_Task;
      Clients         : Socket_Client_Lists.List;
   end record;

end MAT.Readers.Streams.Sockets;

Add the Reader_List_Type instance to the Start operation and keep it in the socket listener type


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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Result : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      MAT.Frames.Tests.Add_Tests (Result);
      MAT.Memory.Tests.Add_Tests (Result);
      MAT.Readers.Tests.Add_Tests (Result);
      MAT.Targets.Tests.Add_Tests (Result);
      return Result;
   end Suite;

end MAT.Testsuite;

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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Result : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      MAT.Expressions.Tests.Add_Tests (Result);
      MAT.Frames.Tests.Add_Tests (Result);
      MAT.Memory.Tests.Add_Tests (Result);
      MAT.Readers.Tests.Add_Tests (Result);
      MAT.Targets.Tests.Add_Tests (Result);
      return Result;
   end Suite;

end MAT.Testsuite;

Add the new unit tests

Add the new unit tests


private with Ada.Finalization;

private with Interfaces;
private with Interfaces.C;
private with Interfaces.C.Pointers;

private with System;

package YAML is

   type UTF8_String is new String;

   type Document_Type is tagged limited private;
   --  Holder for a YAML document

   type Node_Kind is
     (No_Node,
      --  An empty node

      Scalar_Node,
      --  A scalar node

      Sequence_Node,
      --  A sequence node

      Mapping_Node
      --  A mapping node
     ) with
      Convention => C;
   --  Type of a node in a document

   type Node_Ref is private;
   --  Reference to a node as part of a document

   No_Node_Ref : constant Node_Ref;

   function Root_Node (Document : Document_Type'Class) return Node_Ref;
   --  Return the root node of a document, or No_Node_Ref for an empty
   --  document.

   function Kind (Node : Node_Ref) return Node_Kind;
   --  Return the type of a node

   function Scalar_Value (Node : Node_Ref) return UTF8_String
      with Pre => Kind (Node) = Scalar_Node;

   function Sequence_Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) = Sequence_Node;
   --  Return the number of items in the Node sequence

   function Sequence_Item (Node : Node_Ref; Index : Positive) return Node_Ref
      with Pre => Kind (Node) = Sequence_Node;
   --  Return the Index'th item in Node. Index is 1-based.

   type Node_Pair is record
      Key, Value : Node_Ref;
   end record;
   --  Key/value asssociation in a mapping node

   function Mapping_Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) = Mapping_Node;
   --  Return the number of key/value associations in the Node mapping

   function Mapping_Item (Node : Node_Ref; Index : Positive) return Node_Pair
      with Pre => Kind (Node) = Mapping_Node;
   --  Return the Index'th key/value association in Node. Index is 1-based.

   type Parser_Type is tagged limited private;
   --  YAML document parser

   type Encoding_Type is
     (Any_Encoding,
      --  Let the parser choose the encoding

      UTF8_Encoding,
      --  The default UTF-8 encoding

      UTF16LE_Encoding,
      --  The UTF-16-LE encoding with BOM

      UTF16BE_Encoding
      --  The UTF-16-BE encoding with BOM
     ) with
      Convention => C;
   --  Stream encoding

   procedure Set_Input_String
     (Parser   : in out Parser_Type'Class;
      Input    : String;
      Encoding : Encoding_Type);
   --  Set a string input. This maintains a copy of Input in Parser.

   function Load (Parser : in out Parser_Type'Class) return Document_Type;
   --  Parse the input stream and produce the next YAML document.
   --
   --  Call this function subsequently to produce a sequence of documents
   --  constituting the input stream. If the produced document has no root
   --  node, it means that the document end has been reached.
   --
   --  TODO: error handling

private

   subtype C_Int is Interfaces.C.int;
   subtype C_Index is C_Int range 0 .. C_Int'Last;
   subtype C_Ptr_Diff is Interfaces.C.ptrdiff_t;

   type C_Char_Array is array (C_Index) of Interfaces.Unsigned_8;
   type C_Char_Access is access C_Char_Array;

   type C_Node_T;
   type C_Node_Access is access all C_Node_T;

   type C_Scalar_Style_T is
     (Any_Scalar_Style,
      Plain_Scalar_Style,
      Single_Quoted_Scalar_Style,
      Double_Quoted_Scalar_Style,
      Literal_Scalar_Style,
      Folded_Scalar_Style) with
      Convention => C;
   --  Scalar styles

   type C_Sequence_Style_T is
     (Any_Sequence_Style,
      Block_Sequence_Style,
      Flow_Sequence_Style) with
      Convention => C;
   --  Sequence styles

   type C_Mapping_Style_T is
     (Any_Mapping_Style,
      Block_Mapping_Style,
      Flow_Mapping_Style) with
      Convention => C;
   --  Mapping styles

   type C_Mark_T is record
      Index, Line, Column : Interfaces.C.size_t;
   end record with
      Convention => C_Pass_By_Copy;
   --  The pointer position

   type C_Version_Directive_T is record
      Major, Minor : C_Int;
      --  Major and minor version numbers
   end record with
      Convention => C_Pass_By_Copy;
   --  The version directive data

   type C_Version_Directive_Access is access all C_Version_Directive_T;

   type C_Tag_Directive_T is record
      Handle : C_Char_Access;
      --  The tag handle

      Prefix : C_Char_Access;
      --  The tag prefix
   end record with
      Convention => C_Pass_By_Copy;
   --  The tag directive data

   type C_Tag_Directive_Access is access C_Tag_Directive_T;

   subtype C_Node_Item_T is C_Int;
   type C_Node_Item_Array is array (C_Index range <>) of aliased C_Node_Item_T;
   package C_Node_Item_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Item_T,
      Element_Array      => C_Node_Item_Array,
      Default_Terminator => -1);
   subtype C_Node_Item_Access is C_Node_Item_Accesses.Pointer;

   type C_Node_Pair_T is record
      Key, Value : C_Int;
   end record with
      Convention => C_Pass_By_Copy;
   type C_Node_Pair_Array is array (C_Index range <>) of aliased C_Node_Pair_T;
   package C_Node_Pair_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Pair_T,
      Element_Array      => C_Node_Pair_Array,
      Default_Terminator => (-1, -1));
   subtype C_Node_Pair_Access is C_Node_Pair_Accesses.Pointer;

   ----------------------------
   -- Node structure binding --
   ----------------------------

   type C_Scalar_Node_Data is record
      Value  : C_Char_Access;
      --  The scalar value

      Length : Interfaces.C.size_t;
      --  The length of the scalar value

      Style  : C_Scalar_Style_T;
      --  The scalar style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Items is record
      Seq_Start, Seq_End, Seq_Top : C_Node_Item_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Node_Data is record
      Items : C_Sequence_Items;
      --  The stack of sequence items

      Style : C_Sequence_Style_T;
      --  The sequence style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Pairs is record
      Map_Start, Map_End, Map_Top : C_Node_Pair_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Node_Data is record
      Pairs : C_Mapping_Pairs;
      --  The stack of mapping pairs

      Style : C_Mapping_Style_T;
      --  The mapping style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Node_Data (Dummy : Node_Kind := No_Node) is record
      case Dummy is
         when No_Node =>
            null;

         when Scalar_Node =>
            Scalar : C_Scalar_Node_Data;
            --  The scalar parameters (for Scalar_Node)

         when Sequence_Node =>
            Sequence : C_Sequence_Node_Data;
            --  The sequence parameters (for Sequence_Node)

         when Mapping_Node =>
            Mapping : C_Mapping_Node_Data;
            --  The mapping parameters (for Mapping_Node)
      end case;
   end record with
      Convention => C_Pass_By_Copy,
      Unchecked_Union;

   type C_Node_T is record
      Kind : Node_Kind;
      --  The node type

      Tag  : C_Char_Access;
      --  The node tag

      Data : C_Node_Data;
      --  The node data

      Start_Mark, End_Mark : C_Mark_T;
   end record with
      Convention => C_Pass_By_Copy;

   --------------------------------
   -- Document structure binding --
   --------------------------------

   type C_Document_Nodes is record
      Start_Node, End_Node, Top_Node : C_Node_T;
      --  Begining, end and top of the stack
   end record with
      Convention => C_Pass_By_Copy;

   type C_Tag_Directives is record
      Start_Dir, End_Dir : C_Tag_Directive_Access;
      --  Beginning and end of the tag directives list
   end record with
      Convention => C_Pass_By_Copy;

   type C_Document_T is record
      Nodes                        : C_Document_Nodes;
      --  The document nodes

      Version_Directives           : C_Version_Directive_Access;
      --  The version directive

      Tag_Directives               : C_Tag_Directives;
      --  The list of tag directives

      Start_Implicit, End_Implicit : C_Int;
      --  Is the document start/end indicator explicit?

      Start_Mark, End_Mark         : C_Mark_T;
      --  Beginning and end of the document
   end record with
      Convention => C_Pass_By_Copy;
   --  The document structure

   type C_Document_Access is access all C_Document_T;

   -------------------------
   -- High-level Wrappers --
   -------------------------

   type Document_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Doc     : aliased C_Document_T;
      To_Delete : Boolean;
   end record;

   overriding procedure Initialize (Document : in out Document_Type);
   overriding procedure Finalize (Document : in out Document_Type);

   type Document_Access is access all Document_Type'Class;

   type Node_Ref is record
      Node     : C_Node_Access;
      --  The referenced node

      Document : Document_Access;
      --  The document it belongs to
   end record;

   No_Node_Ref : constant Node_Ref := (null, null);

   type C_Parser_Access is new System.Address;
   type String_Access is access String;

   type Parser_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Parser       : C_Parser_Access;
      Input_Encoding : Encoding_Type;
      Input_String   : String_Access;
   end record;

   overriding procedure Initialize (Parser : in out Parser_Type);
   overriding procedure Finalize (Parser : in out Parser_Type);

end YAML;

private with Ada.Finalization;

private with Interfaces;
private with Interfaces.C;
private with Interfaces.C.Pointers;

private with System;

package YAML is

   type UTF8_String is new String;

   type Document_Type is tagged limited private;
   --  Holder for a YAML document

   type Node_Kind is
     (No_Node,
      --  An empty node

      Scalar_Node,
      --  A scalar node

      Sequence_Node,
      --  A sequence node

      Mapping_Node
      --  A mapping node
     ) with
      Convention => C;
   --  Type of a node in a document

   type Node_Ref is private;
   --  Reference to a node as part of a document. Such values must not outlive
   --  the value for the document that owns them.

   No_Node_Ref : constant Node_Ref;

   function Root_Node (Document : Document_Type'Class) return Node_Ref;
   --  Return the root node of a document, or No_Node_Ref for an empty
   --  document.

   function Kind (Node : Node_Ref) return Node_Kind;
   --  Return the type of a node

   function Scalar_Value (Node : Node_Ref) return UTF8_String
      with Pre => Kind (Node) = Scalar_Node;

   function Sequence_Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) = Sequence_Node;
   --  Return the number of items in the Node sequence

   function Sequence_Item (Node : Node_Ref; Index : Positive) return Node_Ref
      with Pre => Kind (Node) = Sequence_Node;
   --  Return the Index'th item in Node. Index is 1-based.

   type Node_Pair is record
      Key, Value : Node_Ref;
   end record;
   --  Key/value asssociation in a mapping node

   function Mapping_Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) = Mapping_Node;
   --  Return the number of key/value associations in the Node mapping

   function Mapping_Item (Node : Node_Ref; Index : Positive) return Node_Pair
      with Pre => Kind (Node) = Mapping_Node;
   --  Return the Index'th key/value association in Node. Index is 1-based.

   type Parser_Type is tagged limited private;
   --  YAML document parser

   type Encoding_Type is
     (Any_Encoding,
      --  Let the parser choose the encoding

      UTF8_Encoding,
      --  The default UTF-8 encoding

      UTF16LE_Encoding,
      --  The UTF-16-LE encoding with BOM

      UTF16BE_Encoding
      --  The UTF-16-BE encoding with BOM
     ) with
      Convention => C;
   --  Stream encoding

   procedure Set_Input_String
     (Parser   : in out Parser_Type'Class;
      Input    : String;
      Encoding : Encoding_Type);
   --  Set a string input. This maintains a copy of Input in Parser.

   function Load (Parser : in out Parser_Type'Class) return Document_Type;
   --  Parse the input stream and produce the next YAML document.
   --
   --  Call this function subsequently to produce a sequence of documents
   --  constituting the input stream. If the produced document has no root
   --  node, it means that the document end has been reached.
   --
   --  TODO: error handling

private

   subtype C_Int is Interfaces.C.int;
   subtype C_Index is C_Int range 0 .. C_Int'Last;
   subtype C_Ptr_Diff is Interfaces.C.ptrdiff_t;

   type C_Char_Array is array (C_Index) of Interfaces.Unsigned_8;
   type C_Char_Access is access C_Char_Array;

   type C_Node_T;
   type C_Node_Access is access all C_Node_T;

   type C_Scalar_Style_T is
     (Any_Scalar_Style,
      Plain_Scalar_Style,
      Single_Quoted_Scalar_Style,
      Double_Quoted_Scalar_Style,
      Literal_Scalar_Style,
      Folded_Scalar_Style) with
      Convention => C;
   --  Scalar styles

   type C_Sequence_Style_T is
     (Any_Sequence_Style,
      Block_Sequence_Style,
      Flow_Sequence_Style) with
      Convention => C;
   --  Sequence styles

   type C_Mapping_Style_T is
     (Any_Mapping_Style,
      Block_Mapping_Style,
      Flow_Mapping_Style) with
      Convention => C;
   --  Mapping styles

   type C_Mark_T is record
      Index, Line, Column : Interfaces.C.size_t;
   end record with
      Convention => C_Pass_By_Copy;
   --  The pointer position

   type C_Version_Directive_T is record
      Major, Minor : C_Int;
      --  Major and minor version numbers
   end record with
      Convention => C_Pass_By_Copy;
   --  The version directive data

   type C_Version_Directive_Access is access all C_Version_Directive_T;

   type C_Tag_Directive_T is record
      Handle : C_Char_Access;
      --  The tag handle

      Prefix : C_Char_Access;
      --  The tag prefix
   end record with
      Convention => C_Pass_By_Copy;
   --  The tag directive data

   type C_Tag_Directive_Access is access C_Tag_Directive_T;

   subtype C_Node_Item_T is C_Int;
   type C_Node_Item_Array is array (C_Index range <>) of aliased C_Node_Item_T;
   package C_Node_Item_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Item_T,
      Element_Array      => C_Node_Item_Array,
      Default_Terminator => -1);
   subtype C_Node_Item_Access is C_Node_Item_Accesses.Pointer;

   type C_Node_Pair_T is record
      Key, Value : C_Int;
   end record with
      Convention => C_Pass_By_Copy;
   type C_Node_Pair_Array is array (C_Index range <>) of aliased C_Node_Pair_T;
   package C_Node_Pair_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Pair_T,
      Element_Array      => C_Node_Pair_Array,
      Default_Terminator => (-1, -1));
   subtype C_Node_Pair_Access is C_Node_Pair_Accesses.Pointer;

   ----------------------------
   -- Node structure binding --
   ----------------------------

   type C_Scalar_Node_Data is record
      Value  : C_Char_Access;
      --  The scalar value

      Length : Interfaces.C.size_t;
      --  The length of the scalar value

      Style  : C_Scalar_Style_T;
      --  The scalar style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Items is record
      Seq_Start, Seq_End, Seq_Top : C_Node_Item_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Node_Data is record
      Items : C_Sequence_Items;
      --  The stack of sequence items

      Style : C_Sequence_Style_T;
      --  The sequence style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Pairs is record
      Map_Start, Map_End, Map_Top : C_Node_Pair_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Node_Data is record
      Pairs : C_Mapping_Pairs;
      --  The stack of mapping pairs

      Style : C_Mapping_Style_T;
      --  The mapping style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Node_Data (Dummy : Node_Kind := No_Node) is record
      case Dummy is
         when No_Node =>
            null;

         when Scalar_Node =>
            Scalar : C_Scalar_Node_Data;
            --  The scalar parameters (for Scalar_Node)

         when Sequence_Node =>
            Sequence : C_Sequence_Node_Data;
            --  The sequence parameters (for Sequence_Node)

         when Mapping_Node =>
            Mapping : C_Mapping_Node_Data;
            --  The mapping parameters (for Mapping_Node)
      end case;
   end record with
      Convention => C_Pass_By_Copy,
      Unchecked_Union;

   type C_Node_T is record
      Kind : Node_Kind;
      --  The node type

      Tag  : C_Char_Access;
      --  The node tag

      Data : C_Node_Data;
      --  The node data

      Start_Mark, End_Mark : C_Mark_T;
   end record with
      Convention => C_Pass_By_Copy;

   --------------------------------
   -- Document structure binding --
   --------------------------------

   type C_Document_Nodes is record
      Start_Node, End_Node, Top_Node : C_Node_T;
      --  Begining, end and top of the stack
   end record with
      Convention => C_Pass_By_Copy;

   type C_Tag_Directives is record
      Start_Dir, End_Dir : C_Tag_Directive_Access;
      --  Beginning and end of the tag directives list
   end record with
      Convention => C_Pass_By_Copy;

   type C_Document_T is record
      Nodes                        : C_Document_Nodes;
      --  The document nodes

      Version_Directives           : C_Version_Directive_Access;
      --  The version directive

      Tag_Directives               : C_Tag_Directives;
      --  The list of tag directives

      Start_Implicit, End_Implicit : C_Int;
      --  Is the document start/end indicator explicit?

      Start_Mark, End_Mark         : C_Mark_T;
      --  Beginning and end of the document
   end record with
      Convention => C_Pass_By_Copy;
   --  The document structure

   type C_Document_Access is access all C_Document_T;

   -------------------------
   -- High-level Wrappers --
   -------------------------

   type Document_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Doc     : aliased C_Document_T;
      To_Delete : Boolean;
   end record;

   overriding procedure Initialize (Document : in out Document_Type);
   overriding procedure Finalize (Document : in out Document_Type);

   type Document_Access is access all Document_Type'Class;

   type Node_Ref is record
      Node     : C_Node_Access;
      --  The referenced node

      Document : Document_Access;
      --  The document it belongs to
   end record;

   No_Node_Ref : constant Node_Ref := (null, null);

   type C_Parser_Access is new System.Address;
   type String_Access is access String;

   type Parser_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Parser       : C_Parser_Access;
      Input_Encoding : Encoding_Type;
      Input_String   : String_Access;
   end record;

   overriding procedure Initialize (Parser : in out Parser_Type);
   overriding procedure Finalize (Parser : in out Parser_Type);

end YAML;

Enhance comment for YAML.Node_Ref

Enhance comment for YAML.Node_Ref


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

with Util.Test_Caller;

with Security.Policies; use Security;
with Security.Policies.URLs;

with ASF.Servlets;
with ASF.Servlets.Tests;
with ASF.Security.Filters;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Security.Tests is

   use Util.Tests;

   --  ------------------------------
   --  Check that the given URI reports the HTTP status.
   --  ------------------------------
   procedure Check_Security (T      : in out Test;
                             URI    : in String;
                             Result : in Natural) is
      Ctx : ASF.Servlets.Servlet_Registry;

      S1  : aliased ASF.Servlets.Tests.Test_Servlet1;
      F1  : aliased ASF.Security.Filters.Auth_Filter;
      Sec : aliased Policies.Policy_Manager (Max_Policies => 10);
   begin
      F1.Set_Permission_Manager (Sec'Unchecked_Access);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
      Ctx.Add_Filter ("Security", F1'Unchecked_Access);

      Sec.Add_Policy (new Policies.URLs.URL_Policy);
      Sec.Read_Policy (Util.Tests.Get_Path ("regtests/files/permissions/simple-policy.xml"));
      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Filter_Mapping (Pattern => "*.jsf", Name => "Security");

      declare
         Dispatcher : constant ASF.Servlets.Request_Dispatcher
           := Ctx.Get_Request_Dispatcher (Path => URI & ".jsf");
         Req        : ASF.Requests.Mockup.Request;
         Resp       : ASF.Responses.Mockup.Response;
      begin
         Req.Set_Request_URI ("/admin/test");
         Req.Set_Method ("GET");
         ASF.Servlets.Forward (Dispatcher, Req, Resp);

         Assert_Equals (T, Result, Resp.Get_Status, "Invalid status");
      end;
   end Check_Security;

   --  ------------------------------
   --  Test the security filter granting permission for a given URI.
   --  ------------------------------
   procedure Test_Security_Filter (T : in out Test) is
   begin
      T.Check_Security ("/admin/test", ASF.Responses.SC_UNAUTHORIZED);
   end Test_Security_Filter;

   --  ------------------------------
   --  Test the security filter grants access to anonymous allowed pages.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Check_Security ("/view", ASF.Responses.SC_OK);
   end Test_Anonymous_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Security.Filters.Auth_Filter (deny)",
                       Test_Security_Filter'Access);
      Caller.Add_Test (Suite, "Test ASF.Security.Filters.Auth_Filter (grant)",
                       Test_Anonymous_Access'Access);
   end Add_Tests;

end ASF.Security.Tests;

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

with Util.Test_Caller;

with Security.Policies; use Security;
with Security.Policies.URLs;

with ASF.Servlets;
with ASF.Servlets.Tests;
with ASF.Security.Filters;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Security.Tests is

   use Util.Tests;

   --  ------------------------------
   --  Check that the given URI reports the HTTP status.
   --  ------------------------------
   procedure Check_Security (T      : in out Test;
                             URI    : in String;
                             Result : in Natural) is
      Ctx : ASF.Servlets.Servlet_Registry;

      S1  : aliased ASF.Servlets.Tests.Test_Servlet1;
      F1  : aliased ASF.Security.Filters.Auth_Filter;
      Sec : aliased Policies.Policy_Manager (Max_Policies => 10);
   begin
      F1.Set_Permission_Manager (Sec'Unchecked_Access);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
      Ctx.Add_Filter ("Security", F1'Unchecked_Access);

      Sec.Add_Policy (new Policies.URLs.URL_Policy);
      Sec.Read_Policy (Util.Tests.Get_Path ("regtests/files/permissions/simple-policy.xml"));
      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Filter_Mapping (Pattern => "*.jsf", Name => "Security");
      Ctx.Start;

      declare
         Dispatcher : constant ASF.Servlets.Request_Dispatcher
           := Ctx.Get_Request_Dispatcher (Path => URI & ".jsf");
         Req        : ASF.Requests.Mockup.Request;
         Resp       : ASF.Responses.Mockup.Response;
      begin
         Req.Set_Request_URI ("/admin/test");
         Req.Set_Method ("GET");
         ASF.Servlets.Forward (Dispatcher, Req, Resp);

         Assert_Equals (T, Result, Resp.Get_Status, "Invalid status");
      end;
   end Check_Security;

   --  ------------------------------
   --  Test the security filter granting permission for a given URI.
   --  ------------------------------
   procedure Test_Security_Filter (T : in out Test) is
   begin
      T.Check_Security ("/admin/test", ASF.Responses.SC_UNAUTHORIZED);
   end Test_Security_Filter;

   --  ------------------------------
   --  Test the security filter grants access to anonymous allowed pages.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Check_Security ("/view", ASF.Responses.SC_OK);
   end Test_Anonymous_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Security.Filters.Auth_Filter (deny)",
                       Test_Security_Filter'Access);
      Caller.Add_Test (Suite, "Test ASF.Security.Filters.Auth_Filter (grant)",
                       Test_Anonymous_Access'Access);
   end Add_Tests;

end ASF.Security.Tests;

Call the Start procedure so that the servlet filters are installed