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

with Util.Log.Loggers;

with ASF.Streams;
with ASF.Contexts.Writer;
with ASF.Components.Core;
with ASF.Components.Core.Factory;
with ASF.Components.Html.Factory;
with ASF.Components.Utils.Factory;
with ASF.Views.Nodes.Core;
with ASF.Views.Nodes.Facelets;

with EL.Expressions;
with EL.Contexts.Default;

with Ada.Exceptions;
with Ada.Containers.Vectors;

package body ASF.Applications.Main is

   use Util.Log;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Main");

   --  ------------------------------
   --  Get the application view handler.
   --  ------------------------------
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class is
   begin
      return App.View'Unchecked_Access;
   end Get_View_Handler;

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   procedure Initialize (App  : in out Application;
                         Conf : in Config) is
      use ASF.Components;
      use ASF.Views;
   begin
      App.Conf := Conf;
      App.Set_Init_Parameters (Params => Conf);

      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Core.Factory.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Html.Factory.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Nodes.Core.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Nodes.Facelets.Definition);

      ASF.Components.Utils.Factory.Set_Functions (App.Functions);
      ASF.Views.Nodes.Core.Set_Functions (App.Functions);

      App.View.Initialize (App.Components'Unchecked_Access, Conf);
      ASF.Modules.Initialize (App.Modules, Conf);
      ASF.Locales.Initialize (App.Locales, App.Factory, Conf);
   end Initialize;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get_Config (App   : Application;
                        Param : Config_Param) return String is
   begin
      return App.Conf.Get (Param);
   end Get_Config;

   --  ------------------------------
   --  Set a global variable in the global EL contexts.
   --  ------------------------------
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String) is
   begin
      App.Set_Global (Name, EL.Objects.To_Object (Value));
   end Set_Global;

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object) is
   begin
      App.Globals.Bind (Name, Value);
   end Set_Global;

   --  ------------------------------
   --  Resolve a global variable and return its value.
   --  Raises the <b>EL.Functions.No_Variable</b> exception if the variable does not exist.
   --  ------------------------------
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object is
      Value : constant EL.Expressions.Value_Expression := App.Globals.Get_Variable (Name);
   begin
      return Value.Get_Value (Context);
   end Get_Global;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Handler : in Create_Bean_Access;
                       Free    : in Free_Bean_Access := null;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
   begin
      ASF.Beans.Register (App.Factory, Name, Handler, Free, Scope);
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out EL.Beans.Readonly_Bean_Access;
                     Free    : out Free_Bean_Access;
                     Scope   : out Scope_Type) is
   begin
      ASF.Beans.Create (App.Factory, Name, Result, Free, Scope);
   end Create;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in ASF.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      ASF.Modules.Register (App.Modules'Unchecked_Access, Module, Name, URI);
      Module.Register_Factory (App.Factory);

      App.View.Register_Module (Module);
   end Register;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String) is
   begin
      ASF.Locales.Register (App.Locales, App.Factory, Name, Bundle);
   end Register;

   --  ------------------------------
   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   --  ------------------------------
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : access ASF.Converters.Converter'Class) is
   begin
      ASF.Factory.Register (Factory   => App.Components,
                            Name      => Name,
                            Converter => Converter.all'Unchecked_Access);
   end Add_Converter;

   --  ------------------------------
   --  Closes the application
   --  ------------------------------
   procedure Close (App : in out Application) is
   begin
      ASF.Applications.Views.Close (App.View);
   end Close;

   type Bean_Object is record
      Bean : EL.Beans.Readonly_Bean_Access;
      Free : ASF.Beans.Free_Bean_Access;
   end record;

   package Bean_Vectors is new Ada.Containers.Vectors
     (Index_Type => Natural, Element_Type => Bean_Object);

   type Bean_Vector_Access is access all Bean_Vectors.Vector;

   --  ------------------------------
   --  Default Resolver
   --  ------------------------------
   type Web_ELResolver is new EL.Contexts.ELResolver with record
      Request     : EL.Contexts.Default.Default_ELResolver_Access;
      Application : Main.Application_Access;
      Beans       : Bean_Vector_Access;
   end record;

   overriding
   function Get_Value (Resolver : Web_ELResolver;
                       Context  : EL.Contexts.ELContext'Class;
                       Base     : access EL.Beans.Readonly_Bean'Class;
                       Name     : Unbounded_String) return EL.Objects.Object;
   overriding
   procedure Set_Value (Resolver : in Web_ELResolver;
                        Context  : in EL.Contexts.ELContext'Class;
                        Base     : access EL.Beans.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in EL.Objects.Object);

   --  Get the value associated with a base object and a given property.
   overriding
   function Get_Value (Resolver : Web_ELResolver;
                       Context  : EL.Contexts.ELContext'Class;
                       Base     : access EL.Beans.Readonly_Bean'Class;
                       Name     : Unbounded_String) return EL.Objects.Object is
      use EL.Objects;
      use EL.Beans;
      use EL.Variables;

      Result : Object := Resolver.Request.Get_Value (Context, Base, Name);
      Bean   : EL.Beans.Readonly_Bean_Access;
      Free   : ASF.Beans.Free_Bean_Access := null;
      Scope  : Scope_Type;
   begin
      if not EL.Objects.Is_Null (Result) then
         return Result;
      end if;
      Resolver.Application.Create (Name, Bean, Free, Scope);
      if Bean = null then
         return Resolver.Application.Get_Global (Name, Context);
         --           raise No_Variable
         --             with "Bean not found: '" & To_String (Name) & "'";
      end if;
      Resolver.Beans.Append (Bean_Object '(Bean, Free));
      Result := To_Object (Bean);
      Resolver.Request.Register (Name, Result);
      return Result;
   end Get_Value;

   --  Set the value associated with a base object and a given property.
   overriding
   procedure Set_Value (Resolver : in Web_ELResolver;
                        Context  : in EL.Contexts.ELContext'Class;
                        Base     : access EL.Beans.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in EL.Objects.Object) is
   begin
      Resolver.Request.Set_Value (Context, Base, Name, Value);
   end Set_Value;

   --  ------------------------------
   --  Set the current faces context before processing a view.
   --  ------------------------------
   procedure Set_Context (App : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access) is
   begin
      Context.Get_ELContext.Set_Function_Mapper (App.Functions'Unchecked_Access);
      ASF.Contexts.Faces.Set_Current (Context, App'Unchecked_Access);
   end Set_Context;

   --  ------------------------------
   --  Dispatch the request received on a page.
   --  ------------------------------
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;
      use EL.Objects;
      use EL.Beans;
      use ASF.Applications.Views;
      use Ada.Exceptions;

      Writer         : aliased ASF.Contexts.Writer.ResponseWriter;
      Context        : aliased ASF.Contexts.Faces.Faces_Context;
      View           : Components.Core.UIViewRoot;
      ELContext      : aliased EL.Contexts.Default.Default_Context;
      Variables      : aliased Default_Variable_Mapper;
      Req_Resolver   : aliased Default_ELResolver;
      Root_Resolver  : aliased Web_ELResolver;

      Beans          : aliased Bean_Vectors.Vector;
      --  Get the view handler
      Handler   : constant access View_Handler'Class := App.Get_View_Handler;

      Output         : constant ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Log.Info ("Dispatch {0}", Page);

      Root_Resolver.Application := App'Unchecked_Access;
      Root_Resolver.Request := Req_Resolver'Unchecked_Access;
      Root_Resolver.Beans := Beans'Unchecked_Access;
      ELContext.Set_Resolver (Root_Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Response_Writer (Writer'Unchecked_Access);
      Writer.Initialize ("text/html", "UTF-8", Output);

      Context.Set_Request (Request'Unchecked_Access);
      Context.Set_Response (Response'Unchecked_Access);
      App.Set_Context (Context'Unchecked_Access);
      begin
         Handler.Restore_View (Page, Context, View);

      exception
         when E : others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         Handler.Render_View (Context, View);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;
      Writer.Flush;

      declare
         C : Bean_Vectors.Cursor := Beans.First;
      begin
         while Bean_Vectors.Has_Element (C) loop
            declare
               Bean : Bean_Object := Bean_Vectors.Element (C);
            begin
               if Bean.Bean /= null and then Bean.Free /= null then
                  Bean.Free (Bean.Bean);
               end if;
            end;
            Bean_Vectors.Next (C);
         end loop;
      end;
   end Dispatch;

   --  ------------------------------
   --  Dispatch the request received on a page.
   --  ------------------------------
   procedure Postback (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;
      use EL.Objects;
      use EL.Beans;
      use ASF.Applications.Views;
      use Ada.Exceptions;

      Writer         : aliased ASF.Contexts.Writer.ResponseWriter;
      Context        : aliased ASF.Contexts.Faces.Faces_Context;
      View           : Components.Core.UIViewRoot;
      ELContext      : aliased EL.Contexts.Default.Default_Context;
      Variables      : aliased Default_Variable_Mapper;
      Req_Resolver   : aliased Default_ELResolver;
      Root_Resolver  : aliased Web_ELResolver;

      Beans          : aliased Bean_Vectors.Vector;
      --  Get the view handler
      Handler   : constant access View_Handler'Class := App.Get_View_Handler;

      Output         : constant ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Log.Info ("Dispatch {0}", Page);

      Root_Resolver.Application := App'Unchecked_Access;
      Root_Resolver.Request := Req_Resolver'Unchecked_Access;
      Root_Resolver.Beans := Beans'Unchecked_Access;
      ELContext.Set_Resolver (Root_Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Response_Writer (Writer'Unchecked_Access);
      Writer.Initialize ("text/html", "UTF-8", Output);

      Context.Set_Request (Request'Unchecked_Access);
      Context.Set_Response (Response'Unchecked_Access);
      App.Set_Context (Context'Unchecked_Access);
      begin
         Handler.Restore_View (Page, Context, View);

      exception
         when E : others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         View.Get_Root.Process_Decodes (Context);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         View.Get_Root.Process_Updates (Context);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         Handler.Render_View (Context, View);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;
      Writer.Flush;

      declare
         C : Bean_Vectors.Cursor := Beans.First;
      begin
         while Bean_Vectors.Has_Element (C) loop
            declare
               Bean : Bean_Object := Bean_Vectors.Element (C);
            begin
               if Bean.Bean /= null and then Bean.Free /= null then
                  Bean.Free (Bean.Bean);
               end if;
            end;
            Bean_Vectors.Next (C);
         end loop;
      end;
   end Postback;

   --  ------------------------------
   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   --  ------------------------------
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return access ASF.Converters.Converter'Class is
   begin
      return ASF.Factory.Find (App.Components, Name);
   end Find;

   --  ------------------------------
   --  Register some functions
   --  ------------------------------
   procedure Register_Functions (App : in out Application'Class) is
   begin
      Set_Functions (App.Functions);
   end Register_Functions;

end ASF.Applications.Main;

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

with Util.Log.Loggers;

with ASF.Streams;
with ASF.Contexts.Writer;
with ASF.Components.Core;
with ASF.Components.Core.Factory;
with ASF.Components.Html.Factory;
with ASF.Components.Utils.Factory;
with ASF.Views.Nodes.Core;
with ASF.Views.Nodes.Facelets;

with EL.Expressions;
with EL.Contexts.Default;

with Ada.Exceptions;
with Ada.Containers.Vectors;

package body ASF.Applications.Main is

   use Util.Log;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Main");

   --  ------------------------------
   --  Get the application view handler.
   --  ------------------------------
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class is
   begin
      return App.View'Unchecked_Access;
   end Get_View_Handler;

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   procedure Initialize (App  : in out Application;
                         Conf : in Config) is
      use ASF.Components;
      use ASF.Views;
   begin
      App.Conf := Conf;
      App.Set_Init_Parameters (Params => Conf);

      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Core.Factory.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Html.Factory.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Nodes.Core.Definition);
      ASF.Factory.Register (Factory  => App.Components,
                            Bindings => Nodes.Facelets.Definition);

      ASF.Components.Utils.Factory.Set_Functions (App.Functions);
      ASF.Views.Nodes.Core.Set_Functions (App.Functions);

      App.View.Initialize (App.Components'Unchecked_Access, Conf);
      ASF.Modules.Initialize (App.Modules, Conf);
      ASF.Locales.Initialize (App.Locales, App.Factory, Conf);
   end Initialize;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get_Config (App   : Application;
                        Param : Config_Param) return String is
   begin
      return App.Conf.Get (Param);
   end Get_Config;

   --  ------------------------------
   --  Set a global variable in the global EL contexts.
   --  ------------------------------
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String) is
   begin
      App.Set_Global (Name, EL.Objects.To_Object (Value));
   end Set_Global;

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object) is
   begin
      App.Globals.Bind (Name, Value);
   end Set_Global;

   --  ------------------------------
   --  Resolve a global variable and return its value.
   --  Raises the <b>EL.Functions.No_Variable</b> exception if the variable does not exist.
   --  ------------------------------
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object is
      Value : constant EL.Expressions.Value_Expression := App.Globals.Get_Variable (Name);
   begin
      return Value.Get_Value (Context);
   end Get_Global;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Handler : in Create_Bean_Access;
                       Free    : in Free_Bean_Access := null;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
   begin
      ASF.Beans.Register (App.Factory, Name, Handler, Free, Scope);
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out EL.Beans.Readonly_Bean_Access;
                     Free    : out Free_Bean_Access;
                     Scope   : out Scope_Type) is
   begin
      ASF.Beans.Create (App.Factory, Name, Result, Free, Scope);
   end Create;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in ASF.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      ASF.Modules.Register (App.Modules'Unchecked_Access, Module, Name, URI);
      Module.Register_Factory (App.Factory);

      App.View.Register_Module (Module);
   end Register;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String) is
   begin
      ASF.Locales.Register (App.Locales, App.Factory, Name, Bundle);
   end Register;

   --  ------------------------------
   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   --  ------------------------------
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : access ASF.Converters.Converter'Class) is
   begin
      ASF.Factory.Register (Factory   => App.Components,
                            Name      => Name,
                            Converter => Converter.all'Unchecked_Access);
   end Add_Converter;

   --  ------------------------------
   --  Closes the application
   --  ------------------------------
   procedure Close (App : in out Application) is
   begin
      ASF.Applications.Views.Close (App.View);
   end Close;

   type Bean_Object is record
      Bean : EL.Beans.Readonly_Bean_Access;
      Free : ASF.Beans.Free_Bean_Access;
   end record;

   package Bean_Vectors is new Ada.Containers.Vectors
     (Index_Type => Natural, Element_Type => Bean_Object);

   type Bean_Vector_Access is access all Bean_Vectors.Vector;

   --  ------------------------------
   --  Default Resolver
   --  ------------------------------
   type Web_ELResolver is new EL.Contexts.ELResolver with record
      Request     : ASF.Requests.Request_Access;
      Application : Main.Application_Access;
      Beans       : Bean_Vector_Access;
   end record;

   overriding
   function Get_Value (Resolver : Web_ELResolver;
                       Context  : EL.Contexts.ELContext'Class;
                       Base     : access EL.Beans.Readonly_Bean'Class;
                       Name     : Unbounded_String) return EL.Objects.Object;
   overriding
   procedure Set_Value (Resolver : in Web_ELResolver;
                        Context  : in EL.Contexts.ELContext'Class;
                        Base     : access EL.Beans.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in EL.Objects.Object);

   --  Get the value associated with a base object and a given property.
   overriding
   function Get_Value (Resolver : Web_ELResolver;
                       Context  : EL.Contexts.ELContext'Class;
                       Base     : access EL.Beans.Readonly_Bean'Class;
                       Name     : Unbounded_String) return EL.Objects.Object is
      use EL.Objects;
      use EL.Beans;
      use EL.Variables;

      Result : Object;
      Bean   : EL.Beans.Readonly_Bean_Access;
      Free   : ASF.Beans.Free_Bean_Access := null;
      Scope  : Scope_Type;
      Key    : constant String := To_String (Name);
   begin
      if Base /= null then
         return Base.Get_Value (Key);
      end if;

      Result := Resolver.Request.Get_Attribute (Key);
      if not EL.Objects.Is_Null (Result) then
         return Result;
      end if;
      Resolver.Application.Create (Name, Bean, Free, Scope);
      if Bean = null then
         return Resolver.Application.Get_Global (Name, Context);
         --           raise No_Variable
         --             with "Bean not found: '" & To_String (Name) & "'";
      end if;
      Resolver.Beans.Append (Bean_Object '(Bean, Free));
      Result := To_Object (Bean);
      Resolver.Request.Set_Attribute (Key, Result);
      return Result;
   end Get_Value;

   --  Set the value associated with a base object and a given property.
   overriding
   procedure Set_Value (Resolver : in Web_ELResolver;
                        Context  : in EL.Contexts.ELContext'Class;
                        Base     : access EL.Beans.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in EL.Objects.Object) is
      pragma Unreferenced (Context);

      Key : constant String := To_String (Name);
   begin
      if Base /= null then
         Base.Set_Value (Name => Key, Value => Value);
      else
         Resolver.Request.Set_Attribute (Name => Key, Value => Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the current faces context before processing a view.
   --  ------------------------------
   procedure Set_Context (App : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access) is
   begin
      Context.Get_ELContext.Set_Function_Mapper (App.Functions'Unchecked_Access);
      ASF.Contexts.Faces.Set_Current (Context, App'Unchecked_Access);
   end Set_Context;

   --  ------------------------------
   --  Dispatch the request received on a page.
   --  ------------------------------
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;
      use EL.Objects;
      use EL.Beans;
      use ASF.Applications.Views;
      use Ada.Exceptions;

      Writer         : aliased ASF.Contexts.Writer.ResponseWriter;
      Context        : aliased ASF.Contexts.Faces.Faces_Context;
      View           : Components.Core.UIViewRoot;
      ELContext      : aliased EL.Contexts.Default.Default_Context;
      Variables      : aliased Default_Variable_Mapper;
      Root_Resolver  : aliased Web_ELResolver;

      Beans          : aliased Bean_Vectors.Vector;
      --  Get the view handler
      Handler   : constant access View_Handler'Class := App.Get_View_Handler;

      Output         : constant ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Log.Info ("Dispatch {0}", Page);

      Root_Resolver.Application := App'Unchecked_Access;
      Root_Resolver.Request := Request'Unchecked_Access;
      Root_Resolver.Beans := Beans'Unchecked_Access;
      ELContext.Set_Resolver (Root_Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Response_Writer (Writer'Unchecked_Access);
      Writer.Initialize ("text/html", "UTF-8", Output);

      Context.Set_Request (Request'Unchecked_Access);
      Context.Set_Response (Response'Unchecked_Access);
      App.Set_Context (Context'Unchecked_Access);
      begin
         Handler.Restore_View (Page, Context, View);

      exception
         when E : others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         Handler.Render_View (Context, View);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;
      Writer.Flush;

      declare
         C : Bean_Vectors.Cursor := Beans.First;
      begin
         while Bean_Vectors.Has_Element (C) loop
            declare
               Bean : Bean_Object := Bean_Vectors.Element (C);
            begin
               if Bean.Bean /= null and then Bean.Free /= null then
                  Bean.Free (Bean.Bean);
               end if;
            end;
            Bean_Vectors.Next (C);
         end loop;
      end;
   end Dispatch;

   --  ------------------------------
   --  Dispatch the request received on a page.
   --  ------------------------------
   procedure Postback (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;
      use EL.Objects;
      use EL.Beans;
      use ASF.Applications.Views;
      use Ada.Exceptions;

      Writer         : aliased ASF.Contexts.Writer.ResponseWriter;
      Context        : aliased ASF.Contexts.Faces.Faces_Context;
      View           : Components.Core.UIViewRoot;
      ELContext      : aliased EL.Contexts.Default.Default_Context;
      Variables      : aliased Default_Variable_Mapper;
      Root_Resolver  : aliased Web_ELResolver;

      Beans          : aliased Bean_Vectors.Vector;
      --  Get the view handler
      Handler   : constant access View_Handler'Class := App.Get_View_Handler;

      Output         : constant ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Log.Info ("Dispatch {0}", Page);

      Root_Resolver.Application := App'Unchecked_Access;
      Root_Resolver.Request := Request'Unchecked_Access;
      Root_Resolver.Beans := Beans'Unchecked_Access;
      ELContext.Set_Resolver (Root_Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Response_Writer (Writer'Unchecked_Access);
      Writer.Initialize ("text/html", "UTF-8", Output);

      Context.Set_Request (Request'Unchecked_Access);
      Context.Set_Response (Response'Unchecked_Access);
      App.Set_Context (Context'Unchecked_Access);
      begin
         Handler.Restore_View (Page, Context, View);

      exception
         when E : others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         View.Get_Root.Process_Decodes (Context);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         View.Get_Root.Process_Updates (Context);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;

      begin
         Handler.Render_View (Context, View);

      exception
         when E: others =>
            Log.Error ("Error when restoring view {0}: {1}: {2}", Page,
                       Exception_Name (E), Exception_Message (E));
            raise;
      end;
      Writer.Flush;

      declare
         C : Bean_Vectors.Cursor := Beans.First;
      begin
         while Bean_Vectors.Has_Element (C) loop
            declare
               Bean : Bean_Object := Bean_Vectors.Element (C);
            begin
               if Bean.Bean /= null and then Bean.Free /= null then
                  Bean.Free (Bean.Bean);
               end if;
            end;
            Bean_Vectors.Next (C);
         end loop;
      end;
   end Postback;

   --  ------------------------------
   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   --  ------------------------------
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return access ASF.Converters.Converter'Class is
   begin
      return ASF.Factory.Find (App.Components, Name);
   end Find;

   --  ------------------------------
   --  Register some functions
   --  ------------------------------
   procedure Register_Functions (App : in out Application'Class) is
   begin
      Set_Functions (App.Functions);
   end Register_Functions;

end ASF.Applications.Main;

Store the beans created for the request on the request object by using Set_Attribute and Get_Attribute to retrieve them.


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

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

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

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

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   type Block;
   type Content_Access is access all Block;

   type Block (Len : Positive) is limited record
      Next_Block : Content_Access;
      Last       : Natural := 0;
      Content    : Wiki.Strings.WString (1 .. Len);
   end record;

   procedure Next (Content : in out Content_Access;
                   Pos     : in out Positive) with Inline_Always;

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      In_Table            : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Pending_Paragraph   : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

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

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar);
   procedure Pop_List (P      : in out Parser);

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

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

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

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

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

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

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

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   type Block;
   type Content_Access is access all Block;

   type Block (Len : Positive) is limited record
      Next_Block : Content_Access;
      Last       : Natural := 0;
      Content    : Wiki.Strings.WString (1 .. Len);
   end record;

   procedure Next (Content : in out Content_Access;
                   Pos     : in out Positive) with Inline_Always;

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      In_Table            : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Pending_Paragraph   : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

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

   procedure Flush_Block (Parser : in out Parser_Type);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar);
   procedure Pop_List (P      : in out Parser);

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

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

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

Declare the Flush_Block procedure

Declare the Flush_Block procedure


-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Ada.Text_IO; use Ada.Text_IO;
package body Util.Commands.Drivers is

   --  The logger
   Logs : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create (Driver_Name);

   --  ------------------------------
   --  Write the command usage.
   --  ------------------------------
   procedure Usage (Command : in Command_Type) is
   begin
      null;
   end Usage;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   --  ------------------------------
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Command.Driver.Log (Level, Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
     procedure Print (Position : in Command_Maps.Cursor);

      procedure Print (Position : in Command_Maps.Cursor) is
         Name : constant String := Command_Maps.Key (Position);
      begin
         Put_Line ("   " & Name);
      end Print;

   begin
      Logs.Debug ("Execute command {0}", Name);

      if Args.Get_Count = 0 then
         --  Usage;
         New_Line;
         Put ("Type '");
         Put (Args.Get_Command_Name);
         Put_Line (" help {command}' for help on a specific command.");
         New_Line;
         Put_Line ("Available subcommands:");

         Command.Driver.List.Iterate (Process => Print'Access);
      else
         declare
            Cmd_Name   : constant String := Args.Get_Argument (1);
            Target_Cmd : constant Command_Access := Command.Driver.Find_Command (Cmd_Name);
         begin
            if Target_Cmd = null then
               Logs.Error ("Unknown command {0}", Cmd_Name);
            else
               Target_Cmd.Help (Context);
            end if;
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Help_Command_Type;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

   --  ------------------------------
   --  Set the driver description printed in the usage.
   --  ------------------------------
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String) is
   begin
      Driver.Desc := Ada.Strings.Unbounded.To_Unbounded_String (Description);
   end Set_Description;

   --  ------------------------------
    --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access) is
   begin
      Command.Driver := Driver'Unchecked_Access;
      Driver.List.Include (Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Handler : in Command_Handler) is
   begin
      Driver.List.Include (Name, new Handler_Command_Type '(Driver  => Driver'Unchecked_Access,
                                                            Handler => Handler));
   end Add_Command;

   --  ------------------------------
   --  Find the command having the given name.
   --  Returns null if the command was not found.
   --  ------------------------------
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access is
      Pos : constant Command_Maps.Cursor := Driver.List.Find (Name);
   begin
      if Command_Maps.Has_Element (Pos) then
         return Command_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Command;

   --  ------------------------------
   --  Execute the command registered under the given name.
   --  ------------------------------
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
      Command : constant Command_Access := Driver.Find_Command (Name);
   begin
      if Command /= null then
         Command.Execute (Name, Args, Context);
      else
         Logs.Error ("Unkown command {0}", Name);
      end if;
   end Execute;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  ------------------------------
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Logs.Print (Level, "{0}: {1}", Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command.Handler (Name, Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Handler_Command_Type;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

end Util.Commands.Drivers;

-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Ada.Text_IO; use Ada.Text_IO;
package body Util.Commands.Drivers is

   --  The logger
   Logs : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create (Driver_Name);

   --  ------------------------------
   --  Write the command usage.
   --  ------------------------------
   procedure Usage (Command : in Command_Type) is
   begin
      null;
   end Usage;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   --  ------------------------------
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Command.Driver.Log (Level, Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
     procedure Print (Position : in Command_Maps.Cursor);

      procedure Print (Position : in Command_Maps.Cursor) is
         Name : constant String := Command_Maps.Key (Position);
      begin
         Put_Line ("   " & Name);
      end Print;

   begin
      Logs.Debug ("Execute command {0}", Name);

      if Args.Get_Count = 0 then
         --  Usage;
         New_Line;
         Put ("Type '");
         Put (Args.Get_Command_Name);
         Put_Line (" help {command}' for help on a specific command.");
         New_Line;
         Put_Line ("Available subcommands:");

         Command.Driver.List.Iterate (Process => Print'Access);
      else
         declare
            Cmd_Name   : constant String := Args.Get_Argument (1);
            Target_Cmd : constant Command_Access := Command.Driver.Find_Command (Cmd_Name);
         begin
            if Target_Cmd = null then
               Logs.Error ("Unknown command {0}", Cmd_Name);
            else
               Target_Cmd.Help (Context);
            end if;
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Help_Command_Type;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

   --  ------------------------------
   --  Set the driver description printed in the usage.
   --  ------------------------------
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String) is
   begin
      Driver.Desc := Ada.Strings.Unbounded.To_Unbounded_String (Description);
   end Set_Description;

   --  ------------------------------
   --  Set the driver usage printed in the usage.
   --  ------------------------------
   procedure Set_Usage (Driver  : in out Driver_Type;
                        Usage   : in String) is
   begin
      Driver.Usage := Ada.Strings.Unbounded.To_Unbounded_String (Usage);
   end Set_Usage;

   --  ------------------------------
    --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access) is
   begin
      Command.Driver := Driver'Unchecked_Access;
      Driver.List.Include (Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Handler : in Command_Handler) is
   begin
      Driver.List.Include (Name, new Handler_Command_Type '(Driver  => Driver'Unchecked_Access,
                                                            Handler => Handler));
   end Add_Command;

   --  ------------------------------
   --  Find the command having the given name.
   --  Returns null if the command was not found.
   --  ------------------------------
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access is
      Pos : constant Command_Maps.Cursor := Driver.List.Find (Name);
   begin
      if Command_Maps.Has_Element (Pos) then
         return Command_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Command;

   --  ------------------------------
   --  Execute the command registered under the given name.
   --  ------------------------------
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
      Command : constant Command_Access := Driver.Find_Command (Name);
   begin
      if Command /= null then
         Command.Execute (Name, Args, Context);
      else
         Logs.Error ("Unkown command {0}", Name);
      end if;
   end Execute;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  ------------------------------
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Logs.Print (Level, "{0}: {1}", Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command.Handler (Name, Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Handler_Command_Type;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

end Util.Commands.Drivers;

Implement the Set_Usage procedure

Implement the Set_Usage procedure


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

with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Calendar;

with Ahven.Listeners.Basic;
with Ahven.XML_Runner;
with Ahven.Text_Runner;

with Util.Tests;
package body Util.XUnit is

   --  ------------------------------
   --  Build a message from a string (Adaptation for AUnit API).
   --  ------------------------------
   function Format (S : in String) return Message_String is
   begin
      return S;
   end Format;

   --  ------------------------------
   --  Build a message with the source and line number.
   --  ------------------------------
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String is
      L : constant String := Natural'Image (Line);
   begin
      return Source & ":" & L (2 .. L'Last) & ": " & Message;
   end Build_Message;

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class);

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class) is
   begin
      Test_Case'Class (T).Run_Test;
   end Run_Test_Case;

   overriding
   procedure Initialize (T : in out Test_Case) is
   begin
      Ahven.Framework.Add_Test_Routine (T, Run_Test_Case'Access, "Test case");
   end Initialize;

   --  ------------------------------
   --  Return the name of the test case.
   --  ------------------------------
   overriding
   function Get_Name (T : Test_Case) return String is
   begin
      return Test_Case'Class (T).Name;
   end Get_Name;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   --  ------------------------------
   --  Check that the value matches what we expect.
   --  ------------------------------
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   First_Test : Test_Object_Access := null;

   --  ------------------------------
   --  Register a test object in the test suite.
   --  ------------------------------
   procedure Register (T : in Test_Object_Access) is
   begin
      T.Next := First_Test;
      First_Test := T;
   end Register;

   --  ------------------------------
   --  Report passes, skips, failures, and errors from the result collection.
   --  ------------------------------
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Time    : in Duration) is
      T_Count : constant Integer := Ahven.Results.Test_Count (Result);
      F_Count : constant Integer := Ahven.Results.Failure_Count (Result);
      S_Count : constant Integer := Ahven.Results.Skipped_Count (Result);
      E_Count : constant Integer := Ahven.Results.Error_Count (Result);
   begin
      if F_Count > 0 then
         Ahven.Text_Runner.Print_Failures (Result, 0);
      end if;
      if E_Count > 0 then
         Ahven.Text_Runner.Print_Errors (Result, 0);
      end if;
      Ada.Text_IO.Put_Line ("Tests run:" & Integer'Image (T_Count - S_Count)
                            & ", Failures:" & Integer'Image (F_Count)
                            & ", Errors:" & Integer'Image (E_Count)
                            & ", Skipped:" & Integer'Image (S_Count)
                            & ", Time elapsed:" & Duration'Image (Time));

   end Report_Results;

   --  ------------------------------
   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   --  ------------------------------
   procedure Harness (Output : in Ada.Strings.Unbounded.Unbounded_String;
                      XML    : in Boolean;
                      Result : out Status) is
      pragma Unreferenced (XML, Output);

      use Ahven.Listeners.Basic;
      use Ahven.Framework;
      use Ahven.Results;
      use type Ada.Calendar.Time;

      Tests    : constant Access_Test_Suite := Suite;
      T        : Test_Object_Access := First_Test;
      Listener : Ahven.Listeners.Basic.Basic_Listener;
      Timeout  : constant Test_Duration := Test_Duration (Util.Tests.Get_Test_Timeout ("all"));
      Out_Dir  : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Start    : Ada.Calendar.Time;
   begin
      while T /= null loop
         Ahven.Framework.Add_Static_Test (Tests.all, T.Test.all);
         T := T.Next;
      end loop;
      Set_Output_Capture (Listener, True);
      if not Ada.Directories.Exists (Out_Dir) then
         Ada.Directories.Create_Path (Out_Dir);
      end if;

      Start := Ada.Calendar.Clock;
      Ahven.Framework.Execute (Tests.all, Listener, Timeout);
      Report_Results (Listener.Main_Result, Ada.Calendar.Clock - Start);

      Ahven.XML_Runner.Report_Results (Listener.Main_Result, Out_Dir);

      if (Error_Count (Listener.Main_Result) > 0) or
        (Failure_Count (Listener.Main_Result) > 0) then
         Result := Failure;
      else
         Result := Success;
      end if;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot create file");
         Result := Failure;

   end Harness;

end Util.XUnit;

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

with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Calendar;

with Ahven.Listeners.Basic;
with Ahven.XML_Runner;
with Ahven.Text_Runner;

with Util.Tests;
package body Util.XUnit is

   --  ------------------------------
   --  Build a message from a string (Adaptation for AUnit API).
   --  ------------------------------
   function Format (S : in String) return Message_String is
   begin
      return S;
   end Format;

   --  ------------------------------
   --  Build a message with the source and line number.
   --  ------------------------------
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String is
      L : constant String := Natural'Image (Line);
   begin
      return Source & ":" & L (2 .. L'Last) & ": " & Message;
   end Build_Message;

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class);

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class) is
   begin
      Test_Case'Class (T).Run_Test;
   end Run_Test_Case;

   overriding
   procedure Initialize (T : in out Test_Case) is
   begin
      Ahven.Framework.Add_Test_Routine (T, Run_Test_Case'Access, "Test case");
   end Initialize;

   --  ------------------------------
   --  Return the name of the test case.
   --  ------------------------------
   overriding
   function Get_Name (T : Test_Case) return String is
   begin
      return Test_Case'Class (T).Name;
   end Get_Name;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   --  ------------------------------
   --  Check that the value matches what we expect.
   --  ------------------------------
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   First_Test : Test_Object_Access := null;

   --  ------------------------------
   --  Register a test object in the test suite.
   --  ------------------------------
   procedure Register (T : in Test_Object_Access) is
   begin
      T.Next := First_Test;
      First_Test := T;
   end Register;

   --  ------------------------------
   --  Report passes, skips, failures, and errors from the result collection.
   --  ------------------------------
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Time    : in Duration) is
      T_Count : constant Integer := Ahven.Results.Test_Count (Result);
      F_Count : constant Integer := Ahven.Results.Failure_Count (Result);
      S_Count : constant Integer := Ahven.Results.Skipped_Count (Result);
      E_Count : constant Integer := Ahven.Results.Error_Count (Result);
   begin
      if F_Count > 0 then
         Ahven.Text_Runner.Print_Failures (Result, 0);
      end if;
      if E_Count > 0 then
         Ahven.Text_Runner.Print_Errors (Result, 0);
      end if;
      Ada.Text_IO.Put_Line ("Tests run:" & Integer'Image (T_Count - S_Count)
                            & ", Failures:" & Integer'Image (F_Count)
                            & ", Errors:" & Integer'Image (E_Count)
                            & ", Skipped:" & Integer'Image (S_Count)
                            & ", Time elapsed:" & Duration'Image (Time));

   end Report_Results;

   --  ------------------------------
   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   --  ------------------------------
   procedure Harness (Output : in Ada.Strings.Unbounded.Unbounded_String;
                      XML    : in Boolean;
                      Result : out Status) is
      pragma Unreferenced (XML, Output);

      use Ahven.Listeners.Basic;
      use Ahven.Framework;
      use Ahven.Results;
      use type Ada.Calendar.Time;

      Tests    : constant Access_Test_Suite := Suite;
      T        : Test_Object_Access := First_Test;
      Listener : Ahven.Listeners.Basic.Basic_Listener;
      Timeout  : constant Test_Duration := Test_Duration (Util.Tests.Get_Test_Timeout ("all"));
      Out_Dir  : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Start    : Ada.Calendar.Time;
   begin
      while T /= null loop
         Ahven.Framework.Add_Static_Test (Tests.all, T.Test.all);
         T := T.Next;
      end loop;
      Set_Output_Capture (Listener, True);
      if not Ada.Directories.Exists (Out_Dir) then
         Ada.Directories.Create_Path (Out_Dir);
      end if;

      Start := Ada.Calendar.Clock;
      Ahven.Framework.Execute (Tests.all, Listener, Timeout);
      Report_Results (Listener.Main_Result, Ada.Calendar.Clock - Start);

      Ahven.XML_Runner.Report_Results (Listener.Main_Result, Out_Dir);

      if (Error_Count (Listener.Main_Result) > 0) or
        (Failure_Count (Listener.Main_Result) > 0) then
         Result := Failure;
      else
         Result := Success;
      end if;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot create file");
         Result := Failure;

   end Harness;

end Util.XUnit;

Update header comment

Update header comment


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
--                                                                          --
--  This file is based on:                                                  --
--                                                                          --
--   @file    stm32f4xx_hal_cortex.c                                        --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   CORTEX HAL module driver.                                     --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with Memory_Barriers;

package body Cortex_M.NVIC is

   -----------------------
   -- Priority_Grouping --
   -----------------------

   function Priority_Grouping return UInt32 is
   begin
      return Shift_Right (SCB.AIRCR and SCB_AIRCR_PRIGROUP_Mask,
                          SCB_AIRCR_PRIGROUP_Pos);
   end Priority_Grouping;

   ---------------------------
   -- Set_Priority_Grouping --
   ---------------------------

   procedure Set_Priority_Grouping (Priority_Group : UInt32) is
      Reg_Value : UInt32;
      PriorityGroupTmp : constant UInt32 := Priority_Group and 16#07#;
      Key              : constant := 16#5FA#;
   begin
      Reg_Value := SCB.AIRCR;
      Reg_Value := Reg_Value and
        (not (SCB_AIRCR_VECTKEY_Mask or SCB_AIRCR_PRIGROUP_Mask));
      Reg_Value := Reg_Value or
        Shift_Left (Key, SCB_AIRCR_VECTKEY_Pos) or
        Shift_Left (PriorityGroupTmp, 8);
      SCB.AIRCR := Reg_Value;
   end Set_Priority_Grouping;

   ------------------
   -- Set_Priority --
   ------------------

   procedure Set_Priority
     (IRQn     : Interrupt_ID;
      Priority : UInt32)
   is
      Index : constant Natural := Integer (IRQn);
      Value : constant UInt32 :=
        Shift_Left (Priority, 8 - NVIC_PRIO_BITS) and 16#FF#;
   begin
      --  IRQ numbers are never less than 0 in the current definition, hence
      --  the code is different from that in the CMSIS.
      NVIC.IP (Index) := UInt8 (Value);
   end Set_Priority;

   ----------------------
   -- Encoded_Priority --
   ----------------------

   function Encoded_Priority
     (Priority_Group : UInt32;  Preempt_Priority : UInt32;  Subpriority : UInt32)
      return UInt32
   is
      PriorityGroupTmp    : constant UInt32 := Priority_Group and 16#07#;
      PreemptPriorityBits : UInt32;
      SubPriorityBits     : UInt32;
      Temp1 : UInt32;
      Temp2 : UInt32;
      Temp3 : UInt32;
      Temp4 : UInt32;
      Temp5 : UInt32;
   begin
      if (7 - PriorityGroupTmp) > NVIC_PRIO_BITS then
         PreemptPriorityBits := NVIC_PRIO_BITS;
      else
         PreemptPriorityBits := 7 - PriorityGroupTmp;
      end if;

      if (PriorityGroupTmp + NVIC_PRIO_BITS) < 7 then
         SubPriorityBits := 0;
      else
         SubPriorityBits := PriorityGroupTmp - 7 + NVIC_PRIO_BITS;
      end if;

      Temp1 := Shift_Left (1, Integer (PreemptPriorityBits)) - 1;
      Temp2 := Preempt_Priority and Temp1;
      Temp3 := Shift_Left (Temp2, Integer (SubPriorityBits));

      Temp4 := Shift_Left (1, Integer (SubPriorityBits)) - 1;
      Temp5 := Subpriority and Temp4;

      return Temp3 or Temp5;
   end Encoded_Priority;

   ------------------
   -- Set_Priority --
   ------------------

   procedure Set_Priority
     (IRQn             : Interrupt_ID;
      Preempt_Priority : UInt32;
      Subpriority      : UInt32)
   is
      Priority_Group : constant UInt32 := Priority_Grouping;
   begin
      Set_Priority
        (IRQn,
         Encoded_Priority (Priority_Group, Preempt_Priority, Subpriority));
   end Set_Priority;

   ----------------------
   -- Enable_Interrupt --
   ----------------------

   procedure Enable_Interrupt (IRQn : Interrupt_ID) is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
   begin
       NVIC.ISER (Index) := Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   end Enable_Interrupt;

   -----------------------
   -- Disable_Interrupt --
   -----------------------

   procedure Disable_Interrupt (IRQn : Interrupt_ID) is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
   begin
      --  NVIC->ICER[((uint32_t)(IRQn)>>5)] = (1 << ((uint32_t)(IRQn) & 0x1F));
      NVIC.ICER (Index) := Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   end Disable_Interrupt;

   ------------
   -- Active --
   ------------

   function Active (IRQn : Interrupt_ID) return Boolean is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
      Value        : constant UInt32 :=
        Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   begin
      return (NVIC.IABR (Index) and Value) /= 0;
   end Active;

   -------------
   -- Pending --
   -------------

   function Pending (IRQn : Interrupt_ID) return Boolean is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
      Value        : constant UInt32 :=
        Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   begin
      return (NVIC.ISPR (Index) and Value) /= 0;
   end Pending;

   -----------------
   -- Set_Pending --
   -----------------

   procedure Set_Pending (IRQn : Interrupt_ID) is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
   begin
      NVIC.ISPR (Index) := Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   end Set_Pending;

   -------------------
   -- Clear_Pending --
   -------------------

   procedure Clear_Pending (IRQn : Interrupt_ID) is
      IRQn_As_Word : constant UInt32 := UInt32 (IRQn);
      Index        : constant Natural :=
        Integer (Shift_Right (IRQn_As_Word, 5));
   begin
      NVIC.ICPR (Index) := Shift_Left (1, Integer (IRQn_As_Word and 16#1F#));
   end Clear_Pending;

   ------------------
   -- Reset_System --
   ------------------

   procedure Reset_System is
      Key : constant := 16#05FA#;  --  required for write to be accepted
      use Memory_Barriers;
   begin
      --  Ensure all outstanding memory accesses including
      --  buffered writes are completed
      Data_Synchronization_Barrier;

      SCB.AIRCR := Shift_Left (Key, SCB_AIRCR_VECTKEY_Pos) or
        -- keep priority group unchanged
        (SCB.AIRCR and SCB_AIRCR_PRIGROUP_Mask)  or
        SCB_AIRCR_SYSRESETREQ_Mask;

      --  TODO: why is all code from here onward in the CMSIS???

      Data_Synchronization_Barrier;

      --  wait until reset
      pragma Warnings (Off);
      <<spin>> goto spin;
      pragma Warnings (On);
   end Reset_System;

end Cortex_M.NVIC;

Fix indentation

Cortex_M.NVIC: Fix indentation