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

with ASF.Events.Phases;
with ASF.Components.Base;
with ASF.Events.Faces.Actions;
with ASF.Applications.Main;

package body ASF.Components.Core.Views is

   use ASF;
   use EL.Objects;
   use type Base.UIComponent_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Events.Faces.Faces_Event'Class,
                                     Name   => Faces_Event_Access);

   --  ------------------------------
   --  Get the content type returned by the view.
   --  ------------------------------
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String is
   begin
      if Util.Beans.Objects.Is_Null (UI.Content_Type) then
         return UI.Get_Attribute (Name => "contentType", Context => Context);
      else
         return Util.Beans.Objects.To_String (UI.Content_Type);
      end if;
   end Get_Content_Type;

   --  ------------------------------
   --  Set the content type returned by the view.
   --  ------------------------------
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String) is
   begin
      UI.Content_Type := Util.Beans.Objects.To_Object (Value);
   end Set_Content_Type;

   --  ------------------------------
   --  Get the locale to be used when rendering messages in the view.
   --  If a locale was set explicitly, return it.
   --  If the view component defines a locale attribute, evaluate and return its value.
   --  If the locale is empty, calculate the locale by using the request context and the view
   --  handler.
   --  ------------------------------
   function Get_Locale (UI      : in UIView;
                        Context : in Faces_Context'Class) return Util.Locales.Locale is
      use type Util.Locales.Locale;
   begin
      if UI.Locale /= Util.Locales.NULL_LOCALE then
         return UI.Locale;
      end if;
      declare
         Value : constant Util.Beans.Objects.Object := UI.Get_Attribute (Name    => "locale",
                                                                         Context => Context);
      begin
         --  If the root view does not specify any locale, calculate it from the request.
         if Util.Beans.Objects.Is_Null (Value) then
            return Context.Get_Application.Get_View_Handler.Calculate_Locale (Context);
         end if;

         --  Resolve the locale.  If it is not valid, calculate it from the request.
         declare
            Name   : constant String := Util.Beans.Objects.To_String (Value);
            Locale : constant Util.Locales.Locale := Util.Locales.Get_Locale (Name);
         begin
            if Locale /= Util.Locales.NULL_LOCALE then
               return Locale;
            else
               return Context.Get_Application.Get_View_Handler.Calculate_Locale (Context);
            end if;
         end;
      end;
   end Get_Locale;

   --  ------------------------------
   --  Set the locale to be used when rendering messages in the view.
   --  ------------------------------
   procedure Set_Locale (UI     : in out UIView;
                         Locale : in Util.Locales.Locale) is
   begin
      UI.Locale := Locale;
   end Set_Locale;

   --  ------------------------------
   --  Encode the begining of the view.  Set the response content type.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class) is
      Content_Type : constant String := UI.Get_Content_Type (Context => Context);
   begin
      Context.Get_Response.Set_Content_Type (Content_Type);
      if UI.Left_Tree /= null then
         UI.Left_Tree.Encode_All (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Encode the end of the view.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIView;
                         Context : in out Faces_Context'Class) is
   begin
      if UI.Right_Tree /= null then
         UI.Right_Tree.Encode_All (Context);
      end if;
   end Encode_End;

   --  ------------------------------
   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Decodes (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.APPLY_REQUEST_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Decodes;

   --  ------------------------------
   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Validators (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.PROCESS_VALIDATION, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Validators;

   --  ------------------------------
   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Updates (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.UPDATE_MODEL_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Updates;

   --  ------------------------------
   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   --  ------------------------------
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class) is
   begin
      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.INVOKE_APPLICATION, Context);
   end Process_Application;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         Parent.Queue_Event (Event);
      else
         UI.Phase_Events (Event.Get_Phase).Append (Event.all'Access);
      end if;
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is

      Pos : Natural := 0;

      --  Broadcast the event to the component's listeners
      --  and free that event.
      procedure Broadcast (Ev : in out Faces_Event_Access);

      procedure Broadcast (Ev : in out Faces_Event_Access) is
      begin
         if Ev /= null then
            declare
               C  : constant Base.UIComponent_Access := Ev.Get_Component;
            begin
               C.Broadcast (Ev, Context);
            end;
            Free (Ev);
         end if;
      end Broadcast;

      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         UIView'Class (Parent.all).Broadcast (Phase, Context);
      else
         --  Dispatch events in the order in which they were queued.
         --  More events could be queued as a result of the dispatch.
         --  After dispatching an event, it is freed but not removed
         --  from the event queue (the access will be cleared).
         loop
            exit when Pos > UI.Phase_Events (Phase).Last_Index;
            UI.Phase_Events (Phase).Update_Element (Pos, Broadcast'Access);
            Pos := Pos + 1;
         end loop;

         --  Now, clear the queue.
         UI.Phase_Events (Phase).Clear;
      end if;
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   procedure Clear_Events (UI : in out UIView) is
   begin
      for Phase in UI.Phase_Events'Range loop
         for I in 0 .. UI.Phase_Events (Phase).Last_Index loop
            declare
               Ev : Faces_Event_Access := UI.Phase_Events (Phase).Element (I);
            begin
               Free (Ev);
            end;
         end loop;
         UI.Phase_Events (Phase).Clear;
      end loop;
   end Clear_Events;

   --  ------------------------------
   --  Set the component tree that must be rendered before this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   --  ------------------------------
   procedure Set_Before_View (UI   : in out UIView'Class;
                              Tree : in Base.UIComponent_Access) is
   begin
      if UI.Left_Tree /= null then
         UI.Log_Error ("Set_Before_View called while there is a tree");
      end if;
      UI.Left_Tree := Tree;
   end Set_Before_View;

   --  ------------------------------
   --  Set the component tree that must be rendered after this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   --  ------------------------------
   procedure Set_After_View (UI   : in out UIView'Class;
                             Tree : in Base.UIComponent_Access) is
   begin
      if UI.Right_Tree /= null then
         UI.Log_Error ("Set_Before_View called while there is a tree");
      end if;
      UI.Right_Tree := Tree;
   end Set_After_View;

   --  ------------------------------
   --  Finalize the object.
   --  ------------------------------
   overriding
   procedure Finalize (UI : in out UIView) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Base.UIComponent'Class,
                                        Name   => Base.UIComponent_Access);

   begin
      Free (UI.Left_Tree);
      Free (UI.Right_Tree);
      Base.UIComponent (UI).Finalize;
   end Finalize;

   --  ------------------------------
   --  Set the metadata facet on the UIView component.
   --  ------------------------------
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      if UI.Meta /= null then
         UI.Log_Error ("A <f:metadata> component was already registered.");
--           Delete (UI.Meta);
      end if;
      Meta.Root := UI'Unchecked_Access;
      UI.Meta := Meta;
      UI.Add_Facet (METADATA_FACET_NAME, Meta.all'Access, Tag);
   end Set_Metadata;

   --  ------------------------------
   --  Decode the request and prepare for the execution for the view action.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      begin
         ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                              Method => UI.Get_Action_Expression (Context));

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Process_Decodes;

   --  ------------------------------
   --  Get the root component.
   --  ------------------------------
   function Get_Root (UI      : in UIViewMetaData) return Base.UIComponent_Access is
      Result : Base.UIComponent_Access := UI.Get_Parent;
      Parent : Base.UIComponent_Access := Result.Get_Parent;
   begin
      while Parent /= null loop
         Result := Parent;
         Parent := Parent.Get_Parent;
      end loop;
      return Result;
   end Get_Root;

   --  ------------------------------
   --  Start encoding the UIComponent.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_Begin (Context);
   end Encode_Begin;

   --  ------------------------------
   --  Encode the children of this component.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_Children (Context);
   end Encode_Children;

   --  ------------------------------
   --  Finish encoding the component.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_End (Context);
   end Encode_End;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
   begin
      UI.Root.Queue_Event (Event);
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is
   begin
      UI.Root.Broadcast (Phase, Context);
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData) is
   begin
      UI.Root.Clear_Events;
   end Clear_Events;

end ASF.Components.Core.Views;

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

with ASF.Events.Phases;
with ASF.Components.Base;
with ASF.Events.Faces.Actions;
with ASF.Applications.Main;

package body ASF.Components.Core.Views is

   use ASF;
   use EL.Objects;
   use type Base.UIComponent_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Events.Faces.Faces_Event'Class,
                                     Name   => Faces_Event_Access);

   --  ------------------------------
   --  Get the content type returned by the view.
   --  ------------------------------
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String is
   begin
      if Util.Beans.Objects.Is_Null (UI.Content_Type) then
         return UI.Get_Attribute (Name => "contentType", Context => Context);
      else
         return Util.Beans.Objects.To_String (UI.Content_Type);
      end if;
   end Get_Content_Type;

   --  ------------------------------
   --  Set the content type returned by the view.
   --  ------------------------------
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String) is
   begin
      UI.Content_Type := Util.Beans.Objects.To_Object (Value);
   end Set_Content_Type;

   --  ------------------------------
   --  Get the locale to be used when rendering messages in the view.
   --  If a locale was set explicitly, return it.
   --  If the view component defines a locale attribute, evaluate and return its value.
   --  If the locale is empty, calculate the locale by using the request context and the view
   --  handler.
   --  ------------------------------
   function Get_Locale (UI      : in UIView;
                        Context : in Faces_Context'Class) return Util.Locales.Locale is
      use type Util.Locales.Locale;
   begin
      if UI.Locale /= Util.Locales.NULL_LOCALE then
         return UI.Locale;
      end if;
      declare
         Value : constant Util.Beans.Objects.Object := UI.Get_Attribute (Name    => "locale",
                                                                         Context => Context);
      begin
         --  If the root view does not specify any locale, calculate it from the request.
         if Util.Beans.Objects.Is_Null (Value) then
            return Context.Get_Application.Get_View_Handler.Calculate_Locale (Context);
         end if;

         --  Resolve the locale.  If it is not valid, calculate it from the request.
         declare
            Name   : constant String := Util.Beans.Objects.To_String (Value);
            Locale : constant Util.Locales.Locale := Util.Locales.Get_Locale (Name);
         begin
            if Locale /= Util.Locales.NULL_LOCALE then
               return Locale;
            else
               return Context.Get_Application.Get_View_Handler.Calculate_Locale (Context);
            end if;
         end;
      end;
   end Get_Locale;

   --  ------------------------------
   --  Set the locale to be used when rendering messages in the view.
   --  ------------------------------
   procedure Set_Locale (UI     : in out UIView;
                         Locale : in Util.Locales.Locale) is
   begin
      UI.Locale := Locale;
   end Set_Locale;

   --  ------------------------------
   --  Encode the begining of the view.  Set the response content type.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class) is
      Content_Type : constant String := UI.Get_Content_Type (Context => Context);
   begin
      Context.Get_Response.Set_Content_Type (Content_Type);
      if UI.Left_Tree /= null then
         UI.Left_Tree.Encode_All (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Encode the end of the view.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIView;
                         Context : in out Faces_Context'Class) is
   begin
      if UI.Right_Tree /= null then
         UI.Right_Tree.Encode_All (Context);
      end if;
   end Encode_End;

   --  ------------------------------
   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Decodes (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.APPLY_REQUEST_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Decodes;

   --  ------------------------------
   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Validators (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.PROCESS_VALIDATION, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Validators;

   --  ------------------------------
   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   --  ------------------------------
   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class) is
   begin
      Base.UIComponent (UI).Process_Updates (Context);

      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.UPDATE_MODEL_VALUES, Context);

      --  Drop other events if the response is to be returned.
      if Context.Get_Render_Response or Context.Get_Response_Completed then
         UIView'Class (UI).Clear_Events;
      end if;
   end Process_Updates;

   --  ------------------------------
   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   --  ------------------------------
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class) is
   begin
      --  Dispatch events queued for this phase.
      UIView'Class (UI).Broadcast (ASF.Events.Phases.INVOKE_APPLICATION, Context);
   end Process_Application;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         Parent.Queue_Event (Event);
      else
         UI.Phase_Events (Event.Get_Phase).Append (Event.all'Access);
      end if;
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is

      Pos : Natural := 0;

      --  Broadcast the event to the component's listeners
      --  and free that event.
      procedure Broadcast (Ev : in out Faces_Event_Access);

      procedure Broadcast (Ev : in out Faces_Event_Access) is
      begin
         if Ev /= null then
            declare
               C  : constant Base.UIComponent_Access := Ev.Get_Component;
            begin
               C.Broadcast (Ev, Context);
            end;
            Free (Ev);
         end if;
      end Broadcast;

      Parent : constant Base.UIComponent_Access := UI.Get_Parent;
   begin
      if Parent /= null then
         UIView'Class (Parent.all).Broadcast (Phase, Context);
      else
         --  Dispatch events in the order in which they were queued.
         --  More events could be queued as a result of the dispatch.
         --  After dispatching an event, it is freed but not removed
         --  from the event queue (the access will be cleared).
         loop
            exit when Pos > UI.Phase_Events (Phase).Last_Index;
            UI.Phase_Events (Phase).Update_Element (Pos, Broadcast'Access);
            Pos := Pos + 1;
         end loop;

         --  Now, clear the queue.
         UI.Phase_Events (Phase).Clear;
      end if;
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   procedure Clear_Events (UI : in out UIView) is
   begin
      for Phase in UI.Phase_Events'Range loop
         for I in 0 .. UI.Phase_Events (Phase).Last_Index loop
            declare
               Ev : Faces_Event_Access := UI.Phase_Events (Phase).Element (I);
            begin
               Free (Ev);
            end;
         end loop;
         UI.Phase_Events (Phase).Clear;
      end loop;
   end Clear_Events;

   --  ------------------------------
   --  Set the component tree that must be rendered before this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   --  ------------------------------
   procedure Set_Before_View (UI   : in out UIView'Class;
                              Tree : in Base.UIComponent_Access) is
   begin
      if UI.Left_Tree /= null then
         UI.Log_Error ("Set_Before_View called while there is a tree");
      end if;
      UI.Left_Tree := Tree;
   end Set_Before_View;

   --  ------------------------------
   --  Set the component tree that must be rendered after this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   --  ------------------------------
   procedure Set_After_View (UI   : in out UIView'Class;
                             Tree : in Base.UIComponent_Access) is
   begin
      if UI.Right_Tree /= null then
         UI.Log_Error ("Set_Before_View called while there is a tree");
      end if;
      UI.Right_Tree := Tree;
   end Set_After_View;

   --  ------------------------------
   --  Finalize the object.
   --  ------------------------------
   overriding
   procedure Finalize (UI : in out UIView) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Base.UIComponent'Class,
                                        Name   => Base.UIComponent_Access);

   begin
      Free (UI.Left_Tree);
      Free (UI.Right_Tree);
      Base.UIComponent (UI).Finalize;
   end Finalize;

   --  ------------------------------
   --  Set the metadata facet on the UIView component.
   --  ------------------------------
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class) is
   begin
      if UI.Meta /= null then
         UI.Log_Error ("A <f:metadata> component was already registered.");
--           Delete (UI.Meta);
      end if;
      Meta.Root := UI'Unchecked_Access;
      UI.Meta := Meta;
      UI.Add_Facet (METADATA_FACET_NAME, Meta.all'Access, Tag);
   end Set_Metadata;

   --  ------------------------------
   --  Get the input parameter from the submitted context.  This operation is called by
   --  <tt>Process_Decodes</tt> to retrieve the request parameter associated with the component.
   --  ------------------------------
   overriding
   function Get_Parameter (UI      : in UIViewParameter;
                           Context : in Faces_Context'Class) return String is
      Name : constant String := UI.Get_Attribute ("name", Context);
   begin
      if Name'Length > 0 then
         return Context.Get_Parameter (Name);
      else
         return Html.Forms.UIInput (UI).Get_Parameter (Context);
      end if;
   end Get_Parameter;

   --  ------------------------------
   --  Decode the request and prepare for the execution for the view action.
   --  ------------------------------
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      begin
         ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                              Method => UI.Get_Action_Expression (Context));

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Process_Decodes;

   --  ------------------------------
   --  Get the root component.
   --  ------------------------------
   function Get_Root (UI      : in UIViewMetaData) return Base.UIComponent_Access is
      Result : Base.UIComponent_Access := UI.Get_Parent;
      Parent : Base.UIComponent_Access := Result.Get_Parent;
   begin
      while Parent /= null loop
         Result := Parent;
         Parent := Parent.Get_Parent;
      end loop;
      return Result;
   end Get_Root;

   --  ------------------------------
   --  Start encoding the UIComponent.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_Begin (Context);
   end Encode_Begin;

   --  ------------------------------
   --  Encode the children of this component.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_Children (Context);
   end Encode_Children;

   --  ------------------------------
   --  Finish encoding the component.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class) is
   begin
      UI.Get_Root.Encode_End (Context);
   end Encode_End;

   --  ------------------------------
   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   --  ------------------------------
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class) is
   begin
      UI.Root.Queue_Event (Event);
   end Queue_Event;

   --  ------------------------------
   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   --  ------------------------------
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class) is
   begin
      UI.Root.Broadcast (Phase, Context);
   end Broadcast;

   --  ------------------------------
   --  Clear the events that were queued.
   --  ------------------------------
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData) is
   begin
      UI.Root.Clear_Events;
   end Clear_Events;

end ASF.Components.Core.Views;

Implement the Get_Parameter function to support the <f:viewParam> name attribute


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

with Ada.IO_Exceptions;

package body Util.Streams.Raw is

   use Util.Systems.Os;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

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

with Ada.IO_Exceptions;

package body Util.Streams.Raw is

   use Util.Systems.Os;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      use type Util.Systems.Types.off_t;

      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

Add missing use type Util.Systems.Types.off_t for Seek function (compilation error with gnat 2014 on 32-bit systems)


-----------------------------------------------------------------------
--  Util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

-----------------------------------------------------------------------
--  Util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   pragma Finalize_Storage_Only (String_Ref);

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

Add Finalize_Storage_Only on String_Ref

Add Finalize_Storage_Only on String_Ref


-----------------------------------------------------------------------
--  factories -- Factory for property manager implementation
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 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.Properties.Hash;
package body Util.Properties.Factories is

   Property_Manager_Factory : Interface_P.Manager_Factory;

   --  ------------------------------
   --  Initialize the property manager by setting the implementation.
   --  ------------------------------
   procedure Initialize (Properties : in out Manager) is
      use Interface_P;
   begin
      if Properties.Impl = null then
         if Property_Manager_Factory = null then
            Properties.Impl := new Util.Properties.Hash.Manager;
         else
            Properties.Impl := Property_Manager_Factory.all;
         end if;
         Properties.Impl.Count := 1;
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the default implementation factory for property manager.
   --  ------------------------------
   procedure Set_Default_Factory (Factory : Interface_P.Manager_Factory) is
   begin
      Property_Manager_Factory := Factory;
   end Set_Default_Factory;

end Util.Properties.Factories;

-----------------------------------------------------------------------
--  factories -- Factory for property manager implementation
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 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 Util.Properties.Hash;
package body Util.Properties.Factories is

   Property_Manager_Factory : Interface_P.Manager_Factory;

   --  ------------------------------
   --  Initialize the property manager by setting the implementation.
   --  ------------------------------
   procedure Initialize (Properties : in out Manager) is
      use Interface_P;
   begin
      if Properties.Impl = null then
         if Property_Manager_Factory = null then
            Properties.Impl := new Util.Properties.Hash.Manager;
         else
            Properties.Impl := Property_Manager_Factory.all;
         end if;
         Util.Concurrent.Counters.Increment (Properties.Impl.Count);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the default implementation factory for property manager.
   --  ------------------------------
   procedure Set_Default_Factory (Factory : Interface_P.Manager_Factory) is
   begin
      Property_Manager_Factory := Factory;
   end Set_Default_Factory;

end Util.Properties.Factories;

Update to use the concurrent counter

Update to use the concurrent counter


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

with Wiki.Documents;
with Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Nodes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

         --  The input is plain possibly incorrect HTML.
         SYNTAX_HTML);

   type Parser is tagged limited private;

   --  Add the plugin to the wiki engine.
   procedure Add_Plugin (Engine : in out Parser;
                         Name   : in String;
                         Plugin : in Wiki.Plugins.Wiki_Plugin_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Parse the wiki text contained in Text according to the wiki syntax configured
   --  on the wiki engine.  The document reader operations are invoked while parsing the wiki
   --  text.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String;
                    Into   : in Wiki.Documents.Document_Reader_Access);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   type Parser is tagged limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Syntax              : Wiki_Syntax_Type;
      Document            : Wiki.Nodes.Document;
      Filters             : Wiki.Filters.Filter_Type_Access;
--      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Token               : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wide_Wide_Character);

   --  Check if the link refers to an image and must be rendered as an image.
   function Is_Image (P    : in Parser;
                      Link : in Wide_Wide_String) return Boolean;

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Nodes.Html_Tag_Type;
                            Attributes : in Wiki.Attributes.Attribute_List_Type);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Nodes.Html_Tag_Type);

end Wiki.Parsers;

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

with Wiki.Documents;
with Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Nodes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

         --  The input is plain possibly incorrect HTML.
         SYNTAX_HTML);

   type Parser is tagged limited private;

   --  Add the plugin to the wiki engine.
   procedure Add_Plugin (Engine : in out Parser;
                         Name   : in String;
                         Plugin : in Wiki.Plugins.Wiki_Plugin_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Parse the wiki text contained in Text according to the wiki syntax configured
   --  on the wiki engine.  The document reader operations are invoked while parsing the wiki
   --  text.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String;
                    Into   : in Wiki.Documents.Document_Reader_Access);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   type Parser is tagged limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Syntax              : Wiki_Syntax_Type;
      Document            : Wiki.Nodes.Document;
      Filters             : Wiki.Filters.Filter_Type_Access;
--      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Token               : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wide_Wide_Character);

   --  Check if the link refers to an image and must be rendered as an image.
   function Is_Image (P    : in Parser;
                      Link : in Wide_Wide_String) return Boolean;

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Nodes.Html_Tag_Type;
                            Attributes : in out Wiki.Attributes.Attribute_List_Type);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Nodes.Html_Tag_Type);

end Wiki.Parsers;

Update Start_Element to allow changing the attributes


-----------------------------------------------------------------------
--  util-listeners-tests -- Unit tests for listeners
--  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 Ada.Strings.Unbounded;

with Util.Measures;
with Util.Test_Caller;
with Util.Listeners.Observers;
with Util.Listeners.Lifecycles;
package body Util.Listeners.Tests is

   use Util.Tests;

   Test_Error : exception;

   Count     : Natural := 0;

   package String_Observers is new Util.Listeners.Observers (String);
   package Integer_Observers is new Util.Listeners.Observers (Integer);

   type String_Listener is new String_Observers.Observer with record
      Expect : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Update (Listener : in String_Listener;
                     Item     : in String);

   type Integer_Listener is new Integer_Observers.Observer with record
      Expect : Integer;
   end record;

   overriding
   procedure Update (Listener : in Integer_Listener;
                     Item     : in Integer);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Listeners.Publish",
                       Test_Publish'Access);
      Caller.Add_Test (Suite, "Test Util.Listeners.Publish_Perf",
                       Test_Publish_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Listeners.Lifecycles",
                       Test_Lifecycles'Access);
   end Add_Tests;

   overriding
   procedure Update (Listener : in String_Listener;
                     Item     : in String) is
      use type Ada.Strings.Unbounded.Unbounded_String;
   begin
      if Item /= Listener.Expect then
         raise Test_Error;
      end if;
      Count := Count + 1;
   end Update;

   overriding
   procedure Update (Listener : in Integer_Listener;
                     Item     : in Integer) is
      use type Ada.Strings.Unbounded.Unbounded_String;
   begin
      if Item /= Listener.Expect then
         raise Test_Error;
      end if;
      Count := Count + 1;
   end Update;

   --  ------------------------------
   --  Test the listeners and the publish operation.
   --  ------------------------------
   procedure Test_Publish (T : in out Test) is
      Listeners : Util.Listeners.List;

      L1        : aliased String_Listener;
      L2        : aliased Integer_Listener;
      L3        : aliased Integer_Listener;
   begin
      Listeners.Append (L1'Unchecked_Access);
      Listeners.Append (L2'Unchecked_Access);
      Listeners.Append (L3'Unchecked_Access);

      L1.Expect := Ada.Strings.Unbounded.To_Unbounded_String ("Hello");
      String_Observers.Notify (Listeners, "Hello");
      Util.Tests.Assert_Equals (T, 1, Count, "Invalid number of calls");

      L2.Expect := 3;
      L3.Expect := 3;
      Integer_Observers.Notify (Listeners, 3);

   end Test_Publish;

   --  ------------------------------
   --  Performance test for the listeners.
   --  ------------------------------
   procedure Test_Publish_Perf (T : in out Test) is
      procedure Test_Basic (Item : in Integer);

      Listeners : Util.Listeners.List;
      L1        : aliased Integer_Listener;

      procedure Test_Basic (Item : in Integer) is
      begin
         Util.Tests.Assert_Equals (T, 3, Item);
      end Test_Basic;

   begin
      Listeners.Append (L1'Unchecked_Access);
      L1.Expect := 3;
      declare
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            Integer_Observers.Notify (Listeners, 3);
         end loop;
         Util.Measures.Report (S, "Observers.Notify", 1000);
      end;
      declare
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            Test_Basic (3);
         end loop;
         Util.Measures.Report (S, "Call basic procedure", 1000);
      end;
   end Test_Publish_Perf;

   --  ------------------------------
   --  Test the lifecycles listener.
   --  ------------------------------
   procedure Test_Lifecycles (T : in out Test) is
      package TL is new Util.Listeners.Lifecycles (Util.Measures.Stamp);

      Create_Count : Natural := 0;
      Update_Count : Natural := 0;
      Delete_Count : Natural := 0;

      type Listener is new TL.Listener with null record;

      --  The `On_Create` procedure is called by `Notify_Create` to notify the creation
      --  of the item.
      overriding
      procedure On_Create (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
      overriding
      procedure On_Update (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion
      --  of the item.
      overriding
      procedure On_Delete (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  ------------------------------
      --  The `On_Create` procedure is called by `Notify_Create` to notify the creation
      --  of the item.
      --  ------------------------------
      overriding
      procedure On_Create (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Create_Count := Create_Count + 1;
      end On_Create;

      --  ------------------------------
      --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
      --  ------------------------------
      overriding
      procedure On_Update (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Update_Count := Update_Count + 1;
      end On_Update;

      --  ------------------------------
      --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion
      --  of the item.
      --  ------------------------------
      overriding
      procedure On_Delete (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Delete_Count := Delete_Count + 1;
      end On_Delete;

      Listeners : Util.Listeners.List;
      L1        : aliased Integer_Listener;
      L2        : aliased Listener;
   begin
      Listeners.Append (L1'Unchecked_Access);
      Listeners.Append (L2'Unchecked_Access);

      declare
         S : Util.Measures.Stamp;
      begin
         TL.Notify_Create (Listeners, S);
         TL.Notify_Update (Listeners, S);
         TL.Notify_Delete (Listeners, S);
         Util.Measures.Report (S, "Notify Create, Update, Delete");
      end;
      Util.Tests.Assert_Equals (T, 1, Create_Count, "On_Create not called");
      Util.Tests.Assert_Equals (T, 1, Update_Count, "On_Update not called");
      Util.Tests.Assert_Equals (T, 1, Delete_Count, "On_Delete not called");
   end Test_Lifecycles;

end Util.Listeners.Tests;

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

with Util.Measures;
with Util.Test_Caller;
with Util.Listeners.Observers;
with Util.Listeners.Lifecycles;
package body Util.Listeners.Tests is

   Test_Error : exception;

   Count     : Natural := 0;

   package String_Observers is new Util.Listeners.Observers (String);
   package Integer_Observers is new Util.Listeners.Observers (Integer);

   type String_Listener is new String_Observers.Observer with record
      Expect : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Update (Listener : in String_Listener;
                     Item     : in String);

   type Integer_Listener is new Integer_Observers.Observer with record
      Expect : Integer;
   end record;

   overriding
   procedure Update (Listener : in Integer_Listener;
                     Item     : in Integer);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Listeners.Publish",
                       Test_Publish'Access);
      Caller.Add_Test (Suite, "Test Util.Listeners.Publish_Perf",
                       Test_Publish_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Listeners.Lifecycles",
                       Test_Lifecycles'Access);
   end Add_Tests;

   overriding
   procedure Update (Listener : in String_Listener;
                     Item     : in String) is
      use type Ada.Strings.Unbounded.Unbounded_String;
   begin
      if Item /= Listener.Expect then
         raise Test_Error;
      end if;
      Count := Count + 1;
   end Update;

   overriding
   procedure Update (Listener : in Integer_Listener;
                     Item     : in Integer) is
   begin
      if Item /= Listener.Expect then
         raise Test_Error;
      end if;
      Count := Count + 1;
   end Update;

   --  ------------------------------
   --  Test the listeners and the publish operation.
   --  ------------------------------
   procedure Test_Publish (T : in out Test) is
      Listeners : Util.Listeners.List;

      L1        : aliased String_Listener;
      L2        : aliased Integer_Listener;
      L3        : aliased Integer_Listener;
   begin
      Listeners.Append (L1'Unchecked_Access);
      Listeners.Append (L2'Unchecked_Access);
      Listeners.Append (L3'Unchecked_Access);

      L1.Expect := Ada.Strings.Unbounded.To_Unbounded_String ("Hello");
      String_Observers.Notify (Listeners, "Hello");
      Util.Tests.Assert_Equals (T, 1, Count, "Invalid number of calls");

      L2.Expect := 3;
      L3.Expect := 3;
      Integer_Observers.Notify (Listeners, 3);

   end Test_Publish;

   --  ------------------------------
   --  Performance test for the listeners.
   --  ------------------------------
   procedure Test_Publish_Perf (T : in out Test) is
      procedure Test_Basic (Item : in Integer);

      Listeners : Util.Listeners.List;
      L1        : aliased Integer_Listener;

      procedure Test_Basic (Item : in Integer) is
      begin
         Util.Tests.Assert_Equals (T, 3, Item);
      end Test_Basic;

   begin
      Listeners.Append (L1'Unchecked_Access);
      L1.Expect := 3;
      declare
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            Integer_Observers.Notify (Listeners, 3);
         end loop;
         Util.Measures.Report (S, "Observers.Notify", 1000);
      end;
      declare
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            Test_Basic (3);
         end loop;
         Util.Measures.Report (S, "Call basic procedure", 1000);
      end;
   end Test_Publish_Perf;

   --  ------------------------------
   --  Test the lifecycles listener.
   --  ------------------------------
   procedure Test_Lifecycles (T : in out Test) is
      package TL is new Util.Listeners.Lifecycles (Util.Measures.Stamp);

      Create_Count : Natural := 0;
      Update_Count : Natural := 0;
      Delete_Count : Natural := 0;

      type Listener is new TL.Listener with null record;

      --  The `On_Create` procedure is called by `Notify_Create` to notify the creation
      --  of the item.
      overriding
      procedure On_Create (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
      overriding
      procedure On_Update (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion
      --  of the item.
      overriding
      procedure On_Delete (Instance : in Listener;
                           Item     : in Util.Measures.Stamp);

      --  ------------------------------
      --  The `On_Create` procedure is called by `Notify_Create` to notify the creation
      --  of the item.
      --  ------------------------------
      overriding
      procedure On_Create (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Create_Count := Create_Count + 1;
      end On_Create;

      --  ------------------------------
      --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
      --  ------------------------------
      overriding
      procedure On_Update (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Update_Count := Update_Count + 1;
      end On_Update;

      --  ------------------------------
      --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion
      --  of the item.
      --  ------------------------------
      overriding
      procedure On_Delete (Instance : in Listener;
                           Item     : in Util.Measures.Stamp) is
         pragma Unreferenced (Instance, Item);
      begin
         Delete_Count := Delete_Count + 1;
      end On_Delete;

      Listeners : Util.Listeners.List;
      L1        : aliased Integer_Listener;
      L2        : aliased Listener;
   begin
      Listeners.Append (L1'Unchecked_Access);
      Listeners.Append (L2'Unchecked_Access);

      declare
         S : Util.Measures.Stamp;
      begin
         TL.Notify_Create (Listeners, S);
         TL.Notify_Update (Listeners, S);
         TL.Notify_Delete (Listeners, S);
         Util.Measures.Report (S, "Notify Create, Update, Delete");
      end;
      Util.Tests.Assert_Equals (T, 1, Create_Count, "On_Create not called");
      Util.Tests.Assert_Equals (T, 1, Update_Count, "On_Update not called");
      Util.Tests.Assert_Equals (T, 1, Delete_Count, "On_Delete not called");
   end Test_Lifecycles;

end Util.Listeners.Tests;

Remove unecessary use clauses

Remove unecessary use clauses


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

with Ada.Strings.Unbounded;
with Ada.Streams;
with Ada.Calendar;

with Util.Refs;
with Util.Nullables;
package ADO is

   type Int64 is range -2**63 .. 2**63 - 1;
   for Int64'Size use 64;

   type Unsigned64 is mod 2**64;
   for Unsigned64'Size use 64;

   DEFAULT_TIME : constant Ada.Calendar.Time;

   --  ------------------------------
   --  Database Identifier
   --  ------------------------------
   --
   type Identifier is range -2**47 .. 2**47 - 1;

   NO_IDENTIFIER : constant Identifier := -1;

   type Entity_Type is range 0 .. 2**16 - 1;

   NO_ENTITY_TYPE : constant Entity_Type := 0;

   type Object_Id is record
      Id   : Identifier;
      Kind : Entity_Type;
   end record;
   pragma Pack (Object_Id);

   --  ------------------------------
   --  Nullable Types
   --  ------------------------------
   --  Most database allow to store a NULL instead of an actual integer, date or string value.
   --  Unlike Java, there is no easy way to distinguish between a NULL and an actual valid value.
   --  The Nullable_T types provide a way to specify and check whether a value is null
   --  or not.

   subtype Nullable_Boolean is Util.Nullables.Nullable_Boolean;
   function "=" (Left, Right : in Nullable_Boolean) return Boolean
     renames Util.Nullables."=";

   Null_Boolean : constant Nullable_Boolean;

   --  An integer which can be null.
   subtype Nullable_Integer is Util.Nullables.Nullable_Integer;
   function "=" (Left, Right : in Nullable_Integer) return Boolean
     renames Util.Nullables."=";

   Null_Integer : constant Nullable_Integer;

   --  A string which can be null.
   subtype Nullable_String is Util.Nullables.Nullable_String;

   Null_String : constant Nullable_String;

   --  A date which can be null.
   subtype Nullable_Time is Util.Nullables.Nullable_Time;

   Null_Time : constant Nullable_Time;

   --  Return True if the two nullable times are identical (both null or both same time).
   function "=" (Left, Right : in Nullable_Time) return Boolean;

   type Nullable_Entity_Type is record
      Value   : Entity_Type := 0;
      Is_Null : Boolean := True;
   end record;

   Null_Entity_Type : constant Nullable_Entity_Type;

   --  ------------------------------
   --  Blob data type
   --  ------------------------------
   --  The Blob type is used to represent database blobs.  The data is stored
   --  in an Ada.Streams.Stream_Element_Array pointed to by the Data member.
   --  The query statement and bind parameter will use a Blob_Ref which represents
   --  a reference to the blob data.  This is intended to minimize data copy.
   type Blob (Len : Ada.Streams.Stream_Element_Offset) is new Util.Refs.Ref_Entity with record
      Data : Ada.Streams.Stream_Element_Array (1 .. Len);
   end record;
   type Blob_Access is access all Blob;

   package Blob_References is new Util.Refs.Indefinite_References (Blob, Blob_Access);
   subtype Blob_Ref is Blob_References.Ref;

   --  Create a blob with an allocated buffer of Size bytes.
   function Create_Blob (Size : in Natural) return Blob_Ref;

   --  Create a blob initialized with the given data buffer.
   function Create_Blob (Data : in Ada.Streams.Stream_Element_Array) return Blob_Ref;

   --  Create a blob initialized with the content from the file whose path is Path.
   --  Raises an IO exception if the file does not exist.
   function Create_Blob (Path : in String) return Blob_Ref;

   --  Return a null blob.
   function Null_Blob return Blob_Ref;

private

   DEFAULT_TIME : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year    => 1901,
                                                                      Month   => 1,
                                                                      Day     => 2,
                                                                      Seconds => 0.0);

   Null_Boolean : constant Nullable_Boolean
     := Nullable_Boolean '(Is_Null => True,
                           Value   => False);

   Null_Integer : constant Nullable_Integer
     := Nullable_Integer '(Is_Null => True,
                           Value   => 0);

   Null_String : constant Nullable_String
     := Nullable_String '(Is_Null => True,
                          Value   => Ada.Strings.Unbounded.Null_Unbounded_String);

   Null_Time : constant Nullable_Time
     := Nullable_Time '(Is_Null => True,
                        Value   => DEFAULT_TIME);

   Null_Entity_Type : constant Nullable_Entity_Type
     := Nullable_Entity_Type '(Is_Null => True,
                               Value   => 0);

end ADO;

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

with Ada.Strings.Unbounded;
with Ada.Streams;
with Ada.Calendar;

with Util.Refs;
with Util.Nullables;
package ADO is

   type Int64 is range -2**63 .. 2**63 - 1;
   for Int64'Size use 64;

   type Unsigned64 is mod 2**64;
   for Unsigned64'Size use 64;

   DEFAULT_TIME : constant Ada.Calendar.Time;

   --  ------------------------------
   --  Database Identifier
   --  ------------------------------
   --
   type Identifier is range -2**47 .. 2**47 - 1;

   NO_IDENTIFIER : constant Identifier := -1;

   type Entity_Type is range 0 .. 2**16 - 1;

   NO_ENTITY_TYPE : constant Entity_Type := 0;

   type Object_Id is record
      Id   : Identifier;
      Kind : Entity_Type;
   end record;
   pragma Pack (Object_Id);

   --  ------------------------------
   --  Nullable Types
   --  ------------------------------
   --  Most database allow to store a NULL instead of an actual integer, date or string value.
   --  Unlike Java, there is no easy way to distinguish between a NULL and an actual valid value.
   --  The Nullable_T types provide a way to specify and check whether a value is null
   --  or not.

   subtype Nullable_Boolean is Util.Nullables.Nullable_Boolean;
   function "=" (Left, Right : in Nullable_Boolean) return Boolean
     renames Util.Nullables."=";

   Null_Boolean : constant Nullable_Boolean;

   --  An integer which can be null.
   subtype Nullable_Integer is Util.Nullables.Nullable_Integer;
   function "=" (Left, Right : in Nullable_Integer) return Boolean
     renames Util.Nullables."=";

   Null_Integer : constant Nullable_Integer;

   --  A string which can be null.
   subtype Nullable_String is Util.Nullables.Nullable_String;

   Null_String : constant Nullable_String;

   --  A date which can be null.
   subtype Nullable_Time is Util.Nullables.Nullable_Time;

   Null_Time : constant Nullable_Time;

   --  Return True if the two nullable times are identical (both null or both same time).
   function "=" (Left, Right : in Nullable_Time) return Boolean;

   type Nullable_Entity_Type is record
      Value   : Entity_Type := 0;
      Is_Null : Boolean := True;
   end record;

   Null_Entity_Type : constant Nullable_Entity_Type;

   --  ------------------------------
   --  Blob data type
   --  ------------------------------
   --  The Blob type is used to represent database blobs.  The data is stored
   --  in an Ada.Streams.Stream_Element_Array pointed to by the Data member.
   --  The query statement and bind parameter will use a Blob_Ref which represents
   --  a reference to the blob data.  This is intended to minimize data copy.
   type Blob (Len : Ada.Streams.Stream_Element_Offset) is new Util.Refs.Ref_Entity with record
      Data : Ada.Streams.Stream_Element_Array (1 .. Len);
   end record;
   type Blob_Access is access all Blob;

   package Blob_References is new Util.Refs.Indefinite_References (Blob, Blob_Access);
   subtype Blob_Ref is Blob_References.Ref;
   subtype Blob_Accessor is Blob_References.Element_Accessor;

   --  Create a blob with an allocated buffer of Size bytes.
   function Create_Blob (Size : in Natural) return Blob_Ref;

   --  Create a blob initialized with the given data buffer.
   function Create_Blob (Data : in Ada.Streams.Stream_Element_Array) return Blob_Ref;

   --  Create a blob initialized with the content from the file whose path is Path.
   --  Raises an IO exception if the file does not exist.
   function Create_Blob (Path : in String) return Blob_Ref;

   --  Return a null blob.
   function Null_Blob return Blob_Ref;

private

   DEFAULT_TIME : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year    => 1901,
                                                                      Month   => 1,
                                                                      Day     => 2,
                                                                      Seconds => 0.0);

   Null_Boolean : constant Nullable_Boolean
     := Nullable_Boolean '(Is_Null => True,
                           Value   => False);

   Null_Integer : constant Nullable_Integer
     := Nullable_Integer '(Is_Null => True,
                           Value   => 0);

   Null_String : constant Nullable_String
     := Nullable_String '(Is_Null => True,
                          Value   => Ada.Strings.Unbounded.Null_Unbounded_String);

   Null_Time : constant Nullable_Time
     := Nullable_Time '(Is_Null => True,
                        Value   => DEFAULT_TIME);

   Null_Entity_Type : constant Nullable_Entity_Type
     := Nullable_Entity_Type '(Is_Null => True,
                               Value   => 0);

end ADO;

Add subtype Blob_Accessor

Add subtype Blob_Accessor