-----------------------------------------------------------------------
--  mat-events-probes -- Event probes
--  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.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Finalization;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   subtype Probe_Event_Type is MAT.Events.Targets.Probe_Event_Type;

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Probe_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in Probe_Event_Type) is abstract;

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Targets.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Targets.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Probe_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

-----------------------------------------------------------------------
--  mat-events-probes -- Event probes
--  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.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Finalization;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   subtype Probe_Event_Type is MAT.Events.Targets.Probe_Event_Type;

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Probe_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in Probe_Event_Type) is abstract;

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Targets.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Targets.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Probe_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  util-beans-vectors -- Object vectors
--  Copyright (C) 2011, 2017, 2019, 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.
-----------------------------------------------------------------------

package body Util.Beans.Objects.Vectors is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Vector_Bean;
                       Name : in String) return Object is
   begin
      if Name = "count" then
         return To_Object (Natural (From.Length));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Vector_Bean) return Natural is
   begin
      return Natural (From.Length);
   end Get_Count;

   --  ------------------------------
   --  Get the element at the given position.
   --  ------------------------------
   overriding
   function Get_Row (From     : in Vector_Bean;
                     Position : in Natural) return Util.Beans.Objects.Object is
   begin
      return From.Element (Position);
   end Get_Row;

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

   --  -----------------------
   --  Iterate over the vectors or array elements.
   --  If the object is not a `Vector_Bean` or an array, the operation does nothing.
   --  -----------------------
   procedure Iterate (From    : in Object;
                      Process : not null access procedure (Item : in Object)) is
      procedure Process_One (Pos : in Vectors.Cursor);

      procedure Process_One (Pos : in Vectors.Cursor) is
      begin
         Process (Vectors.Element (Pos));
      end Process_One;

      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (From);
   begin
      if Bean /= null and then Bean.all in Vector_Bean'Class then
         Vector_Bean'Class (Bean.all).Iterate (Process_One'Access);
      elsif Is_Array (From) then
         declare
            Count : constant Natural := Get_Count (From);
         begin
            for Pos in 1 .. Count loop
               Process (Get_Value (From, Pos));
            end loop;
         end;
      end if;
   end Iterate;

end Util.Beans.Objects.Vectors;

-----------------------------------------------------------------------
--  util-beans-vectors -- Object vectors
--  Copyright (C) 2011, 2017, 2019, 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.
-----------------------------------------------------------------------

package body Util.Beans.Objects.Vectors is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Vector_Bean;
                       Name : in String) return Object is
   begin
      if Name = "count" then
         return To_Object (Natural (From.Length));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Vector_Bean) return Natural is
   begin
      return Natural (From.Length);
   end Get_Count;

   --  ------------------------------
   --  Get the element at the given position.
   --  ------------------------------
   overriding
   function Get_Row (From     : in Vector_Bean;
                     Position : in Natural) return Util.Beans.Objects.Object is
   begin
      return From.Element (Position);
   end Get_Row;

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

   --  -----------------------
   --  Iterate over the vectors or array elements.
   --  If the object is not a `Vector_Bean` or an array, the operation does nothing.
   --  -----------------------
   procedure Iterate (From    : in Object;
                      Process : not null access procedure (Position : in Positive;
                                                           Item     : in Object)) is
      procedure Process_One (Pos : in Vectors.Cursor);

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

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

      elsif Is_Array (From) then
         declare
            Count : constant Natural := Get_Count (From);
         begin
            for Pos in 1 .. Count loop
               Process (Pos, Get_Value (From, Pos));
            end loop;
         end;
      end if;
   end Iterate;

   --  -----------------------
   --  Get an iterator to iterate starting with the first element.
   --  -----------------------
   overriding
   function First (From : in Vector_Bean) return Iterators.Proxy_Iterator_Access is
      Iter : constant Vector_Iterator_Access := new Vector_Iterator;
   begin
      Iter.Pos := From.First;
      return Iter.all'Access;
   end First;

   --  -----------------------
   --  Get an iterator to iterate starting with the last element.
   --  -----------------------
   overriding
   function Last (From : in Vector_Bean) return Iterators.Proxy_Iterator_Access is
      Iter : constant Vector_Iterator_Access := new Vector_Iterator;
   begin
      Iter.Pos := From.Last;
      return Iter.all'Access;
   end Last;

   overriding
   function Has_Element (Iter : in Vector_Iterator) return Boolean is
   begin
      return Vectors.Has_Element (Iter.Pos);
   end Has_Element;

   overriding
   procedure Next (Iter : in out Vector_Iterator) is
   begin
      Vectors.Next (Iter.Pos);
   end Next;

   overriding
   procedure Previous (Iter : in out Vector_Iterator) is
   begin
      Vectors.Previous (Iter.Pos);
   end Previous;

   overriding
   function Element (Iter : in Vector_Iterator) return Object is
   begin
      return Vectors.Element (Iter.Pos);
   end Element;

end Util.Beans.Objects.Vectors;

Implement the operations for the Vector_Iterator type


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

with Util.Test_Caller;
with Util.Log.Loggers;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;

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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         pragma Unreferenced (Quality);

         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

end ASF.Requests.Tests;

-----------------------------------------------------------------------
--  asf-requests-tests - Unit tests for requests
--  Copyright (C) 2012, 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 Util.Log.Loggers;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;

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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Set_Attribute",
                       Test_Set_Attribute'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         pragma Unreferenced (Quality);

         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Accept_Locales (Process_Locale'Access);
      Util.Tests.Assert_Equals (T, 1, Count, "Invalid number of calls");

      Count := 0;
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

   --  ------------------------------
   --  Test the Set_Attribute procedure.
   --  ------------------------------
   procedure Test_Set_Attribute (T : in out Test) is
      use Util.Beans.Objects;
      Req : ASF.Requests.Mockup.Request;
   begin
      Req.Set_Attribute ("page", Util.Beans.Objects.To_Object (Integer (1)));
      Util.Tests.Assert_Equals (T, 1, Util.Beans.Objects.To_Integer (Req.Get_Attribute ("page")),
                                "Invalid page attribute");

      Req.Remove_Attribute ("page");
      T.Assert (Util.Beans.Objects.Is_Null (Req.Get_Attribute ("page")),
                "Attribute page is not null");

      Req.Set_Attribute ("page", Util.Beans.Objects.To_Object (Integer (1)));
      Req.Set_Attribute ("page", Util.Beans.Objects.Null_Object);
      T.Assert (Util.Beans.Objects.Is_Null (Req.Get_Attribute ("page")),
                "Attribute page is not null");
   end Test_Set_Attribute;

end ASF.Requests.Tests;

Add a new test to verify the Set/Get/Remove attribute on a request


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  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.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

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

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  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.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

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

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in Role_Policy'Class) then
         return null;
      else
         return Role_Policy'Class (Policy.all)'Access;
      end if;
   end Get_Role_Policy;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Implement the new function Get_Role_Policy


-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2012, 2016 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 Ada.Finalization;
with Ada.Strings.Unbounded;
with Interfaces;

--  The Util.Encoders package defines the Encoder object
--  which represents a mechanism to transform a stream from one format into
--  another format.
package Util.Encoders is

   pragma Preelaborate;

   Not_Supported  : exception;
   Encoding_Error : exception;

   --  Encoder/decoder for Base64 (RFC 4648)
   BASE_64     : constant String := "base64";

   --  Encoder/decoder for Base64 (RFC 4648) using the URL alphabet
   --  (+ and / are replaced by - and _)
   BASE_64_URL : constant String := "base64url";

   --  Encoder/decoder for Base16 (RFC 4648)
   BASE_16     : constant String := "base16";
   HEX         : constant String := "hex";

   --  Encoder for SHA1 (RFC 3174)
   HASH_SHA1   : constant String := "sha1";

   --  ------------------------------
   --  Encoder context object
   --  ------------------------------
   --  The Encoder provides operations to encode and decode
   --  strings or stream of data from one format to another.
   --  The Encoded contains two Transformer
   --  which either encodes or decodes the stream.
   type Encoder is tagged limited private;

   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   function Encode (E    : in Encoder;
                    Data : in String) return String;

   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   function Decode (E    : in Encoder;
                    Data : in String) return String;

   --  Create the encoder object for the specified encoding format.
   function Create (Name : String) return Encoder;

   --  ------------------------------
   --  Stream Transformation interface
   --  ------------------------------
   --  The Transformer interface defines the operation to transform
   --  a stream from one data format to another.
   type Transformer is limited interface;
   type Transformer_Access is access all Transformer'Class;

   --  Transform the input stream represented by Data into
   --  the output stream Into.  The transformation made by
   --  the object can be of any nature (Hex encoding, Base64 encoding,
   --  Hex decoding, Base64 decoding, ...).
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   procedure Transform (E       : in Transformer;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is abstract;

   procedure Transform (E    : in Transformer;
                        Data : in String;
                        Result : out Ada.Strings.Unbounded.Unbounded_String) is null;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in Transformer'Class;
                       Data : in String) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   procedure Transform (E    : in Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset);

   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Ada.Finalization.Limited_Controlled with record
      Encode : Transformer_Access := null;
      Decode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Encoder);

end Util.Encoders;

-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2012, 2016, 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.Streams;
with Ada.Finalization;
with Interfaces;

--  The Util.Encoders package defines the Encoder object
--  which represents a mechanism to transform a stream from one format into
--  another format.
package Util.Encoders is

   pragma Preelaborate;

   Not_Supported  : exception;
   Encoding_Error : exception;

   --  Encoder/decoder for Base64 (RFC 4648)
   BASE_64     : constant String := "base64";

   --  Encoder/decoder for Base64 (RFC 4648) using the URL alphabet
   --  (+ and / are replaced by - and _)
   BASE_64_URL : constant String := "base64url";

   --  Encoder/decoder for Base16 (RFC 4648)
   BASE_16     : constant String := "base16";
   HEX         : constant String := "hex";

   --  Encoder for SHA1 (RFC 3174)
   HASH_SHA1   : constant String := "sha1";

   --  ------------------------------
   --  Encoder context object
   --  ------------------------------
   --  The Encoder provides operations to encode and decode
   --  strings or stream of data from one format to another.
   --  The Encoded contains two Transformer
   --  which either encodes or decodes the stream.
   type Encoder is tagged limited private;

   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   function Encode (E    : in Encoder;
                    Data : in String) return String;

   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   function Decode (E    : in Encoder;
                    Data : in String) return String;

   --  Create the encoder object for the specified encoding format.
   function Create (Name : String) return Encoder;

   --  ------------------------------
   --  Stream Transformation interface
   --  ------------------------------
   --  The Transformer interface defines the operation to transform
   --  a stream from one data format to another.
   type Transformer is limited interface;
   type Transformer_Access is access all Transformer'Class;

   --  Transform the input stream represented by Data into
   --  the output stream Into.  The transformation made by
   --  the object can be of any nature (Hex encoding, Base64 encoding,
   --  Hex decoding, Base64 decoding, ...).
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   procedure Transform (E       : in out Transformer;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is abstract;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in String) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   procedure Transform (E    : in out Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset);

   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Ada.Finalization.Limited_Controlled with record
      Encode : Transformer_Access := null;
      Decode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Encoder);

end Util.Encoders;

Change the Transformer interface to accept in out parameter for the Transformer


-----------------------------------------------------------------------
--  security-openid - Tests for OpenID
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Http.Clients.Mockups;
with Util.Http.Clients.Files;

with Util.Test_Caller;
with Ada.Text_IO;
package body Security.Openid.Tests is

   use Util.Tests;

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

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OpenID.Discover",
                       Test_Discovery'Access);
      Caller.Add_Test (Suite, "Test Security.OpenID.Verify_Signature",
                       Test_Verify_Signature'Access);
   end Add_Tests;

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String) is
      pragma Unreferenced (URI, T);

      M      : Manager;
      Dir    : constant String := "regtests/files/discover/";
      Path   : constant String := Util.Tests.Get_Path (Dir);
      Result : End_Point;
   begin
      ASF.Clients.Files.Register;
      ASF.Clients.Files.Set_File (Path & Name & ".xrds");
      M.Discover (Name   => Name,
                  Result => Result);
      Ada.Text_IO.Put_Line ("Result: " & To_String (Result));
   end Check_Discovery;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Discovery (T : in out Test) is
   begin
      Check_Discovery (T, "google", "https://www.google.com/accounts/o8/ud");
      Check_Discovery (T, "yahoo", "https://open.login.yahooapis.com/openid/op/auth");
      Check_Discovery (T, "claimid", "");
      Check_Discovery (T, "livejournal", "");
      Check_Discovery (T, "myopenid", "");
      Check_Discovery (T, "myspace", "");
      Check_Discovery (T, "orange", "");
      Check_Discovery (T, "verisign", "");
      Check_Discovery (T, "steamcommunity", "");
   end Test_Discovery;

   --  ------------------------------
   --  Test the OpenID verify signature process
   --  ------------------------------
   procedure Test_Verify_Signature (T : in out Test) is
      Assoc  : Association;
      Req    : ASF.Requests.Mockup.Request;
      M      : Manager;
      Result : Authentication;
   begin
      M.Return_To := To_Unbounded_String ("http://localhost/openId");

      --  Below is a part of the authentication process on Google OpenId.
      --  In theory, you cannot use the following information to authenticate again...
      Assoc.Session_Type := To_Unbounded_String ("no-encryption");
      Assoc.Assoc_Type   := To_Unbounded_String ("HMAC-SHA1");
      Assoc.Assoc_Handle := To_Unbounded_String ("AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Assoc.Mac_Key      := To_Unbounded_String ("NGFpR6vWfe7O8YIhhnXQMjL0goI=");

      Req.Set_Parameter ("openid.ns", "http://specs.openid.net/auth/2.0");
      Req.Set_Parameter ("openid.mode", "id_res");
      Req.Set_Parameter ("openid.op_endpoint", "https://www.google.com/accounts/o8/ud");
      Req.Set_Parameter ("openid.response_nonce", "2011-04-26T20:08:22ZJ_neiVqR0e1wZw");
      Req.Set_Parameter ("openid.return_to", "http://localhost/openId");
      Req.Set_Parameter ("openid.assoc_handle", "AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Req.Set_Parameter ("openid.signed", "op_endpoint,claimed_id,identity,return_to,response_nonce,assoc_handle,ns.ext1,ext1.mode,ext1.type.firstname,ext1.value.firstname,ext1.type.email,ext1.value.email,ext1.type.language,ext1.value.language,ext1.type.lastname,ext1.value.lastname");
      Req.Set_Parameter ("openid.sig", "pV8cmScjrmgKvFn2F6Wxh/qBiIE=");
      Req.Set_Parameter ("openid.identity", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.claimed_id", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.ns.ext1", "http://openid.net/srv/ax/1.0");
      Req.Set_Parameter ("openid.ext1.mode", "fetch_response");
      Req.Set_Parameter ("openid.ext1.type.firstname", "http://axschema.org/namePerson/first");
      Req.Set_Parameter ("openid.ext1.value.firstname", "Stephane");
      Req.Set_Parameter ("openid.ext1.type.email", "http://axschema.org/contact/email");
      Req.Set_Parameter ("openid.ext1.value.email", "stephane.carrez@gmail.com");
      Req.Set_Parameter ("openid.ext1.type.language", "http://axschema.org/pref/language");
      Req.Set_Parameter ("openid.ext1.value.language", "fr");
      Req.Set_Parameter ("openid.ext1.type.lastname", "http://axschema.org/namePerson/last");
      Req.Set_Parameter ("openid.ext1.value.lastname", "Carrez");

      M.Verify (Assoc, Req, Result);

      --  If the verification is succeeds, the signature is correct, we should be authenticated.
      T.Assert (Get_Status (Result) = AUTHENTICATED, "Authentication status is not authenticated");
      Assert_Equals (T, "stephane.carrez@gmail.com", Get_Email (Result), "Invalid email");
   end Test_Verify_Signature;

end Security.Openid.Tests;

-----------------------------------------------------------------------
--  security-openid - Tests for OpenID
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Http.Mockups;
with Util.Http.Clients.Mockups;

with Util.Test_Caller;
with Ada.Text_IO;
package body Security.Openid.Tests is

   use Util.Tests;

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

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OpenID.Discover",
                       Test_Discovery'Access);
      Caller.Add_Test (Suite, "Test Security.OpenID.Verify_Signature",
                       Test_Verify_Signature'Access);
   end Add_Tests;

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String) is
      pragma Unreferenced (URI, T);

      M      : Manager;
      Dir    : constant String := "regtests/files/discover/";
      Path   : constant String := Util.Tests.Get_Path (Dir);
      Result : End_Point;
   begin
      Util.Http.Clients.Mockups.Register;
      Util.Http.Clients.Mockups.Set_File (Path & Name & ".xrds");
      M.Discover (Name   => Name,
                  Result => Result);
      Ada.Text_IO.Put_Line ("Result: " & To_String (Result));
   end Check_Discovery;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Discovery (T : in out Test) is
   begin
      Check_Discovery (T, "google", "https://www.google.com/accounts/o8/ud");
      Check_Discovery (T, "yahoo", "https://open.login.yahooapis.com/openid/op/auth");
      Check_Discovery (T, "claimid", "");
      Check_Discovery (T, "livejournal", "");
      Check_Discovery (T, "myopenid", "");
      Check_Discovery (T, "myspace", "");
      Check_Discovery (T, "orange", "");
      Check_Discovery (T, "verisign", "");
      Check_Discovery (T, "steamcommunity", "");
   end Test_Discovery;

   --  ------------------------------
   --  Test the OpenID verify signature process
   --  ------------------------------
   procedure Test_Verify_Signature (T : in out Test) is
      Assoc  : Association;
      Req    : Util.Http.Mockups.Mockup_Request;
      M      : Manager;
      Result : Authentication;
   begin
      M.Return_To := To_Unbounded_String ("http://localhost/openId");

      --  Below is a part of the authentication process on Google OpenId.
      --  In theory, you cannot use the following information to authenticate again...
      Assoc.Session_Type := To_Unbounded_String ("no-encryption");
      Assoc.Assoc_Type   := To_Unbounded_String ("HMAC-SHA1");
      Assoc.Assoc_Handle := To_Unbounded_String ("AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Assoc.Mac_Key      := To_Unbounded_String ("NGFpR6vWfe7O8YIhhnXQMjL0goI=");

      Req.Set_Parameter ("openid.ns", "http://specs.openid.net/auth/2.0");
      Req.Set_Parameter ("openid.mode", "id_res");
      Req.Set_Parameter ("openid.op_endpoint", "https://www.google.com/accounts/o8/ud");
      Req.Set_Parameter ("openid.response_nonce", "2011-04-26T20:08:22ZJ_neiVqR0e1wZw");
      Req.Set_Parameter ("openid.return_to", "http://localhost/openId");
      Req.Set_Parameter ("openid.assoc_handle", "AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Req.Set_Parameter ("openid.signed", "op_endpoint,claimed_id,identity,return_to,response_nonce,assoc_handle,ns.ext1,ext1.mode,ext1.type.firstname,ext1.value.firstname,ext1.type.email,ext1.value.email,ext1.type.language,ext1.value.language,ext1.type.lastname,ext1.value.lastname");
      Req.Set_Parameter ("openid.sig", "pV8cmScjrmgKvFn2F6Wxh/qBiIE=");
      Req.Set_Parameter ("openid.identity", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.claimed_id", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.ns.ext1", "http://openid.net/srv/ax/1.0");
      Req.Set_Parameter ("openid.ext1.mode", "fetch_response");
      Req.Set_Parameter ("openid.ext1.type.firstname", "http://axschema.org/namePerson/first");
      Req.Set_Parameter ("openid.ext1.value.firstname", "Stephane");
      Req.Set_Parameter ("openid.ext1.type.email", "http://axschema.org/contact/email");
      Req.Set_Parameter ("openid.ext1.value.email", "stephane.carrez@gmail.com");
      Req.Set_Parameter ("openid.ext1.type.language", "http://axschema.org/pref/language");
      Req.Set_Parameter ("openid.ext1.value.language", "fr");
      Req.Set_Parameter ("openid.ext1.type.lastname", "http://axschema.org/namePerson/last");
      Req.Set_Parameter ("openid.ext1.value.lastname", "Carrez");

      M.Verify (Assoc, Req, Result);

      --  If the verification is succeeds, the signature is correct, we should be authenticated.
      T.Assert (Get_Status (Result) = AUTHENTICATED, "Authentication status is not authenticated");
      Assert_Equals (T, "stephane.carrez@gmail.com", Get_Email (Result), "Invalid email");
   end Test_Verify_Signature;

end Security.Openid.Tests;

Use the new util HTTP mockups

Use the new util HTTP mockups


-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  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 Util.Serialize.IO;
package body Util.Beans.Objects.Readers is

   use type Maps.Map_Bean_Access;
   use type Vectors.Vector_Bean_Access;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader) is
   begin
      Object_Stack.Clear (Handler.Context);
      Object_Stack.Push (Handler.Context);
      Object_Stack.Current (Handler.Context).Map := new Maps.Map_Bean;
   end Start_Document;

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  <b>Set_Member</b> procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.Map := new Maps.Map_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.List := new Vectors.Vector_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is
      pragma Unreferenced (Attribute);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
   begin
      if Current.Map /= null then
         Current.Map.Set_Value (Name, Value);
      else
         Current.List.Append (Value);
      end if;
   end Set_Member;

end Util.Beans.Objects.Readers;

-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  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.
-----------------------------------------------------------------------
package body Util.Beans.Objects.Readers is

   use type Maps.Map_Bean_Access;
   use type Vectors.Vector_Bean_Access;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader) is
   begin
      Object_Stack.Clear (Handler.Context);
      Object_Stack.Push (Handler.Context);
      Object_Stack.Current (Handler.Context).Map := new Maps.Map_Bean;
   end Start_Document;

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  <b>Set_Member</b> procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Logger);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.Map := new Maps.Map_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Name, Logger);
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Logger);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.List := new Vectors.Vector_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Name, Count, Logger);
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is
      pragma Unreferenced (Logger, Attribute);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
   begin
      if Current.Map /= null then
         Current.Map.Set_Value (Name, Value);
      else
         Current.List.Append (Value);
      end if;
   end Set_Member;

end Util.Beans.Objects.Readers;

Fix compilation warning unused Logger parameter