-----------------------------------------------------------------------
--  Util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 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 Ada.Containers;
with Ada.Containers.Indefinite_Hashed_Maps;
package Util.Strings is

   type String_Access is access all String;

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

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

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

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

end Util.Strings;

-----------------------------------------------------------------------
--  Util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 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 Ada.Containers;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Sets;
package Util.Strings is

   type String_Access is access all String;

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

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

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

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

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

end Util.Strings;

Define a package to represent and use a set of string pointers


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

with Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Nodes;
with Wiki.Streams;
with Wiki.Render;

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

   pragma Preelaborate;

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

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

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

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

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

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

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

   type Parser is tagged limited private;

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

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

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

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String);

   --  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);

private

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end Wiki.Parsers;

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

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

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

   pragma Preelaborate;

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

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

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

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

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

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

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

   type Parser is tagged limited private;

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

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

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

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String;
                    Doc    : in out Wiki.Nodes.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.Nodes.Document);

private

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end Wiki.Parsers;

Update the Parse procedure to add the Document as output


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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;

      Listeners : constant Listener_Vectors.Ref := Controller.Listeners.Get;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         declare
            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);
            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);

            Event : ASF.Events.Phases.Phase_Event (Phase);

            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end Before_Phase;

            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end After_Phase;

         begin
            Context.Set_Current_Phase (Phase);

            --  Call the before phase listeners if there are some.
            if not Listeners.Is_Empty then
               Listeners.Iterate (Before_Phase'Access);
            end if;

            begin
               Controller.Controllers (Phase).Execute (Context);
            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end;

            if not Listeners.Is_Empty then
               Listeners.Iterate (After_Phase'Access);
            end if;

            --  If exceptions have been raised and queued during the current phase, process them.
            --  An exception handler could use them to redirect the current request to another
            --  page or navigate to a specific view.
            declare
               Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
                 := Context.Get_Exception_Handler;
            begin
               if Ex /= null then
                  Ex.Handle;
               end if;
            end;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

   --  ------------------------------
   --  Add a phase listener in the lifecycle controller.
   --  ------------------------------
   procedure Add_Phase_Listener (Controller : in out Lifecycle;
                                 Listener   : in ASF.Events.Phases.Phase_Listener_Access) is
   begin
      Controller.Listeners.Append (Listener);
   end Add_Phase_Listener;

end ASF.Lifecycles;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;

      Listeners : constant Listener_Vectors.Ref := Controller.Listeners.Get;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         declare
            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);
            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);

            Event : ASF.Events.Phases.Phase_Event (Phase);

            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end Before_Phase;

            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.After_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end After_Phase;

         begin
            Context.Set_Current_Phase (Phase);

            --  Call the before phase listeners if there are some.
            Listeners.Iterate (Before_Phase'Access);

            begin
               Controller.Controllers (Phase).Execute (Context);
            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end;

            Listeners.Iterate (After_Phase'Access);

            --  If exceptions have been raised and queued during the current phase, process them.
            --  An exception handler could use them to redirect the current request to another
            --  page or navigate to a specific view.
            declare
               Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
                 := Context.Get_Exception_Handler;
            begin
               if Ex /= null then
                  Ex.Handle;
               end if;
            end;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

   --  ------------------------------
   --  Add a phase listener in the lifecycle controller.
   --  ------------------------------
   procedure Add_Phase_Listener (Controller : in out Lifecycle;
                                 Listener   : in ASF.Events.Phases.Phase_Listener_Access) is
   begin
      Controller.Listeners.Append (Listener);
   end Add_Phase_Listener;

end ASF.Lifecycles;

Fix call to After_Phase listener

Fix call to After_Phase listener


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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         begin
            Controller.Controllers (Phase).Execute (Context);
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;

         --  If exceptions have been raised and queued during the current phase, process them.
         --  An exception handler could use them to redirect the current request to another
         --  page or navigate to a specific view.
         declare
            Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
              := Context.Get_Exception_Handler;
         begin
            if Ex /= null then
               Ex.Handle;
            end if;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         begin
            Context.Set_Current_Phase (Phase);
            Controller.Controllers (Phase).Execute (Context);
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;

         --  If exceptions have been raised and queued during the current phase, process them.
         --  An exception handler could use them to redirect the current request to another
         --  page or navigate to a specific view.
         declare
            Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
              := Context.Get_Exception_Handler;
         begin
            if Ex /= null then
               Ex.Handle;
            end if;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

Set the lifecycle phase in the faces context before executing each lifecycle operation


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

with Ada.Unchecked_Deallocation;
package body Util.Refs is

   package body Indefinite_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create (Value : in Element_Access) return Ref is
      begin
         return Result : Ref do
            Result.Target := Value;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Access is
      begin
         return Object.Target;
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      protected body Atomic_Ref is
         --  ------------------------------
         --  Get the reference
         --  ------------------------------
         function Get return Ref is
         begin
            return Value;
         end Get;

         --  ------------------------------
         --  Change the reference
         --  ------------------------------
         procedure Set (Object : in Ref) is
         begin
            Value := Object;
         end Set;

      end Atomic_Ref;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Element_Type,
                                        Name   => Element_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Obj.Target.Finalize;
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end Indefinite_References;

   package body References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return IR.Create (new Element_Type);
      end Create;
   end References;

   package body General_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return Result : Ref do
            Result.Target := new Ref_Data;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return access Element_Type is
      begin
         if Object.Target /= null then
            return Object.Target.Data'Access;
         else
            raise Constraint_Error;
         end if;
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      protected body Atomic_Ref is
         --  ------------------------------
         --  Get the reference
         --  ------------------------------
         function Get return Ref is
         begin
            return Value;
         end Get;

         --  ------------------------------
         --  Change the reference
         --  ------------------------------
         procedure Set (Object : in Ref) is
         begin
            Value := Object;
         end Set;

      end Atomic_Ref;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ref_Data,
                                        Name   => Ref_Data_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Finalize (Obj.Target.Data);
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end General_References;

end Util.Refs;

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

with Ada.Unchecked_Deallocation;
package body Util.Refs is

   package body Indefinite_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create (Value : in Element_Access) return Ref is
      begin
         return Result : Ref do
            Result.Target := Value;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         return Element_Accessor '(Element => Object.Target);
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Element_Type,
                                        Name   => Element_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Obj.Target.Finalize;
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end Indefinite_References;

   package body References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return IR.Create (new Element_Type);
      end Create;
   end References;

   package body General_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return Result : Ref do
            Result.Target := new Ref_Data;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         if Object.Target /= null then
            return Element_Accessor '(Element => Object.Target.Data'Access);
         else
            raise Constraint_Error;
         end if;
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ref_Data,
                                        Name   => Ref_Data_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Finalize (Obj.Target.Data);
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end General_References;

end Util.Refs;

Refactor references to use Implicit_Dereference aspect


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

--  == Introduction ==
--  The <tt>Util.Mail</tt> package provides various operations related to sending email.

package Util.Mail is

   type Email_Address is record
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Address : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Parse the email address and separate the name from the address.
   function Parse_Address (E_Mail : in String) return Email_Address;

end Util.Mail;

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

--  == Introduction ==
--  The <tt>Util.Mail</tt> package provides various operations related to sending email.

package Util.Mail is

   type Email_Address is record
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Address : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Parse the email address and separate the name from the address.
   function Parse_Address (E_Mail : in String) return Email_Address;

   --  Extract a first name from the email address.
   function Get_First_Name (From : in Email_Address) return String;

end Util.Mail;

Declare the Get_First_Name function

Declare the Get_First_Name function


------------------------------------------------------------------------------
-- Copyright (c) 2017, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Buffers;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Printers.Pretty;

package body Natools.Web.Comment_Cookies is

   Parameters : constant Natools.S_Expressions.Printers.Pretty.Parameters
     := (Width         => 0,
         Newline_At    => (others => (others => False)),
         Space_At      => (others => (others => False)),
         Tab_Stop      => <>,
         Indentation   => 0,
         Indent        => <>,
         Quoted        => S_Expressions.Printers.Pretty.No_Quoted,
         Token         => S_Expressions.Printers.Pretty.Extended_Token,
         Hex_Casing    => <>,
         Quoted_Escape => <>,
         Char_Encoding => <>,
         Fallback      => S_Expressions.Printers.Pretty.Verbatim,
         Newline       => S_Expressions.Printers.Pretty.LF);

   function Create (A : S_Expressions.Atom)
     return S_Expressions.Atom_Refs.Immutable_Reference
     renames S_Expressions.Atom_Ref_Constructors.Create;

   procedure Set_Atom
     (Info : in out Comment_Info;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   function To_Atom (Kind : in Atom_Kind) return S_Expressions.Atom;

   procedure Initialize is new S_Expressions.Interpreter_Loop
     (Comment_Info, Meaningless_Type, Set_Atom);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Set_Atom
     (Info : in out Comment_Info;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type S_Expressions.Events.Event;
      Kind : Atom_Kind;
   begin
      if Arguments.Current_Event /= S_Expressions.Events.Add_Atom then
         return;
      end if;

      declare
         S_Name : constant String := S_Expressions.To_String (Name);
      begin
         Kind := Atom_Kind'Value (S_Name);
      exception
         when Constraint_Error =>
            Log (Severities.Error, "Unknown comment atom kind """
              & S_Name & '"');
      end;

      Info.Refs (Kind) := Create (Arguments.Current_Atom);
   end Set_Atom;

   function To_Atom (Kind : in Atom_Kind) return S_Expressions.Atom is
   begin
      case Kind is
         when Name =>
            return (Character'Pos ('N'), Character'Pos ('a'),
                    Character'Pos ('m'), Character'Pos ('e'));
         when Mail =>
            return (Character'Pos ('M'), Character'Pos ('a'),
                    Character'Pos ('i'), Character'Pos ('l'));
         when Link =>
            return (Character'Pos ('L'), Character'Pos ('n'),
                    Character'Pos ('n'), Character'Pos ('k'));
         when Filter =>
            return (Character'Pos ('F'), Character'Pos ('i'),
                    Character'Pos ('l'), Character'Pos ('t'),
                    Character'Pos ('e'), Character'Pos ('r'));
      end case;
   end To_Atom;

   -----------------------------------
   -- Comment Info Public Interface --
   -----------------------------------

   function Create
     (Name : in S_Expressions.Atom_Refs.Immutable_Reference;
      Mail : in S_Expressions.Atom_Refs.Immutable_Reference;
      Link : in S_Expressions.Atom_Refs.Immutable_Reference;
      Filter : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Comment_Info is
   begin
      return (Refs =>
        (Comment_Cookies.Name => Name,
         Comment_Cookies.Mail => Mail,
         Comment_Cookies.Link => Link,
         Comment_Cookies.Filter => Filter));
   end Create;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Comment_Info
   is
      use type S_Expressions.Events.Event;
      Result : Comment_Info := Null_Info;
      Event : S_Expressions.Events.Event;
   begin
      case Expression.Current_Event is
         when S_Expressions.Events.Add_Atom =>
            for Kind in Result.Refs'Range loop
               Result.Refs (Kind) := Create (Expression.Current_Atom);
               Expression.Next (Event);
               exit when Event /= S_Expressions.Events.Add_Atom;
            end loop;

         when S_Expressions.Events.Open_List =>
            Initialize (Expression, Result, Meaningless_Value);

         when S_Expressions.Events.Close_List
           | S_Expressions.Events.End_Of_Input
           | S_Expressions.Events.Error
         =>
            null;
      end case;

      return Result;
   end Create;

   function Named_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom
   is
      Buffer : aliased S_Expressions.Atom_Buffers.Atom_Buffer;
      Printer : S_Expressions.Printers.Pretty.Stream_Printer (Buffer'Access);
   begin
      Printer.Set_Parameters (Parameters);
      Buffer.Preallocate (120);

      for Kind in Atom_Kind loop
         if not Info.Refs (Kind).Is_Empty then
            Printer.Open_List;
            Printer.Append_Atom (To_Atom (Kind));
            Printer.Append_Atom (Info.Refs (Kind).Query);
            Printer.Close_List;
         end if;
      end loop;

      return Buffer.Data;
   end Named_Serialization;

   function Positional_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom
   is
      Buffer : aliased S_Expressions.Atom_Buffers.Atom_Buffer;
      Printer : S_Expressions.Printers.Pretty.Stream_Printer (Buffer'Access);
      Last : Atom_Kind;
   begin
      Printer.Set_Parameters (Parameters);
      Buffer.Preallocate (120);

      Last := Atom_Kind'Last;
      while Info.Refs (Last).Is_Empty loop
         if Last = Atom_Kind'First then
            return S_Expressions.Null_Atom;
         else
            Last := Atom_Kind'Pred (Last);
         end if;
      end loop;

      for Kind in Atom_Kind'First .. Last loop
         if Info.Refs (Kind).Is_Empty then
            Printer.Append_Atom (S_Expressions.Null_Atom);
         else
            Printer.Append_Atom (Info.Refs (Kind).Query);
         end if;
      end loop;

      return Buffer.Data;
   end Positional_Serialization;

   -------------------------------
   -- Codec DB Public Interface --
   -------------------------------

   function Decode
     (DB : in Codec_DB;
      Cookie : in String)
     return Comment_Info
   is
      Cursor : Decoder_Maps.Cursor;
   begin
      if Cookie'Length = 0 then
         return Null_Info;
      end if;

      Cursor := DB.Dec.Find (Cookie (Cookie'First));

      if not Decoder_Maps.Has_Element (Cursor) then
         return Null_Info;
      end if;

      declare
         use type S_Expressions.Atom;
         Parser : S_Expressions.Parsers.Memory_Parser
           := S_Expressions.Parsers.Create
              (Decoder_Maps.Element (Cursor).all (Cookie) & (1 => 0));
      begin
         Parser.Next;
         return Create (Parser);
      end;
   end Decode;

   function Encode
     (DB : in Codec_DB;
      Info : in Comment_Info)
     return String is
   begin
      if DB.Enc = null then
         raise Program_Error
           with "Comment_Cookie.Encode called before Set_Encoder";
      end if;

      case DB.Serialization is
         when Named =>
            return DB.Enc.all (Named_Serialization (Info));

         when Positional =>
            return DB.Enc.all (Positional_Serialization (Info));
      end case;
   end Encode;

   procedure Register
     (DB : in out Codec_DB;
      Key : in Character;
      Filter : in not null Decoder) is
   begin
      DB.Dec := Decoder_Maps.Include (DB.Dec, Key, Filter);
   end Register;

   procedure Set_Encoder
     (DB : in out Codec_DB;
      Filter : in not null Encoder;
      Serialization : in Serialization_Kind) is
   begin
      DB.Enc := Filter;
      DB.Serialization := Serialization;
   end Set_Encoder;

end Natools.Web.Comment_Cookies;

------------------------------------------------------------------------------
-- Copyright (c) 2017, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Buffers;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.Encodings;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Printers.Pretty;

package body Natools.Web.Comment_Cookies is

   Parameters : constant Natools.S_Expressions.Printers.Pretty.Parameters
     := (Width         => 0,
         Newline_At    => (others => (others => False)),
         Space_At      => (others => (others => False)),
         Tab_Stop      => <>,
         Indentation   => 0,
         Indent        => <>,
         Quoted        => S_Expressions.Printers.Pretty.When_Shorter,
         Token         => S_Expressions.Printers.Pretty.Extended_Token,
         Hex_Casing    => S_Expressions.Encodings.Lower,
         Quoted_Escape => S_Expressions.Printers.Pretty.Hex_Escape,
         Char_Encoding => S_Expressions.Printers.Pretty.Latin,
         Fallback      => S_Expressions.Printers.Pretty.Verbatim,
         Newline       => S_Expressions.Printers.Pretty.LF);

   function Create (A : S_Expressions.Atom)
     return S_Expressions.Atom_Refs.Immutable_Reference
     renames S_Expressions.Atom_Ref_Constructors.Create;

   procedure Set_Atom
     (Info : in out Comment_Info;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   function To_Atom (Kind : in Atom_Kind) return S_Expressions.Atom;

   procedure Initialize is new S_Expressions.Interpreter_Loop
     (Comment_Info, Meaningless_Type, Set_Atom);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Set_Atom
     (Info : in out Comment_Info;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type S_Expressions.Events.Event;
      Kind : Atom_Kind;
   begin
      if Arguments.Current_Event /= S_Expressions.Events.Add_Atom then
         return;
      end if;

      declare
         S_Name : constant String := S_Expressions.To_String (Name);
      begin
         Kind := Atom_Kind'Value (S_Name);
      exception
         when Constraint_Error =>
            Log (Severities.Error, "Unknown comment atom kind """
              & S_Name & '"');
      end;

      Info.Refs (Kind) := Create (Arguments.Current_Atom);
   end Set_Atom;

   function To_Atom (Kind : in Atom_Kind) return S_Expressions.Atom is
   begin
      case Kind is
         when Name =>
            return (Character'Pos ('N'), Character'Pos ('a'),
                    Character'Pos ('m'), Character'Pos ('e'));
         when Mail =>
            return (Character'Pos ('M'), Character'Pos ('a'),
                    Character'Pos ('i'), Character'Pos ('l'));
         when Link =>
            return (Character'Pos ('L'), Character'Pos ('n'),
                    Character'Pos ('n'), Character'Pos ('k'));
         when Filter =>
            return (Character'Pos ('F'), Character'Pos ('i'),
                    Character'Pos ('l'), Character'Pos ('t'),
                    Character'Pos ('e'), Character'Pos ('r'));
      end case;
   end To_Atom;

   -----------------------------------
   -- Comment Info Public Interface --
   -----------------------------------

   function Create
     (Name : in S_Expressions.Atom_Refs.Immutable_Reference;
      Mail : in S_Expressions.Atom_Refs.Immutable_Reference;
      Link : in S_Expressions.Atom_Refs.Immutable_Reference;
      Filter : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Comment_Info is
   begin
      return (Refs =>
        (Comment_Cookies.Name => Name,
         Comment_Cookies.Mail => Mail,
         Comment_Cookies.Link => Link,
         Comment_Cookies.Filter => Filter));
   end Create;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Comment_Info
   is
      use type S_Expressions.Events.Event;
      Result : Comment_Info := Null_Info;
      Event : S_Expressions.Events.Event;
   begin
      case Expression.Current_Event is
         when S_Expressions.Events.Add_Atom =>
            for Kind in Result.Refs'Range loop
               Result.Refs (Kind) := Create (Expression.Current_Atom);
               Expression.Next (Event);
               exit when Event /= S_Expressions.Events.Add_Atom;
            end loop;

         when S_Expressions.Events.Open_List =>
            Initialize (Expression, Result, Meaningless_Value);

         when S_Expressions.Events.Close_List
           | S_Expressions.Events.End_Of_Input
           | S_Expressions.Events.Error
         =>
            null;
      end case;

      return Result;
   end Create;

   function Named_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom
   is
      Buffer : aliased S_Expressions.Atom_Buffers.Atom_Buffer;
      Printer : S_Expressions.Printers.Pretty.Stream_Printer (Buffer'Access);
   begin
      Printer.Set_Parameters (Parameters);
      Buffer.Preallocate (120);

      for Kind in Atom_Kind loop
         if not Info.Refs (Kind).Is_Empty then
            Printer.Open_List;
            Printer.Append_Atom (To_Atom (Kind));
            Printer.Append_Atom (Info.Refs (Kind).Query);
            Printer.Close_List;
         end if;
      end loop;

      return Buffer.Data;
   end Named_Serialization;

   function Positional_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom
   is
      Buffer : aliased S_Expressions.Atom_Buffers.Atom_Buffer;
      Printer : S_Expressions.Printers.Pretty.Stream_Printer (Buffer'Access);
      Last : Atom_Kind;
   begin
      Printer.Set_Parameters (Parameters);
      Buffer.Preallocate (120);

      Last := Atom_Kind'Last;
      while Info.Refs (Last).Is_Empty loop
         if Last = Atom_Kind'First then
            return S_Expressions.Null_Atom;
         else
            Last := Atom_Kind'Pred (Last);
         end if;
      end loop;

      for Kind in Atom_Kind'First .. Last loop
         if Info.Refs (Kind).Is_Empty then
            Printer.Append_Atom (S_Expressions.Null_Atom);
         else
            Printer.Append_Atom (Info.Refs (Kind).Query);
         end if;
      end loop;

      return Buffer.Data;
   end Positional_Serialization;

   -------------------------------
   -- Codec DB Public Interface --
   -------------------------------

   function Decode
     (DB : in Codec_DB;
      Cookie : in String)
     return Comment_Info
   is
      Cursor : Decoder_Maps.Cursor;
   begin
      if Cookie'Length = 0 then
         return Null_Info;
      end if;

      Cursor := DB.Dec.Find (Cookie (Cookie'First));

      if not Decoder_Maps.Has_Element (Cursor) then
         return Null_Info;
      end if;

      declare
         use type S_Expressions.Atom;
         Parser : S_Expressions.Parsers.Memory_Parser
           := S_Expressions.Parsers.Create
              (Decoder_Maps.Element (Cursor).all (Cookie) & (1 => 0));
      begin
         Parser.Next;
         return Create (Parser);
      end;
   end Decode;

   function Encode
     (DB : in Codec_DB;
      Info : in Comment_Info)
     return String is
   begin
      if DB.Enc = null then
         raise Program_Error
           with "Comment_Cookie.Encode called before Set_Encoder";
      end if;

      case DB.Serialization is
         when Named =>
            return DB.Enc.all (Named_Serialization (Info));

         when Positional =>
            return DB.Enc.all (Positional_Serialization (Info));
      end case;
   end Encode;

   procedure Register
     (DB : in out Codec_DB;
      Key : in Character;
      Filter : in not null Decoder) is
   begin
      DB.Dec := Decoder_Maps.Include (DB.Dec, Key, Filter);
   end Register;

   procedure Set_Encoder
     (DB : in out Codec_DB;
      Filter : in not null Encoder;
      Serialization : in Serialization_Kind) is
   begin
      DB.Enc := Filter;
      DB.Serialization := Serialization;
   end Set_Encoder;

end Natools.Web.Comment_Cookies;

comment_cookies: improve the printer for (hopefully) smaller cookies


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

with Ada.Calendar;
with Ada.Strings.Hash;

with Util.Strings;
with Util.Beans.Objects;
with Util.Log.Loggers;

with ADO.Objects;
with ADO.Schemas;
with ADO.Sessions.Entities;
with AWA.Audits.Models;
with AWA.Services.Contexts;
package body AWA.Audits.Services is

   package ASC renames AWA.Services.Contexts;
   package UBO renames Util.Beans.Objects;

   use type ASC.Service_Context_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Audits.Services");

   function Hash (Item : in Field_Key) return Ada.Containers.Hash_Type is
      use type Ada.Containers.Hash_Type;
   begin
      return Ada.Containers.Hash_Type (Item.Entity) + Ada.Strings.Hash (Item.Name);
   end Hash;

   --  ------------------------------
   --  Save the audit changes in the database.
   --  ------------------------------
   overriding
   procedure Save (Manager : in out Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in ADO.Audits.Auditable_Object_Record'Class;
                   Changes : in ADO.Audits.Audit_Array) is
      Context : constant ASC.Service_Context_Access := ASC.Current;
      Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Class   : constant ADO.Schemas.Class_Mapping_Access
        := Object.Get_Key.Of_Class;
      Kind    : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : AWA.Audits.Models.Audit_Ref;
            Field : constant Util.Strings.Name_Access := Class.Members (C.Field);
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Field (Manager.Get_Audit_Field (Field.all, Kind));
            if UBO.Is_Null (C.Old_Value) then
               Audit.Set_Old_Value (ADO.Null_String);
            else
               Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            end if;
            if UBO.Is_Null (C.New_Value) then
               Audit.Set_New_Value (ADO.Null_String);
            else
               Audit.Set_New_Value (UBO.To_String (C.New_Value));
            end if;
            Audit.Set_Date (Now);
            if Context /= null then
               Audit.Set_Session (Context.Get_User_Session);
            end if;
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   --  ------------------------------
   --  Find the audit field identification number from the entity type and field name.
   --  ------------------------------
   function Get_Audit_Field (Manager : in Audit_Manager;
                             Name    : in String;
                             Entity  : in ADO.Entity_Type) return ADO.Identifier is
      Key : constant Field_Key := Field_Key '(Len    => Name'Length,
                                              Name   => Name,
                                              Entity => Entity);
      Pos : constant Audit_Field_Maps.Cursor := Manager.Fields.Find (Key);
   begin
      if Audit_Field_Maps.Has_Element (Pos) then
         return Audit_Field_Maps.Element (Pos);
      else
         Log.Warn ("Audit field {0} for {1} not found", Name, ADO.Entity_Type'Image (Entity));
         return ADO.NO_IDENTIFIER;
      end if;
   end Get_Audit_Field;

end AWA.Audits.Services;

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

with Ada.Calendar;
with Ada.Strings.Hash;

with Util.Strings;
with Util.Beans.Objects;
with Util.Log.Loggers;

with ADO.Objects;
with ADO.Schemas;
with ADO.Statements;
with ADO.Sessions.Entities;
with AWA.Audits.Models;
with AWA.Services.Contexts;
package body AWA.Audits.Services is

   package ASC renames AWA.Services.Contexts;
   package UBO renames Util.Beans.Objects;

   use type ASC.Service_Context_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Audits.Services");

   function Hash (Item : in Field_Key) return Ada.Containers.Hash_Type is
      use type Ada.Containers.Hash_Type;
   begin
      return Ada.Containers.Hash_Type (Item.Entity) + Ada.Strings.Hash (Item.Name);
   end Hash;

   --  ------------------------------
   --  Save the audit changes in the database.
   --  ------------------------------
   overriding
   procedure Save (Manager : in out Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in ADO.Audits.Auditable_Object_Record'Class;
                   Changes : in ADO.Audits.Audit_Array) is
      Context : constant ASC.Service_Context_Access := ASC.Current;
      Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Class   : constant ADO.Schemas.Class_Mapping_Access
        := Object.Get_Key.Of_Class;
      Kind    : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : AWA.Audits.Models.Audit_Ref;
            Field : constant Util.Strings.Name_Access := Class.Members (C.Field);
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Field (Manager.Get_Audit_Field (Field.all, Kind));
            if UBO.Is_Null (C.Old_Value) then
               Audit.Set_Old_Value (ADO.Null_String);
            else
               Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            end if;
            if UBO.Is_Null (C.New_Value) then
               Audit.Set_New_Value (ADO.Null_String);
            else
               Audit.Set_New_Value (UBO.To_String (C.New_Value));
            end if;
            Audit.Set_Date (Now);
            if Context /= null then
               Audit.Set_Session (Context.Get_User_Session);
            end if;
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   --  ------------------------------
   --  Find the audit field identification number from the entity type and field name.
   --  ------------------------------
   function Get_Audit_Field (Manager : in Audit_Manager;
                             Name    : in String;
                             Entity  : in ADO.Entity_Type) return Integer is
      Key : constant Field_Key := Field_Key '(Len    => Name'Length,
                                              Name   => Name,
                                              Entity => Entity);
      Pos : constant Audit_Field_Maps.Cursor := Manager.Fields.Find (Key);
   begin
      if Audit_Field_Maps.Has_Element (Pos) then
         return Audit_Field_Maps.Element (Pos);
      else
         Log.Warn ("Audit field {0} for{1} not found", Name, ADO.Entity_Type'Image (Entity));
         return 0;
      end if;
   end Get_Audit_Field;

   --  ------------------------------
   --  Initialize the audit manager.
   --  ------------------------------
   procedure Initialize (Manager : in out Audit_Manager;
                         App     : in Application_Access) is
      DB    : constant ADO.Sessions.Session := App.Get_Session;
      Stmt  : ADO.Statements.Query_Statement
        := DB.Create_Statement ("SELECT id, entity_type, name FROM awa_audit_field");
      Count : Natural := 0;
   begin
      Stmt.Execute;
      while Stmt.Has_Elements loop
         declare
            Id   : constant Integer := Stmt.Get_Integer (0);
            Kind : constant ADO.Entity_Type := ADO.Entity_Type (Stmt.Get_Integer (1));
            Name : constant String := Stmt.Get_String (2);
         begin
            Log.Debug ("Field {0} of{1} ={2}",
                       Name, ADO.Entity_Type'Image (Kind), Integer'Image (Id));
            Manager.Fields.Insert (Key => (Len => Name'Length, Name => Name, Entity => Kind),
                                   New_Item => Id);
         end;
         Count := Count + 1;
         Stmt.Next;
      end loop;
      Log.Info ("Loaded{0} audit fields", Natural'Image (Count));
   end Initialize;

end AWA.Audits.Services;

Implement the Initialize procedure to load the audit fields


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

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Os.Sys_Stat (File)",
                       Test_Stat'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Os.Sys_Stat (Directory)",
                       Test_Stat_Directory'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Sys_Stat operation.
   --  ------------------------------
   procedure Test_Stat (T : in out Test) is
      use Interfaces.C;
      use Util.Systems.Types;

      Info : array (1 .. 2) of aliased Util.Systems.Types.Stat_Type;
      Path : constant String := Util.Tests.Get_Test_Path ("regtests/files/test-1.json");
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
      Res  : Integer;
   begin
      Info (2).st_dev := 16#12345678#;
      Res := Sys_Stat (Name, Info (1)'Unchecked_Access);
      T.Assert (Res = 0, "Sys_Stat must return 0");
      T.Assert (Info (1).st_size > 0, "Sys_Stat must return the correct size");
      T.Assert (Info (2).St_Dev = 16#12345678#, "Suspecting invalid size for Stat_Type");
      T.Assert (Info (1).St_Size = off_t (Ada.Directories.Size (Path)),
                "Invalid size returned by Sys_Stat");
      T.Assert ((Info (1).St_Mode and S_IFMT) = S_IFREG, "st_mode must indicate a regular file");
      Interfaces.C.Strings.Free (Name);
   end Test_Stat;

   --  ------------------------------
   --  Test the Sys_Stat operation.
   --  ------------------------------
   procedure Test_Stat_Directory (T : in out Test) is
      use Interfaces.C;
      use Util.Systems.Types;

      Stat : aliased Util.Systems.Types.Stat_Type;
      Path : constant String := Util.Tests.Get_Test_Path ("regtests/files");
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
      Res  : Integer;
   begin
      Res := Sys_Stat (Name, Stat'Unchecked_Access);
      T.Assert (Res = 0, "Sys_Stat must return 0");
      T.Assert ((Stat.St_Mode and S_IFMT) = S_IFDIR, "st_mode must indicate a directory");
      Interfaces.C.Strings.Free (Name);
   end Test_Stat_Directory;

end Util.Systems.OS.Tests;

-----------------------------------------------------------------------
--  util-systems-os-tests -- Unit tests for OS specific operations
--  Copyright (C) 2014, 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Util.Test_Caller;
with Util.Systems.Types;
with Interfaces.C.Strings;
package body Util.Systems.Os.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Os.Sys_Stat (File)",
                       Test_Stat'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Os.Sys_Stat (Directory)",
                       Test_Stat_Directory'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Sys_Stat operation.
   --  ------------------------------
   procedure Test_Stat (T : in out Test) is
      use Interfaces.C;
      use Util.Systems.Types;

      Info : array (1 .. 2) of aliased Util.Systems.Types.Stat_Type;
      Path : constant String := Util.Tests.Get_Test_Path ("regtests/files/test-1.json");
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
      Res  : Integer;
   begin
      Info (2).st_dev := 16#12345678#;
      Res := Sys_Stat (Name, Info (1)'Unchecked_Access);
      T.Assert (Res = 0, "Sys_Stat must return 0");
      T.Assert (Info (1).st_size > 0, "Sys_Stat must return the correct size");
      T.Assert (Info (2).st_dev = 16#12345678#, "Suspecting invalid size for Stat_Type");
      T.Assert (Info (1).st_size = off_t (Ada.Directories.Size (Path)),
                "Invalid size returned by Sys_Stat");
      T.Assert ((Info (1).st_mode and S_IFMT) = S_IFREG, "st_mode must indicate a regular file");
      Interfaces.C.Strings.Free (Name);
   end Test_Stat;

   --  ------------------------------
   --  Test the Sys_Stat operation.
   --  ------------------------------
   procedure Test_Stat_Directory (T : in out Test) is
      use Interfaces.C;
      use Util.Systems.Types;

      Stat : aliased Util.Systems.Types.Stat_Type;
      Path : constant String := Util.Tests.Get_Test_Path ("regtests/files");
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
      Res  : Integer;
   begin
      Res := Sys_Stat (Name, Stat'Unchecked_Access);
      T.Assert (Res = 0, "Sys_Stat must return 0");
      T.Assert ((Stat.st_mode and S_IFMT) = S_IFDIR, "st_mode must indicate a directory");
      Interfaces.C.Strings.Free (Name);
   end Test_Stat_Directory;

end Util.Systems.Os.Tests;

Fix style warning

Fix style warning


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

with AWA.Tags.Models;
package body AWA.Tags.Beans is

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

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Tag_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

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

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Tag_List_Bean;
                            Index : in Natural) is
   begin
      From.Current := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Tag_List_Bean) return Util.Beans.Objects.Object is
   begin
      return From.List.Element (From.Current);
   end Get_Row;

   --  ------------------------------
   --  Load the tags associated with the given database identifier.
   --  ------------------------------
   procedure Load_Tags (Into          : in out Tag_List_Bean;
                        Session       : in ADO.Sessions.Session;
                        For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

--        Session     : constant ADO.Sessions.Session := Into.Module.Get_Session;
      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Tags.Models.Query_Tag_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      declare
         Stmt : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      begin
         Stmt.Execute;

         while Stmt.Has_Elements loop
            Into.List.Append (Util.Beans.Objects.To_Object (Stmt.Get_String (0)));
            Stmt.Next;
         end loop;
      end;
   end Load_Tags;

   --  ------------------------------
   --  Create the tag list bean instance.
   --  ------------------------------
   function Create_Tag_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Tag_List_Bean_Access := new Tag_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Tag_List_Bean;

end AWA.Tags.Beans;

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

with AWA.Tags.Models;
package body AWA.Tags.Beans is

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

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Tag_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

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

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Tag_List_Bean;
                            Index : in Natural) is
   begin
      From.Current := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Tag_List_Bean) return Util.Beans.Objects.Object is
   begin
      return From.List.Element (From.Current);
   end Get_Row;

   --  ------------------------------
   --  Set the entity type (database table) onto which the tags are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Tag_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Load the tags associated with the given database identifier.
   --  ------------------------------
   procedure Load_Tags (Into          : in out Tag_List_Bean;
                        Session       : in ADO.Sessions.Session;
                        For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

--        Session     : constant ADO.Sessions.Session := Into.Module.Get_Session;
      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Tags.Models.Query_Tag_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      declare
         Stmt : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      begin
         Stmt.Execute;

         while Stmt.Has_Elements loop
            Into.List.Append (Util.Beans.Objects.To_Object (Stmt.Get_String (0)));
            Stmt.Next;
         end loop;
      end;
   end Load_Tags;

   --  ------------------------------
   --  Create the tag list bean instance.
   --  ------------------------------
   function Create_Tag_List_Bean (Module : in AWA.Tags.Modules.Tag_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Tag_List_Bean_Access := new Tag_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Tag_List_Bean;

end AWA.Tags.Beans;

Implement the Set_Entity_Type procedure

Implement the Set_Entity_Type procedure