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

with Util.Strings;
with ASF.Views.Nodes;
with ASF.Converters;
with ASF.Validators;
with EL.Objects;

private with Util.Beans.Objects.Hash;
private with Ada.Containers;
private with Ada.Containers.Hashed_Maps;

--  The ASF.Factory is the main factory for building the facelet
--  node tree and defining associated component factory.  A binding library
--  must be registered before the application starts.  The binding library
--  must not be changed (this is a read-only static definition of names
--  associated with create functions).
package ASF.Factory is

   use ASF;

   Unknown_Name : exception;

   --  Binding name
   type Name_Access is new Util.Strings.Name_Access;

   --  ------------------------------
   --  Binding definition.
   --  ------------------------------
   --  The binding links an XHTML entity name to a tag node implementation
   --  and a component creation handler.  When the XHTML entity is found,
   --  the associated binding is search and when found the node is created
   --  by using the Tag create function.
   type Binding is record
      Name      : Name_Access;
      Component : ASF.Views.Nodes.Create_Access;
      Tag       : ASF.Views.Nodes.Tag_Node_Create_Access;
   end record;

   --  ------------------------------
   --  List of bindings
   --  ------------------------------
   --  The binding array defines a set of XML entity names that represent
   --  a library accessible through a XML name-space.  The binding array
   --  must be sorted on the binding name.  The Check procedure will
   --  verify this assumption when the bindings are registered in the factory.
   type Binding_Array is array (Natural range <>) of Binding;
   type Binding_Array_Access is access constant Binding_Array;

   type Factory_Bindings is record
      URI      : Name_Access;
      Bindings : Binding_Array_Access;
   end record;
   type Factory_Bindings_Access is access constant Factory_Bindings;

   --  Find the create function associated with the name.
   --  Returns null if there is no binding associated with the name.
   function Find (Factory : Factory_Bindings;
                  Name    : String) return Binding;

   --  Check the definition of the component factory.
   procedure Check (Factory : in Factory_Bindings);

   --  ------------------------------
   --  Component Factory
   --  ------------------------------
   --  The Component_Factory is the main entry point to register bindings
   --  and resolve them when an XML file is read.
   type Component_Factory is limited private;

   --  Register a binding library in the factory.
   procedure Register (Factory  : in out Component_Factory;
                       Bindings : in Factory_Bindings_Access);

   --  Find the create function in bound to the name in the given URI name-space.
   --  Returns null if no such binding exist.
   function Find (Factory : Component_Factory;
                  URI     : String;
                  Name    : String) return Binding;

   --  ------------------------------
   --  Converter Factory
   --  ------------------------------
   --  The Converter_Factory registers the converters which can be used
   --  to convert a value into a string or the opposite.

   --  Register the converter instance under the given name.
   procedure Register (Factory   : in out Component_Factory;
                       Name      : in String;
                       Converter : in ASF.Converters.Converter_Access);

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (Factory : in Component_Factory;
                  Name    : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  ------------------------------
   --  Validator Factory
   --  ------------------------------

   --  Register the validator instance under the given name.
   procedure Register (Factory   : in out Component_Factory;
                       Name      : in String;
                       Validator : in ASF.Validators.Validator_Access);

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find (Factory : in Component_Factory;
                  Name    : in EL.Objects.Object) return ASF.Validators.Validator_Access;

private

   use Util.Strings;
   use ASF.Converters;
   use ASF.Validators;

   --  Tag library map indexed on the library namespace.
   package Factory_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Name_Access,
                                 Element_Type    => Factory_Bindings_Access,
                                 Hash            => Hash,
                                 Equivalent_Keys => Equivalent_Keys);

   --  Converter map indexed on the converter name.
   --  The key is an EL.Objects.Object to minimize the conversions when searching
   --  for a converter.
   package Converter_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => EL.Objects.Object,
                                 Element_Type    => Converter_Access,
                                 Hash            => EL.Objects.Hash,
                                 Equivalent_Keys => EL.Objects."=");

   --  Validator map indexed on the validator name.
   --  The key is an EL.Objects.Object to minimize the conversions when searching
   --  for a validator.
   package Validator_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => EL.Objects.Object,
                                 Element_Type    => Validator_Access,
                                 Hash            => EL.Objects.Hash,
                                 Equivalent_Keys => EL.Objects."=");

   type Component_Factory is limited record
      Map        : Factory_Maps.Map;
      Converters : Converter_Maps.Map;
      Validators : Validator_Maps.Map;
   end record;

end ASF.Factory;

-----------------------------------------------------------------------
--  asf-factory -- Component and tag factory
--  Copyright (C) 2009, 2010, 2011, 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 ASF.Views.Nodes;
with ASF.Converters;
with ASF.Validators;
with EL.Objects;

private with Util.Beans.Objects.Hash;
private with Ada.Containers;
private with Ada.Containers.Hashed_Maps;

--  The ASF.Factory is the main factory for building the facelet
--  node tree and defining associated component factory.  A binding library
--  must be registered before the application starts.  The binding library
--  must not be changed (this is a read-only static definition of names
--  associated with create functions).
package ASF.Factory is

   use ASF;

   --  ------------------------------
   --  List of bindings
   --  ------------------------------
   --  The binding array defines a set of XML entity names that represent
   --  a library accessible through a XML name-space.  The binding array
   --  must be sorted on the binding name.  The Check procedure will
   --  verify this assumption when the bindings are registered in the factory.
   type Binding_Array is array (Natural range <>) of aliased ASF.Views.Nodes.Binding;
   type Binding_Array_Access is access constant Binding_Array;

   type Factory_Bindings is limited record
      URI      : ASF.Views.Nodes.Name_Access;
      Bindings : Binding_Array_Access;
   end record;
   type Factory_Bindings_Access is access constant Factory_Bindings;

   --  ------------------------------
   --  Component Factory
   --  ------------------------------
   --  The Component_Factory is the main entry point to register bindings
   --  and resolve them when an XML file is read.
   type Component_Factory is limited private;

   --  Register a binding library in the factory.
   procedure Register (Factory  : in out Component_Factory;
                       Bindings : in Factory_Bindings_Access);

   --  Find the create function in bound to the name in the given URI name-space.
   --  Returns null if no such binding exist.
   function Find (Factory : in Component_Factory;
                  URI     : in String;
                  Name    : in String) return ASF.Views.Nodes.Binding_Access;

   --  ------------------------------
   --  Converter Factory
   --  ------------------------------
   --  The Converter_Factory registers the converters which can be used
   --  to convert a value into a string or the opposite.

   --  Register the converter instance under the given name.
   procedure Register (Factory   : in out Component_Factory;
                       Name      : in String;
                       Converter : in ASF.Converters.Converter_Access);

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (Factory : in Component_Factory;
                  Name    : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  ------------------------------
   --  Validator Factory
   --  ------------------------------

   --  Register the validator instance under the given name.
   procedure Register (Factory   : in out Component_Factory;
                       Name      : in String;
                       Validator : in ASF.Validators.Validator_Access);

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find (Factory : in Component_Factory;
                  Name    : in EL.Objects.Object) return ASF.Validators.Validator_Access;

private

   use ASF.Converters;
   use ASF.Validators;
   use ASF.Views.Nodes;

   --  The tag name defines a URI with the name.
   type Tag_Name is record
      URI  : ASF.Views.Nodes.Name_Access;
      Name : ASF.Views.Nodes.Name_Access;
   end record;

   --  Compute a hash for the tag name.
   function Hash (Key : in Tag_Name) return Ada.Containers.Hash_Type;

   --  Returns true if both tag names are identical.
   function "=" (Left, Right : in Tag_Name) return Boolean;

   --  Tag library map indexed on the library namespace.
   package Factory_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Tag_Name,
                                 Element_Type    => Binding_Access,
                                 Hash            => Hash,
                                 Equivalent_Keys => "=");

   --  Converter map indexed on the converter name.
   --  The key is an EL.Objects.Object to minimize the conversions when searching
   --  for a converter.
   package Converter_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => EL.Objects.Object,
                                 Element_Type    => Converter_Access,
                                 Hash            => EL.Objects.Hash,
                                 Equivalent_Keys => EL.Objects."=");

   --  Validator map indexed on the validator name.
   --  The key is an EL.Objects.Object to minimize the conversions when searching
   --  for a validator.
   package Validator_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => EL.Objects.Object,
                                 Element_Type    => Validator_Access,
                                 Hash            => EL.Objects.Hash,
                                 Equivalent_Keys => EL.Objects."=");

   type Component_Factory is limited record
      Map        : Factory_Maps.Map;
      Converters : Converter_Maps.Map;
      Validators : Validator_Maps.Map;
   end record;

end ASF.Factory;

Change the component factory to store each binding and resolve in one search the component binding from the namespace and the name


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

with EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

end EL.Beans;

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

with EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is interface and Readonly_Bean;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Get the element at the given index.
   function Get_Row (From  : List_Bean;
                     Index : Natural) return EL.Objects.Object is abstract;

end EL.Beans;

Declare the List_Bean to represent lists that can be accessed from the Object


-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Index = MAT.Events.MSG_MALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Index = MAT.Events.MSG_REALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Alloc_Size + Event.Old_Size;
            else
               Info.Free_Size := Info.Alloc_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  MAT.Events.Tools.Collect_Info (Info, Event);
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Positive;
                          Exact  : in Boolean;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
            First     : Natural;
            Last      : Natural;
         begin
            if Exact then
               First := Depth;
            else
               First := Backtrace'First;
            end if;
            if Depth < Backtrace'Last then
               Last := Depth;
            else
               Last := Backtrace'Last;
            end if;
            for I in First .. Last loop
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Count := 0;
                        MAT.Events.Tools.Collect_Info (Info, Event);
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  MAT.Events.Tools.Collect_Info (Info, Event);
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Positive;
                          Exact  : in Boolean;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
            First     : Natural;
            Last      : Natural;
         begin
            if Exact then
               First := Depth;
            else
               First := Backtrace'First;
            end if;
            if Depth < Backtrace'Last then
               Last := Depth;
            else
               Last := Backtrace'Last;
            end if;
            for I in First .. Last loop
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Count := 0;
                        MAT.Events.Tools.Collect_Info (Info, Event);
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

Fix Update_Size to use the Collect_Info procedure to gather the size statistics


--  Copyright (c) 2018 onox <denkpadje@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;
with Ada.Text_IO;

with Orka.Futures;
with Orka.Jobs;
with Orka_Test.Package_9_Jobs;

procedure Orka_Test.Test_9_Jobs is
   Job_0 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 0);
   Job_1 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 1);
   Job_2 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 2);

   Job_3 : constant Orka.Jobs.Parallel_Job_Ptr := new Package_9_Jobs.Test_Parallel_Job;
   Job_4 : constant Orka.Jobs.Job_Ptr := Orka.Jobs.Parallelize (Job_3, 24, 6);

   Future : Orka.Futures.Pointers.Mutable_Pointer;
   Status : Orka.Futures.Status;

   use Ada.Real_Time;
   use Ada.Text_IO;

   T1, T2 : Time;

   package Boss renames Package_9_Jobs.Boss;
begin
   --  Graph: Job_0 --> Job_1 --> Job_4 (4 slices) --> Job_2
   Job_1.Set_Dependencies ((1 => Job_0));
   Job_4.Set_Dependencies ((1 => Job_1));
   Job_2.Set_Dependencies ((1 => Job_4));

   Package_9_Jobs.Boss.Queue.Enqueue (Job_0, Future);
   Put_Line ("References (2): " & Future.References'Image);

   T1 := Clock;
   declare
      Reference : Orka.Futures.Pointers.Reference := Future.Get;
      Future : constant Orka.Futures.Future_Access := Reference.Value;
   begin
      select
         Future.Wait_Until_Done (Status);
         T2 := Clock;
         Put_Line ("   Status: " & Status'Image);
         Put_Line ("   Time:  " & Duration'Image (1e3 * To_Duration (T2 - T1)) & " ms");
      or
         delay until Clock + Milliseconds (10);
         Put_Line ("   Time out: " & Reference.Current_Status'Image);
      end select;
   end;
   Put_Line ("References (1): " & Future.References'Image);

   Boss.Shutdown;

   Put_Line ("CPU Queue:   " & Boss.Queue.Length (Boss.Queues.CPU)'Image);
   Put_Line ("GPU Queue:   " & Boss.Queue.Length (Boss.Queues.GPU)'Image);
end Orka_Test.Test_9_Jobs;

--  Copyright (c) 2018 onox <denkpadje@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.Exceptions;
with Ada.Real_Time;
with Ada.Text_IO;

with Orka.Futures;
with Orka.Jobs;
with Orka_Test.Package_9_Jobs;

procedure Orka_Test.Test_9_Jobs is
   Job_0 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 0);
   Job_1 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 1);
   Job_2 : constant Orka.Jobs.Job_Ptr := new Package_9_Jobs.Test_Sequential_Job'
     (Orka.Jobs.Abstract_Job with ID => 2);

   Job_3 : constant Orka.Jobs.Parallel_Job_Ptr := new Package_9_Jobs.Test_Parallel_Job;
   Job_4 : constant Orka.Jobs.Job_Ptr := Orka.Jobs.Parallelize (Job_3, 24, 6);

   Handle : Orka.Futures.Pointers.Mutable_Pointer;
   Status : Orka.Futures.Status;

   use Ada.Exceptions;
   use Ada.Real_Time;
   use Ada.Text_IO;

   T1, T2 : Time;

   package Boss renames Package_9_Jobs.Boss;
begin
   --  Graph: Job_0 --> Job_1 --> Job_4 (4 slices) --> Job_2
   Orka.Jobs.Chain ((Job_0, Job_1, Job_4, Job_2));

   Package_9_Jobs.Boss.Queue.Enqueue (Job_0, Handle);
   Put_Line ("References (2): " & Handle.References'Image);

   T1 := Clock;
   declare
      Reference : constant Orka.Futures.Pointers.Reference := Handle.Get;
      Future    : constant Orka.Futures.Future_Access      := Reference.Value;
   begin
      select
         Future.Wait_Until_Done (Status);
         T2 := Clock;
         Put_Line ("   Status: " & Status'Image);
         Put_Line ("   Time:  " & Duration'Image (1e3 * To_Duration (T2 - T1)) & " ms");
      or
         delay until T1 + Milliseconds (10);
         Put_Line ("   Time out: " & Reference.Current_Status'Image);
      end select;
   exception
      when Error : others =>
         Put_Line ("Error: " & Exception_Information (Error));
   end;
   Put_Line ("References (1): " & Handle.References'Image);

   Boss.Shutdown;

   Put_Line ("CPU Queue:   " & Boss.Queue.Length (Boss.Queues.CPU)'Image);
   Put_Line ("GPU Queue:   " & Boss.Queue.Length (Boss.Queues.GPU)'Image);
end Orka_Test.Test_9_Jobs;

examples: Use Orka.Jobs.Chain in job graph example

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with AWS.Session;
with AWS.Messages;
with AWS.Templates;
with AWS.Services.Web_Block.Registry;

with Util.Log.Loggers;
package body Auth_CB is

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

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   USER_INFO_ATTRIBUTE    : constant String := "user-info";

   Null_Association : Security.Auth.Association;
   Null_Auth        : Security.Auth.Authentication;

   package Auth_Session is
     new AWS.Session.Generic_Data (Security.Auth.Association, Null_Association);

   package User_Session is
     new AWS.Session.Generic_Data (Security.Auth.Authentication, Null_Auth);

   overriding
   function Get_Parameter (Params : in Auth_Config;
                           Name   : in String) return String is
   begin
      if Params.Exists (Name) then
         return Params.Get (Name);
      else
         return "";
      end if;
   end Get_Parameter;

   function Get_Auth_Name (Request : in AWS.Status.Data) return String is
      URI  : constant String := AWS.Status.URI (Request);
      Pos  : constant Natural := Ada.Strings.Fixed.Index (URI, "/", Ada.Strings.Backward);
   begin
      if Pos = 0 then
         return "";
      else
         Log.Info ("OpenID authentication with {0}", URI);
         return URI (Pos + 1 .. URI'Last);
      end if;
   end Get_Auth_Name;

   --  ------------------------------
   --  Implement the first step of authentication: discover the OpenID (if any) provider,
   --  create the authorization request and redirect the user to the authorization server.
   --  Some authorization data is saved in the session for the verify process.
   --  ------------------------------
   function Get_Authorization (Request : in AWS.Status.Data) return AWS.Response.Data is
      Name     : constant String := Get_Auth_Name (Request);
      Provider : constant String := Config.Get_Parameter ("auth.provider." & Name);
      URL      : constant String := Config.Get_Parameter ("auth.url." & Name);
      Mgr      : Security.Auth.Manager;
      OP       : Security.Auth.End_Point;
      Assoc    : Security.Auth.Association;
   begin
      if URL'Length = 0 or Provider'Length = 0 then
         return AWS.Response.URL (Location => "/login.html");
      end if;

      Mgr.Initialize (Config, Provider);

      --  Yadis discovery (get the XRDS file).  This step does nothing for OAuth.
      Mgr.Discover (URL, OP);

      --  Associate to the OpenID provider and get an end-point with a key.
      Mgr.Associate (OP, Assoc);

      --  Save the association in the HTTP session and
      --  redirect the user to the OpenID provider.
      declare
         Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc);
         SID      : constant AWS.Session.Id := AWS.Status.Session (Request);
      begin
         Log.Info ("Redirect to auth URL: {0}", Auth_URL);

         Auth_Session.Set (SID, OPENID_ASSOC_ATTRIBUTE, Assoc);
         return AWS.Response.URL (Location => Auth_URL);
      end;
   end Get_Authorization;

   --  ------------------------------
   --  Second step of authentication: verify the authorization response.  The authorization
   --  data saved in the session is extracted and checked against the response.  If it matches
   --  the response is verified to check if the authentication succeeded or not.
   --  The user is then redirected to the success page.
   --  ------------------------------
   function Verify_Authorization (Request : in AWS.Status.Data) return AWS.Response.Data is

      use type Security.Auth.Auth_Result;

      --  Give access to the request parameters.
      type Auth_Params is limited new Security.Auth.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return AWS.Status.Parameter (Request, Name);
      end Get_Parameter;

      Mgr        : Security.Auth.Manager;
      Assoc      : Security.Auth.Association;
      Credential : Security.Auth.Authentication;
      Params     : Auth_Params;
      SID        : constant AWS.Session.Id := AWS.Status.Session (Request);
   begin
      Log.Info ("Verify openid authentication");

      if not AWS.Session.Exist (SID, OPENID_ASSOC_ATTRIBUTE) then
         Log.Warn ("Session has expired during OpenID authentication process");
         return AWS.Response.Build ("text/html", "Session has expired", AWS.Messages.S403);
      end if;

      Assoc := Auth_Session.Get (SID, OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      AWS.Session.Remove (SID, OPENID_ASSOC_ATTRIBUTE);

      Mgr.Initialize (Provider => Security.Auth.Get_Provider (Assoc),
                      Params   => Config);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc, Params, Credential);
      if Security.Auth.Get_Status (Credential) /= Security.Auth.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         return AWS.Response.Build ("text/html", "Authentication failed", AWS.Messages.S403);
      end if;

      Log.Info ("Authentication succeeded for {0}", Security.Auth.Get_Email (Credential));

      Log.Info ("Claimed id: {0}", Security.Auth.Get_Claimed_Id (Credential));
      Log.Info ("Email:      {0}", Security.Auth.Get_Email (Credential));
      Log.Info ("Name:       {0}", Security.Auth.Get_Full_Name (Credential));

      --  Save the user information in the session (for the purpose of this demo).
      User_Session.Set (SID, USER_INFO_ATTRIBUTE, Credential);

      declare
         URL  : constant String := Config.Get_Parameter ("openid.success_url");
      begin
         Log.Info ("Redirect user to success URL: {0}", URL);

         return AWS.Response.URL (Location => URL);
      end;
   end Verify_Authorization;

   function User_Info (Request : in AWS.Status.Data) return AWS.Response.Data is
      URI        : constant String := AWS.Status.URI (Request);
      SID        : constant AWS.Session.Id := AWS.Status.Session (Request);
      Credential : Security.Auth.Authentication;
      Set        : AWS.Templates.Translate_Set;
   begin
      if AWS.Session.Exist (SID, USER_INFO_ATTRIBUTE) then
         Credential := User_Session.Get (SID, USER_INFO_ATTRIBUTE);
         AWS.Templates.Insert (Set,
           AWS.Templates.Assoc ("ID",
             Security.Auth.Get_Claimed_Id (Credential)));
         AWS.Templates.Insert (Set, AWS.Templates.Assoc ("EMAIL",
           Security.Auth.Get_Email (Credential)));
         AWS.Templates.Insert (Set, AWS.Templates.Assoc ("NAME",
           Security.Auth.Get_Full_Name (Credential)));
      end if;
      return AWS.Services.Web_Block.Registry.Build ("success", Request, Set);
   end User_Info;

end Auth_CB;

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

with AWS.Session;
with AWS.Messages;
with AWS.Templates;
with AWS.Services.Web_Block.Registry;

with Util.Log.Loggers;
package body Auth_CB is

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

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   USER_INFO_ATTRIBUTE    : constant String := "user-info";

   Null_Association : Security.Auth.Association;
   Null_Auth        : Security.Auth.Authentication;

   package Auth_Session is
     new AWS.Session.Generic_Data (Security.Auth.Association, Null_Association);

   package User_Session is
     new AWS.Session.Generic_Data (Security.Auth.Authentication, Null_Auth);

   overriding
   function Get_Parameter (Params : in Auth_Config;
                           Name   : in String) return String is
   begin
      if Params.Exists (Name) then
         return Params.Get (Name);
      else
         return "";
      end if;
   end Get_Parameter;

   function Get_Auth_Name (Request : in AWS.Status.Data) return String is
      URI  : constant String := AWS.Status.URI (Request);
      Pos  : constant Natural := Ada.Strings.Fixed.Index (URI, "/", Ada.Strings.Backward);
   begin
      if Pos = 0 then
         return "";
      else
         Log.Info ("OpenID authentication with {0}", URI);
         return URI (Pos + 1 .. URI'Last);
      end if;
   end Get_Auth_Name;

   --  ------------------------------
   --  Implement the first step of authentication: discover the OpenID (if any) provider,
   --  create the authorization request and redirect the user to the authorization server.
   --  Some authorization data is saved in the session for the verify process.
   --  ------------------------------
   function Get_Authorization (Request : in AWS.Status.Data) return AWS.Response.Data is
      Name     : constant String := Get_Auth_Name (Request);
      URL      : constant String := Config.Get_Parameter ("auth.url." & Name);
      Mgr      : Security.Auth.Manager;
      OP       : Security.Auth.End_Point;
      Assoc    : Security.Auth.Association;
   begin
      if URL'Length = 0 or Name'Length = 0 then
         return AWS.Response.URL (Location => "/login.html");
      end if;

      Mgr.Initialize (Config, Name);

      --  Yadis discovery (get the XRDS file).  This step does nothing for OAuth.
      Mgr.Discover (URL, OP);

      --  Associate to the OpenID provider and get an end-point with a key.
      Mgr.Associate (OP, Assoc);

      --  Save the association in the HTTP session and
      --  redirect the user to the OpenID provider.
      declare
         Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc);
         SID      : constant AWS.Session.Id := AWS.Status.Session (Request);
      begin
         Log.Info ("Redirect to auth URL: {0}", Auth_URL);

         Auth_Session.Set (SID, OPENID_ASSOC_ATTRIBUTE, Assoc);
         return AWS.Response.URL (Location => Auth_URL);
      end;
   end Get_Authorization;

   --  ------------------------------
   --  Second step of authentication: verify the authorization response.  The authorization
   --  data saved in the session is extracted and checked against the response.  If it matches
   --  the response is verified to check if the authentication succeeded or not.
   --  The user is then redirected to the success page.
   --  ------------------------------
   function Verify_Authorization (Request : in AWS.Status.Data) return AWS.Response.Data is

      use type Security.Auth.Auth_Result;

      --  Give access to the request parameters.
      type Auth_Params is limited new Security.Auth.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return AWS.Status.Parameter (Request, Name);
      end Get_Parameter;

      Mgr        : Security.Auth.Manager;
      Assoc      : Security.Auth.Association;
      Credential : Security.Auth.Authentication;
      Params     : Auth_Params;
      SID        : constant AWS.Session.Id := AWS.Status.Session (Request);
   begin
      Log.Info ("Verify openid authentication");

      if not AWS.Session.Exist (SID, OPENID_ASSOC_ATTRIBUTE) then
         Log.Warn ("Session has expired during OpenID authentication process");
         return AWS.Response.Build ("text/html", "Session has expired", AWS.Messages.S403);
      end if;

      Assoc := Auth_Session.Get (SID, OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      AWS.Session.Remove (SID, OPENID_ASSOC_ATTRIBUTE);

      Mgr.Initialize (Name   => Security.Auth.Get_Provider (Assoc),
                      Params => Config);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc, Params, Credential);
      if Security.Auth.Get_Status (Credential) /= Security.Auth.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         return AWS.Response.Build ("text/html", "Authentication failed", AWS.Messages.S403);
      end if;

      Log.Info ("Authentication succeeded for {0}", Security.Auth.Get_Email (Credential));

      Log.Info ("Claimed id: {0}", Security.Auth.Get_Claimed_Id (Credential));
      Log.Info ("Email:      {0}", Security.Auth.Get_Email (Credential));
      Log.Info ("Name:       {0}", Security.Auth.Get_Full_Name (Credential));

      --  Save the user information in the session (for the purpose of this demo).
      User_Session.Set (SID, USER_INFO_ATTRIBUTE, Credential);

      declare
         URL  : constant String := Config.Get_Parameter ("openid.success_url");
      begin
         Log.Info ("Redirect user to success URL: {0}", URL);

         return AWS.Response.URL (Location => URL);
      end;
   end Verify_Authorization;

   function User_Info (Request : in AWS.Status.Data) return AWS.Response.Data is
      URI        : constant String := AWS.Status.URI (Request);
      SID        : constant AWS.Session.Id := AWS.Status.Session (Request);
      Credential : Security.Auth.Authentication;
      Set        : AWS.Templates.Translate_Set;
   begin
      if AWS.Session.Exist (SID, USER_INFO_ATTRIBUTE) then
         Credential := User_Session.Get (SID, USER_INFO_ATTRIBUTE);
         AWS.Templates.Insert (Set,
           AWS.Templates.Assoc ("ID",
             Security.Auth.Get_Claimed_Id (Credential)));
         AWS.Templates.Insert (Set, AWS.Templates.Assoc ("EMAIL",
           Security.Auth.Get_Email (Credential)));
         AWS.Templates.Insert (Set, AWS.Templates.Assoc ("NAME",
           Security.Auth.Get_Full_Name (Credential)));
      end if;
      return AWS.Services.Web_Block.Registry.Build ("success", Request, Set);
   end User_Info;

end Auth_CB;

Fix initialization

Fix initialization


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

with Util.Test_Caller;
package body Util.Events.Channels.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Events.Channels.Post_Event",
                       Test_Post_Event'Access);
   end Add_Tests;

   procedure Receive_Event (Sub  : in out Test;
                            Item : in Event'Class) is
      pragma Unreferenced (Item);
   begin
      Sub.Count := Sub.Count + 1;
   end Receive_Event;

   procedure Test_Post_Event (T : in out Test) is
      C  : constant Channel_Access := Create ("test", "direct");
      E  : Event;
      T1 : aliased Test;
      T2 : aliased Test;
   begin
      C.Post (E);

      Assert_Equals (T, "test", C.Get_Name, "Invalid channel name");

      C.Subscribe (T1'Unchecked_Access);
      C.Post (E);
      Assert_Equals (T, 1, T1.Count, "Invalid number of received events");
      Assert_Equals (T, 0, T2.Count, "Invalid number of events");

      C.Subscribe (T2'Unchecked_Access);
      C.Post (E);

      C.Unsubscribe (T1'Unchecked_Access);
      C.Post (E);
      Assert_Equals (T, 2, T1.Count, "Invalid number of received events");
      Assert_Equals (T, 2, T2.Count, "Invalid number of events");
   end Test_Post_Event;

end Util.Events.Channels.Tests;

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

with Ada.Unchecked_Deallocation;
with Util.Test_Caller;
package body Util.Events.Channels.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Events.Channels.Post_Event",
                       Test_Post_Event'Access);
   end Add_Tests;

   procedure Receive_Event (Sub  : in out Test;
                            Item : in Event'Class) is
      pragma Unreferenced (Item);
   begin
      Sub.Count := Sub.Count + 1;
   end Receive_Event;

   procedure Test_Post_Event (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Channel'Class,
                                         Name   => Channel_Access);

      C  : Channel_Access := Create ("test", "direct");
      E  : Event;
      T1 : aliased Test;
      T2 : aliased Test;
   begin
      C.Post (E);

      Assert_Equals (T, "test", C.Get_Name, "Invalid channel name");

      C.Subscribe (T1'Unchecked_Access);
      C.Post (E);
      Assert_Equals (T, 1, T1.Count, "Invalid number of received events");
      Assert_Equals (T, 0, T2.Count, "Invalid number of events");

      C.Subscribe (T2'Unchecked_Access);
      C.Post (E);

      C.Unsubscribe (T1'Unchecked_Access);
      C.Post (E);
      Assert_Equals (T, 2, T1.Count, "Invalid number of received events");
      Assert_Equals (T, 2, T2.Count, "Invalid number of events");

      Free (C);
   end Test_Post_Event;

end Util.Events.Channels.Tests;

Fix memory leak in the unit test

Fix memory leak in the unit test


-----------------------------------------------------------------------
--  wiki -- Ada Wiki Engine
--  Copyright (C) 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 Wiki.Attributes;
with Wiki.Documents;
with Wiki.Strings;
package Wiki.Nodes is

   pragma Preelaborate;

   subtype Format_Map is Wiki.Documents.Format_Map;
   subtype WString is Wide_Wide_String;

   type Node_Kind is (N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_PARAGRAPH,
                      N_HEADER,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_INDENT,
                      N_TEXT,
                      N_LINK);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_LINE_BREAK .. N_PARAGRAPH;

     --  The possible HTML tags as described in HTML5 specification.
   type Html_Tag_Type is
     (
      --  Section 4.1 The root element
      HTML_TAG,

      --  Section 4.2 Document metadata
      HEAD_TAG, TITLE_TAG, BASE_TAG, LINK_TAG, META_TAG, STYLE_TAG,

      --  Section 4.3 Sections
      BODY_TAG, ARTICLE_TAG, SECTION_TAG, NAV_TAG, ASIDE_TAG,
      H1_TAG, H2_TAG, H3_TAG, H4_TAG, H5_TAG, H6_TAG,
      HEADER_TAG, FOOTER_TAG,
      ADDRESS_TAG,

      --  Section 4.4 Grouping content
      P_TAG, HR_TAG, PRE_TAG, BLOCKQUOTE_TAG,
      OL_TAG, UL_TAG, LI_TAG,
      DL_TAG, DT_TAG, DD_TAG,
      FIGURE_TAG, FIGCAPTION_TAG,
      DIV_TAG, MAIN_TAG,

      --  Section 4.5 Text-level semantics
      A_TAG, EM_TAG, STRONG_TAG, SMALL_TAG,
      S_TAG, CITE_TAG, Q_TAG, DFN_TAG, ABBR_TAG,
      DATA_TAG, TIME_TAG, CODE_TAG, VAR_TAG, SAMP_TAG,
      KBD_TAG, SUB_TAG, SUP_TAG,
      I_TAG, B_TAG, U_TAG,
      MARK_TAG, RUBY_TAG, RB_TAG, RT_TAG, RTC_TAG,
      RP_TAG, BDI_TAG, BDO_TAG, SPAN_TAG,
      BR_TAG, WBR_TAG,

      --  Section 4.6 Edits
      INS_TAG, DEL_TAG,

      --  Section 4.7 Embedded content
      IMG_TAG,
      IFRAME_TAG,
      EMBED_TAG,
      OBJECT_TAG,
      PARAM_TAG,
      VIDEO_TAG,
      AUDIO_TAG,
      SOURCE_TAG,
      TRACK_TAG,
      MAP_TAG,
      AREA_TAG,

      --  Section 4.9 Tabular data
      TABLE_TAG, CAPTION_TAG, COLGROUP_TAG, COL_TAG,
      TBODY_TAG, THEAD_TAG, TFOOT_TAG,
      TR_TAG, TD_TAG, TH_TAG,

      --  Section 4.10 Forms
      FORM_TAG, LABEL_TAG, INPUT_TAG,
      BUTTON_TAG, SELECT_TAG, DATALIST_TAG, OPTGROUP_TAG,
      OPTION_TAG, TEXTAREA_TAG, KEYGEN_TAG, OUTPUT_TAG,
      PROGRESS_TAG, METER_TAG, FIELDSET_TAG, LEGEND_TAG,

      --  Section 4.11 Scripting
      SCRIPT_TAG, NOSCRIPT_TAG,
      TEMPLATE_TAG, CANVAS_TAG,

      --  Unknown tags
      UNKNOWN_TAG
     );

   --  Find the tag from the tag name.
   function Find_Tag (Name : in Wide_Wide_String) return Html_Tag_Type;

   type String_Access is access constant String;

   --  Get the HTML tag name.
   function Get_Tag_Name (Tag : in Html_Tag_Type) return String_Access;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT =>
            Level  : Natural := 0;
            Header : WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : WString (1 .. Len);

         when N_LINK =>
            Image      : Boolean;
            Link_Attr  : Wiki.Attributes.Attribute_List_Type;
            Title      : WString (1 .. Len);

         when N_QUOTE =>
            Quote_Attr : Wiki.Attributes.Attribute_List_Type;
            Quote      : WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag_Type;
            Attributes : Wiki.Attributes.Attribute_List_Type;
            Children   : Node_List_Access;
            Parent     : Node_Type_Access;

         when others =>
            null;

      end case;
   end record;

   --  Create a text node.
   function Create_Text (Text : in WString) return Node_Type_Access;

   type Document is limited private;

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Node_Type_Access);

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Document   : in out Wiki.Nodes.Document;
                        Tag        : in Html_Tag_Type;
                        Attributes : in Wiki.Attributes.Attribute_List_Type);

   --  Pop the HTML tag.
   procedure Pop_Node (Document : in out Wiki.Nodes.Document;
                       Tag      : in Html_Tag_Type);

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --     procedure Add_Text (Doc  : in out Document;
--                         Text : in WString);

--     type Renderer is limited interface;
--
--     procedure Render (Engine : in out Renderer;
--                       Doc    : in Document;
--                       Node   : in Node_Type) is abstract;
--
--     procedure Iterate (Doc     : in Document;
--                        Process : access procedure (Doc : in Document; Node : in Node_Type)) is
--        Node : Document_Node_Access := Doc.First;
--     begin
--        while Node /= null loop
--           Process (Doc, Node.Data);
--           Node := Node.Next;
--        end loop;
--     end Iterate;

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 20;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

   --  Append a node to the node list.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   type Document is limited record
      Nodes   : Node_List;
      Current : Node_Type_Access;
   end record;

end Wiki.Nodes;

-----------------------------------------------------------------------
--  wiki -- Ada Wiki Engine
--  Copyright (C) 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 Wiki.Attributes;
with Wiki.Documents;
with Wiki.Strings;
package Wiki.Nodes is

   pragma Preelaborate;

   subtype Format_Map is Wiki.Documents.Format_Map;
   subtype WString is Wide_Wide_String;

   type Node_Kind is (N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_PARAGRAPH,
                      N_HEADER,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_INDENT,
                      N_TEXT,
                      N_LINK);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_LINE_BREAK .. N_PARAGRAPH;

     --  The possible HTML tags as described in HTML5 specification.
   type Html_Tag_Type is
     (
      --  Section 4.1 The root element
      HTML_TAG,

      --  Section 4.2 Document metadata
      HEAD_TAG, TITLE_TAG, BASE_TAG, LINK_TAG, META_TAG, STYLE_TAG,

      --  Section 4.3 Sections
      BODY_TAG, ARTICLE_TAG, SECTION_TAG, NAV_TAG, ASIDE_TAG,
      H1_TAG, H2_TAG, H3_TAG, H4_TAG, H5_TAG, H6_TAG,
      HEADER_TAG, FOOTER_TAG,
      ADDRESS_TAG,

      --  Section 4.4 Grouping content
      P_TAG, HR_TAG, PRE_TAG, BLOCKQUOTE_TAG,
      OL_TAG, UL_TAG, LI_TAG,
      DL_TAG, DT_TAG, DD_TAG,
      FIGURE_TAG, FIGCAPTION_TAG,
      DIV_TAG, MAIN_TAG,

      --  Section 4.5 Text-level semantics
      A_TAG, EM_TAG, STRONG_TAG, SMALL_TAG,
      S_TAG, CITE_TAG, Q_TAG, DFN_TAG, ABBR_TAG,
      DATA_TAG, TIME_TAG, CODE_TAG, VAR_TAG, SAMP_TAG,
      KBD_TAG, SUB_TAG, SUP_TAG,
      I_TAG, B_TAG, U_TAG,
      MARK_TAG, RUBY_TAG, RB_TAG, RT_TAG, RTC_TAG,
      RP_TAG, BDI_TAG, BDO_TAG, SPAN_TAG,
      BR_TAG, WBR_TAG,

      --  Section 4.6 Edits
      INS_TAG, DEL_TAG,

      --  Section 4.7 Embedded content
      IMG_TAG,
      IFRAME_TAG,
      EMBED_TAG,
      OBJECT_TAG,
      PARAM_TAG,
      VIDEO_TAG,
      AUDIO_TAG,
      SOURCE_TAG,
      TRACK_TAG,
      MAP_TAG,
      AREA_TAG,

      --  Section 4.9 Tabular data
      TABLE_TAG, CAPTION_TAG, COLGROUP_TAG, COL_TAG,
      TBODY_TAG, THEAD_TAG, TFOOT_TAG,
      TR_TAG, TD_TAG, TH_TAG,

      --  Section 4.10 Forms
      FORM_TAG, LABEL_TAG, INPUT_TAG,
      BUTTON_TAG, SELECT_TAG, DATALIST_TAG, OPTGROUP_TAG,
      OPTION_TAG, TEXTAREA_TAG, KEYGEN_TAG, OUTPUT_TAG,
      PROGRESS_TAG, METER_TAG, FIELDSET_TAG, LEGEND_TAG,

      --  Section 4.11 Scripting
      SCRIPT_TAG, NOSCRIPT_TAG,
      TEMPLATE_TAG, CANVAS_TAG,

      --  Unknown tags
      UNKNOWN_TAG
     );

   --  Find the tag from the tag name.
   function Find_Tag (Name : in Wide_Wide_String) return Html_Tag_Type;

   type String_Access is access constant String;

   --  Get the HTML tag name.
   function Get_Tag_Name (Tag : in Html_Tag_Type) return String_Access;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT =>
            Level  : Natural := 0;
            Header : WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : WString (1 .. Len);

         when N_LINK =>
            Image      : Boolean;
            Link_Attr  : Wiki.Attributes.Attribute_List_Type;
            Title      : WString (1 .. Len);

         when N_QUOTE =>
            Quote_Attr : Wiki.Attributes.Attribute_List_Type;
            Quote      : WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag_Type;
            Attributes : Wiki.Attributes.Attribute_List_Type;
            Children   : Node_List_Access;
            Parent     : Node_Type_Access;

         when others =>
            null;

      end case;
   end record;

   --  Create a text node.
   function Create_Text (Text : in WString) return Node_Type_Access;

   type Document is limited private;

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Node_Type_Access);

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Document   : in out Wiki.Nodes.Document;
                        Tag        : in Html_Tag_Type;
                        Attributes : in Wiki.Attributes.Attribute_List_Type);

   --  Pop the HTML tag.
   procedure Pop_Node (Document : in out Wiki.Nodes.Document;
                       Tag      : in Html_Tag_Type);

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List_Type);

   --     procedure Add_Text (Doc  : in out Document;
--                         Text : in WString);

--     type Renderer is limited interface;
--
--     procedure Render (Engine : in out Renderer;
--                       Doc    : in Document;
--                       Node   : in Node_Type) is abstract;
--
--     procedure Iterate (Doc     : in Document;
--                        Process : access procedure (Doc : in Document; Node : in Node_Type)) is
--        Node : Document_Node_Access := Doc.First;
--     begin
--        while Node /= null loop
--           Process (Doc, Node.Data);
--           Node := Node.Next;
--        end loop;
--     end Iterate;

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 20;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

   --  Append a node to the node list.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   type Document is limited record
      Nodes   : Node_List;
      Current : Node_Type_Access;
   end record;

end Wiki.Nodes;

Declare the Add_Link procedure

Declare the Add_Link procedure


-----------------------------------------------------------------------
--  mat-memory-tools - Tools for memory maps
--  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.Ordered_Maps;

package MAT.Memory.Tools is

   type Size_Info_Type is record
      Count : Natural;
   end record;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

   --  Collect the information about memory slot sizes for the memory slots in the map.
   procedure Size_Information (Memory : in MAT.Memory.Allocation_Map;
                               Sizes  : in out Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in MAT.Memory.Allocation_Map;
                                 Threads : in out Memory_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
   --  it does not already contains the memory slot.
   procedure Find (Memory : in MAT.Memory.Allocation_Map;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Allocation_Map);

end MAT.Memory.Tools;

-----------------------------------------------------------------------
--  mat-memory-tools - Tools for memory maps
--  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.Ordered_Maps;

with MAT.Expressions;
package MAT.Memory.Tools is

   type Size_Info_Type is record
      Count : Natural;
   end record;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

   --  Collect the information about memory slot sizes for the memory slots in the map.
   procedure Size_Information (Memory : in MAT.Memory.Allocation_Map;
                               Sizes  : in out Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in MAT.Memory.Allocation_Map;
                                 Threads : in out Memory_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in MAT.Memory.Allocation_Map;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

end MAT.Memory.Tools;

Add a filter expression to the Find procedure


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

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

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

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

   procedure Save (Bean : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Manager : constant Services.Question_Service_Access := Bean.Module.Get_Question_Manager;
   begin
      Manager.Save_Question (Bean);
   end Save;

   procedure Delete (Bean : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

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

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

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      Object  : constant Question_Info_List_Bean_Access := new Question_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      AWA.Questions.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Question_List_Bean;

end AWA.Questions.Beans;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      Object  : constant Question_Info_List_Bean_Access := new Question_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      AWA.Questions.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Question_List_Bean;

end AWA.Questions.Beans;

Implement the answer bean

Implement the answer bean