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

with Ada.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;

with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) <= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'<=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      Res := To_Object_Test (N) >= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'>=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      if To_Object_Test (N) + To_Object_Test (N) /= To_Object_Test (N) then
         Res := To_Object_Test (N) + To_Object_Test (N) <= To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'<=' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V & "Num="
                     & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                     & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
         Res := To_Object_Test (N) >= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V);
      end if;
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) <= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) >= To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Le_Ge;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);
   procedure Test_Le_Ge is new Test_Basic_Object (Test_Le_Ge);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Beans.Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

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

with Ada.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;
with Ada.Characters.Conversions;
with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value  : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      declare
         Val    : Ada.Strings.Unbounded.Unbounded_String;
         Value2 : Util.Beans.Objects.Object;
      begin
         Val := Ada.Strings.Unbounded.To_Unbounded_String (V);
         Value2 := To_Object (Val);
         T.Assert (Value2 = Value, "Invalid value");

         T.Assert (Condition => To_Type (Value2) = N,
                   Message   => Test_Name & " returned invalid value: "
                     & To_String (Value2) & " when we expected: " & V);
      end;

      declare
         Val    : constant Wide_Wide_String
           := Ada.Characters.Conversions.To_Wide_Wide_String (V);
         Value2 : Util.Beans.Objects.Object;
      begin
         Value2 := To_Object (Val);
         T.Assert (Value2 = Value, "Invalid value");

         T.Assert (Condition => To_Type (Value2) = N,
                   Message   => Test_Name & " returned invalid value: "
                     & To_String (Value2) & " when we expected: " & V);

      end;
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) <= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'<=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      Res := To_Object_Test (N) >= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'>=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      if To_Object_Test (N) + To_Object_Test (N) /= To_Object_Test (N) then
         Res := To_Object_Test (N) + To_Object_Test (N) <= To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'<=' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V & "Num="
                     & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                     & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
         Res := To_Object_Test (N) >= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V);
      end if;
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) <= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) >= To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Le_Ge;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);
   procedure Test_Le_Ge is new Test_Basic_Object (Test_Le_Ge);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Beans.Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

Add more tests on discrete Object types

Add more tests on discrete Object types


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 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 Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

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

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 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 Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Vectors;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

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

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Collect the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with the prefix are
   --  returned.
   procedure Get_Names (Self   : in Manager;
                        Into   : in out Util.Strings.Vectors.Vector;
                        Prefix : in String := "");

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager;
                        Name : in String) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Util.Beans.Objects.Object))
      is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Refactor the Properties implementation (step 3): - Declare a Get_Names procedure to collect the property names - Change the internal Remove procedure to use a String for Name parameter - Change the internal Iterate procedure to get the property value as Object


-----------------------------------------------------------------------
--  util-events-timers -- Timer list management
--  Copyright (C) 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 Ada.Real_Time;
private with Ada.Finalization;
private with Util.Concurrent.Counters;

--  == Timer Management ==
--  The <tt>Util.Events.Timers</tt> package provides a timer list that allows to have
--  operations called on regular basis when a deadline has expired.  It is very close to
--  the <tt>Ada.Real_Time.Timing_Events</tt> package but it provides more flexibility
--  by allowing to have several timer lists that run independently.  Unlike the GNAT
--  implementation, this timer list management does not use tasks at all.  The timer list
--  can therefore be used in a mono-task environment by the main process task.  Furthermore
--  you can control your own task priority by having your own task that uses the timer list.
--
--  The timer list is created by an instance of <tt>Timer_List</tt>:
--
--    Manager : Util.Events.Timers.Timer_List;
--
--  The timer list is protected against concurrent accesses so that timing events can be
--  setup by a task but the timer handler is executed by another task.
--
--  === Timer Creation ===
--  A timer handler is defined by implementing the <tt>Timer</tt> interface with the
--  <tt>Time_Handler</tt> procedure.  A typical timer handler could be declared as follows:
--
--    type Timeout is new Timer with null record;
--    overriding procedure Time_Handler (T : in out Timeout);
--
--    My_Timeout : aliased Timeout;
--
--  The timer instance is represented by the <tt>Timer_Ref</tt> type that describes the handler
--  to be called as well as the deadline time.  The timer instance is initialized as follows:
--
--    T : Util.Events.Timers.Timer_Ref;
--    Manager.Set_Timer (T, My_Timeout'Access, Ada.Real_Time.Seconds (1));
--
--  === Timer Main Loop ===
--  Because the implementation does not impose any execution model, the timer management must
--  be called regularly by some application's main loop.  The <tt>Process</tt> procedure
--  executes the timer handler that have ellapsed and it returns the deadline to wait for the
--  next timer to execute.
--
--    Deadline : Ada.Real_Time.Time;
--    loop
--       ...
--       Manager.Process (Deadline);
--       delay until Deadline;
--    end loop;
--
package Util.Events.Timers is

   type Timer_Ref is tagged private;

   --  The timer interface that must be implemented by applications.
   type Timer is limited interface;
   type Timer_Access is access all Timer'Class;

   --  The timer handler executed when the timer deadline has passed.
   procedure Time_Handler (T     : in out Timer;
                           Event : in out Timer_Ref'Class) is abstract;

   --  Repeat the timer.
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span);

   --  Cancel the timer.
   procedure Cancel (Event : in out Timer_Ref);

   --  Check if the timer is ready to be executed.
   function Is_Scheduled (Event : in Timer_Ref) return Boolean;

   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time;

   type Timer_List is tagged limited private;

   --  Set a timer to be called at the given time.
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time);

   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last);

private

   type Timer_Manager;
   type Timer_Manager_Access is access all Timer_Manager;

   type Timer_Node;
   type Timer_Node_Access is access all Timer_Node;

   type Timer_Ref is new Ada.Finalization.Controlled with record
      Value : Timer_Node_Access;
   end record;

   overriding
   procedure Adjust (Object : in out Timer_Ref);

   overriding
   procedure Finalize (Object : in out Timer_Ref);

   type Timer_Node is limited record
      Next     : Timer_Node_Access;
      Prev     : Timer_Node_Access;
      List     : Timer_Manager_Access;
      Counter  : Util.Concurrent.Counters.Counter;
      Handler  : Timer_Access;
      Deadline : Ada.Real_Time.Time;
   end record;

   protected type Timer_Manager is

      --  Add a timer.
      procedure Add (Timer    : in out Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time);

      --  Cancel a timer.
      procedure Cancel (Timer : in out Timer_Node_Access);

      --  Find the next timer to be executed or return the next deadline.
      procedure Find_Next (Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref);

   private
      List : Timer_Node_Access;
   end Timer_Manager;

   type Timer_List is new Ada.Finalization.Limited_Controlled with record
      Manager : aliased Timer_Manager;
   end record;

   overriding
   procedure Finalize (Object : in out Timer_List);

end Util.Events.Timers;

-----------------------------------------------------------------------
--  util-events-timers -- Timer list management
--  Copyright (C) 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 Ada.Real_Time;
private with Ada.Finalization;
private with Util.Concurrent.Counters;

--  == Timer Management ==
--  The <tt>Util.Events.Timers</tt> package provides a timer list that allows to have
--  operations called on regular basis when a deadline has expired.  It is very close to
--  the <tt>Ada.Real_Time.Timing_Events</tt> package but it provides more flexibility
--  by allowing to have several timer lists that run independently.  Unlike the GNAT
--  implementation, this timer list management does not use tasks at all.  The timer list
--  can therefore be used in a mono-task environment by the main process task.  Furthermore
--  you can control your own task priority by having your own task that uses the timer list.
--
--  The timer list is created by an instance of <tt>Timer_List</tt>:
--
--    Manager : Util.Events.Timers.Timer_List;
--
--  The timer list is protected against concurrent accesses so that timing events can be
--  setup by a task but the timer handler is executed by another task.
--
--  === Timer Creation ===
--  A timer handler is defined by implementing the <tt>Timer</tt> interface with the
--  <tt>Time_Handler</tt> procedure.  A typical timer handler could be declared as follows:
--
--    type Timeout is new Timer with null record;
--    overriding procedure Time_Handler (T : in out Timeout);
--
--    My_Timeout : aliased Timeout;
--
--  The timer instance is represented by the <tt>Timer_Ref</tt> type that describes the handler
--  to be called as well as the deadline time.  The timer instance is initialized as follows:
--
--    T : Util.Events.Timers.Timer_Ref;
--    Manager.Set_Timer (T, My_Timeout'Access, Ada.Real_Time.Seconds (1));
--
--  === Timer Main Loop ===
--  Because the implementation does not impose any execution model, the timer management must
--  be called regularly by some application's main loop.  The <tt>Process</tt> procedure
--  executes the timer handler that have ellapsed and it returns the deadline to wait for the
--  next timer to execute.
--
--    Deadline : Ada.Real_Time.Time;
--    loop
--       ...
--       Manager.Process (Deadline);
--       delay until Deadline;
--    end loop;
--
package Util.Events.Timers is

   type Timer_Ref is tagged private;

   --  The timer interface that must be implemented by applications.
   type Timer is limited interface;
   type Timer_Access is access all Timer'Class;

   --  The timer handler executed when the timer deadline has passed.
   procedure Time_Handler (T     : in out Timer;
                           Event : in out Timer_Ref'Class) is abstract;

   --  Repeat the timer.
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span);

   --  Cancel the timer.
   procedure Cancel (Event : in out Timer_Ref);

   --  Check if the timer is ready to be executed.
   function Is_Scheduled (Event : in Timer_Ref) return Boolean;

   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time;

   type Timer_List is tagged limited private;

   --  Set a timer to be called at the given time.
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time);

   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last);

private

   type Timer_Manager;
   type Timer_Manager_Access is access all Timer_Manager;

   type Timer_Node;
   type Timer_Node_Access is access all Timer_Node;

   type Timer_Ref is new Ada.Finalization.Controlled with record
      Value : Timer_Node_Access;
   end record;

   overriding
   procedure Adjust (Object : in out Timer_Ref);

   overriding
   procedure Finalize (Object : in out Timer_Ref);

   type Timer_Node is limited record
      Next     : Timer_Node_Access;
      Prev     : Timer_Node_Access;
      List     : Timer_Manager_Access;
      Counter  : Util.Concurrent.Counters.Counter;
      Handler  : Timer_Access;
      Deadline : Ada.Real_Time.Time;
   end record;

   protected type Timer_Manager is

      --  Add a timer.
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time);

      --  Cancel a timer.
      procedure Cancel (Timer : in out Timer_Node_Access);

      --  Find the next timer to be executed or return the next deadline.
      procedure Find_Next (Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref);

   private
      List : Timer_Node_Access;
   end Timer_Manager;

   type Timer_List is new Ada.Finalization.Limited_Controlled with record
      Manager : aliased Timer_Manager;
   end record;

   overriding
   procedure Finalize (Object : in out Timer_List);

end Util.Events.Timers;

Change the Add protected procedure to use only 'in' parameters


-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  Copyright (C) 2012, 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.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  Copyright (C) 2012, 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.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Options",
                          Test_Http_Options'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         elsif L (L'First .. Pos - 1) = "OPTIONS" then
            Into.Method := OPTIONS;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http OPTIONS operation.
   --  ------------------------------
   procedure Test_Http_Options (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Options (Uri & "/options", Reply);

      T.Assert (T.Server.Method = OPTIONS, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Options;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

Implement Test_Http_Options and register the test for execution


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012 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 Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Permission (Id : Permission_Index) is tagged limited null record;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012 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 Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

end Security.Permissions;

Remove Permission_Type and Permission_Map