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

with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Files;
with Util.Strings;
with Util.Streams.Files;
with Util.Streams.Texts;
with Util.Streams.Buffered;

with EL.Expressions;

with Gen.Utils;
package body Gen.Artifacts.Distribs.Merges is

   use Util.Log;
   use Ada.Strings.Fixed;
   use Util.Beans.Objects;
   use Ada.Strings.Unbounded;

   procedure Process_Property (Rule : in out Merge_Rule;
                               Node : in DOM.Core.Node);

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Merges");

   --  ------------------------------
   --  Extract the <property name='{name}'>{value}</property> to setup the
   --  EL context to evaluate the source and target links for the merge.
   --  ------------------------------
   procedure Process_Property (Rule : in out Merge_Rule;
                               Node : in DOM.Core.Node) is
      use Util.Beans.Objects.Maps;

      Name  : constant String := Gen.Utils.Get_Attribute (Node, "name");
      Value : constant String := Gen.Utils.Get_Data_Content (Node);
      Pos   : constant Natural := Util.Strings.Index (Name, '.');
   begin
      if Pos = 0 then
         Rule.Variables.Bind (Name, To_Object (Value));
         return;
      end if;

      --  A composed name such as 'jquery.path' must be split so that we store
      --  the 'path' value within a 'jquery' Map_Bean object.  We handle only
      --  one such composition.
      declare
         Param : constant String := Name (Name'First .. Pos - 1);
         Tag   : constant Unbounded_String := To_Unbounded_String (Param);
         Var   : constant EL.Expressions.Expression := Rule.Variables.Get_Variable (Tag);
         Val   : Object := Rule.Params.Get_Value (Param);
         Child : Map_Bean_Access;
      begin
         if Is_Null (Val) then
            Child := new Map_Bean;
            Val := To_Object (Child);
            Rule.Params.Set_Value (Param, Val);
         else
            Child := To_Bean (Val);
         end if;
         Child.Set_Value (Name (Pos + 1 .. Name'Last), To_Object (Value));
         if Var.Is_Null then
            Rule.Variables.Bind (Param, Val);
         end if;
      end;
   end Process_Property;

   procedure Process_Replace (Rule : in out Merge_Rule;
                              Node : in DOM.Core.Node) is
      From : constant String := Gen.Utils.Get_Data_Content (Node, "from");
      To   : constant String := Gen.Utils.Get_Data_Content (Node, "to");
   begin
      Rule.Replace.Include (From, To);
   end Process_Replace;

   procedure Iterate_Properties is
      new Gen.Utils.Iterate_Nodes (Merge_Rule, Process_Property);

   procedure Iterate_Replace is
      new Gen.Utils.Iterate_Nodes (Merge_Rule, Process_Replace);

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      Result : constant Merge_Rule_Access := new Merge_Rule;
   begin
      Iterate_Properties (Result.all, Node, "property", False);
      Iterate_Replace (Result.all, Node, "replace", False);
      Result.Context.Set_Variable_Mapper (Result.Variables'Access);
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Merge_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "merge";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Merge_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is

      use Ada.Streams;

      type Mode_Type is (MERGE_NONE, MERGE_LINK, MERGE_SCRIPT);

      procedure Error (Message : in String);
      function Get_Target_Path (Link : in String) return String;
      function Get_Filename (Line : in String) return String;
      function Get_Source (Line : in String;
                           Tag  : in String) return String;
      procedure Prepare_Merge (Line : in String);
      procedure Include (Source : in String);
      procedure Process (Line : in String);

      Root_Dir : constant String :=
        Util.Files.Compose (Context.Get_Result_Directory,
                            To_String (Rule.Dir));
      Source   : constant String := Get_Source_Path (Files, False);
      Dir      : constant String := Ada.Directories.Containing_Directory (Path);
      Output   : aliased Util.Streams.Files.File_Stream;
      Merge    : aliased Util.Streams.Files.File_Stream;
      Text     : Util.Streams.Texts.Print_Stream;
      Mode     : Mode_Type := MERGE_NONE;
      Line_Num : Natural := 0;

      procedure Error (Message : in String) is
         Line : constant String := Util.Strings.Image (Line_Num);
      begin
         Context.Error (Source & ":" & Line & ": " & Message);
      end Error;

      function Get_Target_Path (Link : in String) return String is
         Expr : EL.Expressions.Expression;
         File : Util.Beans.Objects.Object;
      begin
         Expr := EL.Expressions.Create_Expression (Link, Rule.Context);
         File := Expr.Get_Value (Rule.Context);
         return Util.Files.Compose (Root_Dir, To_String (File));
      end Get_Target_Path;

      function Get_Filename (Line : in String) return String is
         Pos  : Natural := Index (Line, "link=");
         Last : Natural;
      begin
         if Pos > 0 then
            Mode := MERGE_LINK;
         else
            Pos := Index (Line, "script=");
            if Pos > 0 then
               Mode := MERGE_SCRIPT;
            end if;
            if Pos = 0 then
               return "";
            end if;
         end if;
         Pos := Index (Line, "=");

         Last := Util.Strings.Index (Line, ' ', Pos + 1);
         if Last = 0 then
            return "";
         end if;
         return Line (Pos + 1 .. Last - 1);
      end Get_Filename;

      function Get_Source (Line : in String;
                           Tag  : in String) return String is
         Pos  : Natural := Index (Line, Tag);
         Last : Natural;
      begin
         if Pos = 0 then
            return "";
         end if;
         Pos := Pos + Tag'Length;
         if Pos > Line'Last or else (Line (Pos) /= '"' and Line (Pos) /= ''') then
            return "";
         end if;
         Last := Util.Strings.Index (Line, Line (Pos), Pos + 1);
         if Last = 0 then
            return "";
         end if;
         return Line (Pos + 1 .. Last - 1);
      end Get_Source;

      procedure Prepare_Merge (Line : in String) is
         Name : constant String := Get_Filename (Line);
         Path : constant String := Get_Target_Path (Name);
      begin
         if Name'Length = 0 then
            Error ("invalid file name");
            return;
         end if;
         case Mode is
            when MERGE_LINK =>
               Text.Write ("<link media='screen' type='text/css' rel='stylesheet'"
                           & " href='");
               Text.Write (Name);
               Text.Write ("'/>" & ASCII.LF);

            when MERGE_SCRIPT =>
               Text.Write ("<script type='text/javascript' src='");
               Text.Write (Name);
               Text.Write ("'></script>" & ASCII.LF);

            when MERGE_NONE =>
               null;

         end case;
         if Rule.Level >= Util.Log.INFO_LEVEL then
            Log.Info ("  create {0}", Path);
         end if;
         Merge.Create (Mode => Ada.Streams.Stream_IO.Out_File,
                       Name => Path);
      end Prepare_Merge;

      Current_Match : Util.Strings.Maps.Cursor;

      function Find_Match (Buffer : in Stream_Element_Array) return Stream_Element_Offset is
         Iter  : Util.Strings.Maps.Cursor := Rule.Replace.First;
         First : Stream_Element_Offset := Buffer'Last + 1;
      begin
         while Util.Strings.Maps.Has_Element (Iter) loop
            declare
               Value : constant String := Util.Strings.Maps.Key (Iter);
               Match : Stream_Element_Array (1 .. Value'Length);
               for Match'Address use Value'Address;
               Pos   : Stream_Element_Offset;
            begin
               Pos := Buffer'First;
               while Pos + Match'Length < Buffer'Last loop
                  if Buffer (Pos .. Pos + Match'Length - 1) = Match then
                     if First > Pos then
                        First := Pos;
                        Current_Match := Iter;
                     end if;
                     exit;
                  end if;
                  Pos := Pos + 1;
               end loop;
            end;
            Util.Strings.Maps.Next (Iter);
         end loop;
         return First;
      end Find_Match;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ada.Streams.Stream_Element_Array,
                                        Name   => Util.Streams.Buffered.Buffer_Access);

      procedure Include (Source : in String) is
         Target : constant String := Get_Target_Path (Source);
         Input  : Util.Streams.Files.File_Stream;
         Size   : Stream_Element_Offset;
         Last   : Stream_Element_Offset;
         Pos    : Stream_Element_Offset;
         Next   : Stream_Element_Offset;
         Buffer : Util.Streams.Buffered.Buffer_Access;
      begin
         if Rule.Level >= Util.Log.INFO_LEVEL then
            Log.Info ("    include {0}", Target);
         end if;

         Input.Open (Name => Target, Mode => Ada.Streams.Stream_IO.In_File);

         Size := Stream_Element_Offset (Ada.Directories.Size (Target));
         Buffer := new Stream_Element_Array (1 .. Size);
         Input.Read (Buffer.all, Last);
         Input.Close;

         Pos := 1;
         while Pos < Last loop
            Next := Find_Match (Buffer (Pos .. Last));
            if Next > Pos then
               Merge.Write (Buffer (Pos .. Next - 1));
            end if;
            exit when Next >= Last;
            declare
               Value   : constant String := Util.Strings.Maps.Key (Current_Match);
               Replace : constant String := Util.Strings.Maps.Element (Current_Match);
               Content : Stream_Element_Array (1 .. Replace'Length);
               for Content'Address use Replace'Address;
            begin
               Merge.Write (Content);
               Pos := Next + Value'Length;
            end;
         end loop;
         Free (Buffer);

      exception
         when Ex : Ada.IO_Exceptions.Name_Error =>
            Error ("Cannot read: " & Ada.Exceptions.Exception_Message (Ex));
      end Include;

      procedure Process (Line : in String) is
         Pos : Natural;
      begin
         Line_Num := Line_Num + 1;
         case Mode is
            when MERGE_NONE =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-START ");
               if Pos = 0 then
                  Text.Write (Line);
                  Text.Write (ASCII.LF);
                  return;
               end if;
               Text.Write (Line (Line'First .. Pos - 1));
               Prepare_Merge (Line (Pos + 10 .. Line'Last));

            when MERGE_LINK =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-END ");
               if Pos > 0 then
                  Merge.Close;
                  Mode := MERGE_NONE;
                  return;
               end if;
               Include (Get_Source (Line, "href="));

            when MERGE_SCRIPT =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-END ");
               if Pos > 0 then
                  Merge.Close;
                  Mode := MERGE_NONE;
                  return;
               end if;
               Text.Write (Line (Line'First .. Pos - 1));
               Include (Get_Source (Line, "src="));

         end case;
      end Process;

   begin
      if Rule.Level >= Util.Log.INFO_LEVEL then
         Log.Info ("webmerge {0}", Path);
      end if;

      Ada.Directories.Create_Path (Dir);
      Output.Create (Name => Path, Mode => Ada.Streams.Stream_IO.Out_File);
      Text.Initialize (Output'Unchecked_Access, 16 * 1024);
      Util.Files.Read_File (Source, Process'Access);
      Text.Flush;
      Output.Close;
   end Install;

end Gen.Artifacts.Distribs.Merges;

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

with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Files;
with Util.Strings;
with Util.Streams.Files;
with Util.Streams.Texts;
with Util.Streams.Buffered;

with EL.Expressions;

with Gen.Utils;
package body Gen.Artifacts.Distribs.Merges is

   use Util.Log;
   use Ada.Strings.Fixed;
   use Util.Beans.Objects;
   use Ada.Strings.Unbounded;

   procedure Process_Property (Rule : in out Merge_Rule;
                               Node : in DOM.Core.Node);
   procedure Process_Replace (Rule : in out Merge_Rule;
                              Node : in DOM.Core.Node);

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Merges");

   --  ------------------------------
   --  Extract the <property name='{name}'>{value}</property> to setup the
   --  EL context to evaluate the source and target links for the merge.
   --  ------------------------------
   procedure Process_Property (Rule : in out Merge_Rule;
                               Node : in DOM.Core.Node) is
      use Util.Beans.Objects.Maps;

      Name  : constant String := Gen.Utils.Get_Attribute (Node, "name");
      Value : constant String := Gen.Utils.Get_Data_Content (Node);
      Pos   : constant Natural := Util.Strings.Index (Name, '.');
   begin
      if Pos = 0 then
         Rule.Variables.Bind (Name, To_Object (Value));
         return;
      end if;

      --  A composed name such as 'jquery.path' must be split so that we store
      --  the 'path' value within a 'jquery' Map_Bean object.  We handle only
      --  one such composition.
      declare
         Param : constant String := Name (Name'First .. Pos - 1);
         Tag   : constant Unbounded_String := To_Unbounded_String (Param);
         Var   : constant EL.Expressions.Expression := Rule.Variables.Get_Variable (Tag);
         Val   : Object := Rule.Params.Get_Value (Param);
         Child : Map_Bean_Access;
      begin
         if Is_Null (Val) then
            Child := new Map_Bean;
            Val := To_Object (Child);
            Rule.Params.Set_Value (Param, Val);
         else
            Child := To_Bean (Val);
         end if;
         Child.Set_Value (Name (Pos + 1 .. Name'Last), To_Object (Value));
         if Var.Is_Null then
            Rule.Variables.Bind (Param, Val);
         end if;
      end;
   end Process_Property;

   procedure Process_Replace (Rule : in out Merge_Rule;
                              Node : in DOM.Core.Node) is
      From : constant String := Gen.Utils.Get_Data_Content (Node, "from");
      To   : constant String := Gen.Utils.Get_Data_Content (Node, "to");
   begin
      Rule.Replace.Include (From, To);
   end Process_Replace;

   procedure Iterate_Properties is
      new Gen.Utils.Iterate_Nodes (Merge_Rule, Process_Property);

   procedure Iterate_Replace is
      new Gen.Utils.Iterate_Nodes (Merge_Rule, Process_Replace);

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      Result : constant Merge_Rule_Access := new Merge_Rule;
   begin
      Iterate_Properties (Result.all, Node, "property", False);
      Iterate_Replace (Result.all, Node, "replace", False);
      Result.Context.Set_Variable_Mapper (Result.Variables'Access);
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Merge_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "merge";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Merge_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is

      use Ada.Streams;

      type Mode_Type is (MERGE_NONE, MERGE_LINK, MERGE_SCRIPT);

      procedure Error (Message : in String);
      function Get_Target_Path (Link : in String) return String;
      function Get_Filename (Line : in String) return String;
      function Get_Source (Line : in String;
                           Tag  : in String) return String;
      function Find_Match (Buffer : in Stream_Element_Array) return Stream_Element_Offset;
      procedure Prepare_Merge (Line : in String);
      procedure Include (Source : in String);
      procedure Process (Line : in String);

      Root_Dir : constant String :=
        Util.Files.Compose (Context.Get_Result_Directory,
                            To_String (Rule.Dir));
      Source   : constant String := Get_Source_Path (Files, False);
      Dir      : constant String := Ada.Directories.Containing_Directory (Path);
      Build    : constant String := Context.Get_Parameter ("dynamo.build");
      Output   : aliased Util.Streams.Files.File_Stream;
      Merge    : aliased Util.Streams.Files.File_Stream;
      Text     : Util.Streams.Texts.Print_Stream;
      Mode     : Mode_Type := MERGE_NONE;
      Line_Num : Natural := 0;

      procedure Error (Message : in String) is
         Line : constant String := Util.Strings.Image (Line_Num);
      begin
         Context.Error (Source & ":" & Line & ": " & Message);
      end Error;

      function Get_Target_Path (Link : in String) return String is
         Expr : EL.Expressions.Expression;
         File : Util.Beans.Objects.Object;
      begin
         Expr := EL.Expressions.Create_Expression (Link, Rule.Context);
         File := Expr.Get_Value (Rule.Context);
         return Util.Files.Compose (Root_Dir, To_String (File));
      end Get_Target_Path;

      function Get_Filename (Line : in String) return String is
         Pos  : Natural := Index (Line, "link=");
         Last : Natural;
      begin
         if Pos > 0 then
            Mode := MERGE_LINK;
         else
            Pos := Index (Line, "script=");
            if Pos > 0 then
               Mode := MERGE_SCRIPT;
            end if;
            if Pos = 0 then
               return "";
            end if;
         end if;
         Pos := Index (Line, "=");

         Last := Util.Strings.Index (Line, ' ', Pos + 1);
         if Last = 0 then
            return "";
         end if;
         return Line (Pos + 1 .. Last - 1);
      end Get_Filename;

      function Get_Source (Line : in String;
                           Tag  : in String) return String is
         Pos  : Natural := Index (Line, Tag);
         Last : Natural;
      begin
         if Pos = 0 then
            return "";
         end if;
         Pos := Pos + Tag'Length;
         if Pos > Line'Last or else (Line (Pos) /= '"' and Line (Pos) /= ''') then
            return "";
         end if;
         Last := Util.Strings.Index (Line, Line (Pos), Pos + 1);
         if Last = 0 then
            return "";
         end if;
         return Line (Pos + 1 .. Last - 1);
      end Get_Source;

      procedure Prepare_Merge (Line : in String) is
         Name : constant String := Get_Filename (Line);
         Path : constant String := Get_Target_Path (Name);
      begin
         if Name'Length = 0 then
            Error ("invalid file name");
            return;
         end if;
         case Mode is
            when MERGE_LINK =>
               Text.Write ("<link media='screen' type='text/css' rel='stylesheet'"
                           & " href='");
               Text.Write (Name);
               Text.Write ("?build=");
               Text.Write (Build);
               Text.Write ("'/>" & ASCII.LF);

            when MERGE_SCRIPT =>
               Text.Write ("<script type='text/javascript' src='");
               Text.Write (Name);
               Text.Write ("?build=");
               Text.Write (Build);
               Text.Write ("'></script>" & ASCII.LF);

            when MERGE_NONE =>
               null;

         end case;
         if Rule.Level >= Util.Log.INFO_LEVEL then
            Log.Info ("  create {0}", Path);
         end if;
         Merge.Create (Mode => Ada.Streams.Stream_IO.Out_File,
                       Name => Path);
      end Prepare_Merge;

      Current_Match : Util.Strings.Maps.Cursor;

      function Find_Match (Buffer : in Stream_Element_Array) return Stream_Element_Offset is
         Iter  : Util.Strings.Maps.Cursor := Rule.Replace.First;
         First : Stream_Element_Offset := Buffer'Last + 1;
      begin
         while Util.Strings.Maps.Has_Element (Iter) loop
            declare
               Value : constant String := Util.Strings.Maps.Key (Iter);
               Match : Stream_Element_Array (1 .. Value'Length);
               for Match'Address use Value'Address;
               Pos   : Stream_Element_Offset;
            begin
               Pos := Buffer'First;
               while Pos + Match'Length < Buffer'Last loop
                  if Buffer (Pos .. Pos + Match'Length - 1) = Match then
                     if First > Pos then
                        First := Pos;
                        Current_Match := Iter;
                     end if;
                     exit;
                  end if;
                  Pos := Pos + 1;
               end loop;
            end;
            Util.Strings.Maps.Next (Iter);
         end loop;
         return First;
      end Find_Match;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ada.Streams.Stream_Element_Array,
                                        Name   => Util.Streams.Buffered.Buffer_Access);

      procedure Include (Source : in String) is
         Target : constant String := Get_Target_Path (Source);
         Input  : Util.Streams.Files.File_Stream;
         Size   : Stream_Element_Offset;
         Last   : Stream_Element_Offset;
         Pos    : Stream_Element_Offset;
         Next   : Stream_Element_Offset;
         Buffer : Util.Streams.Buffered.Buffer_Access;
      begin
         if Rule.Level >= Util.Log.INFO_LEVEL then
            Log.Info ("    include {0}", Target);
         end if;

         Input.Open (Name => Target, Mode => Ada.Streams.Stream_IO.In_File);

         Size := Stream_Element_Offset (Ada.Directories.Size (Target));
         Buffer := new Stream_Element_Array (1 .. Size);
         Input.Read (Buffer.all, Last);
         Input.Close;

         Pos := 1;
         while Pos < Last loop
            Next := Find_Match (Buffer (Pos .. Last));
            if Next > Pos then
               Merge.Write (Buffer (Pos .. Next - 1));
            end if;
            exit when Next >= Last;
            declare
               Value   : constant String := Util.Strings.Maps.Key (Current_Match);
               Replace : constant String := Util.Strings.Maps.Element (Current_Match);
               Content : Stream_Element_Array (1 .. Replace'Length);
               for Content'Address use Replace'Address;
            begin
               Merge.Write (Content);
               Pos := Next + Value'Length;
            end;
         end loop;
         Free (Buffer);

      exception
         when Ex : Ada.IO_Exceptions.Name_Error =>
            Error ("Cannot read: " & Ada.Exceptions.Exception_Message (Ex));
      end Include;

      procedure Process (Line : in String) is
         Pos : Natural;
      begin
         Line_Num := Line_Num + 1;
         case Mode is
            when MERGE_NONE =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-START ");
               if Pos = 0 then
                  Text.Write (Line);
                  Text.Write (ASCII.LF);
                  return;
               end if;
               Text.Write (Line (Line'First .. Pos - 1));
               Prepare_Merge (Line (Pos + 10 .. Line'Last));

            when MERGE_LINK =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-END ");
               if Pos > 0 then
                  Merge.Close;
                  Mode := MERGE_NONE;
                  return;
               end if;
               Include (Get_Source (Line, "href="));

            when MERGE_SCRIPT =>
               Pos := Index (Line, "<!-- DYNAMO-MERGE-END ");
               if Pos > 0 then
                  Merge.Close;
                  Mode := MERGE_NONE;
                  return;
               end if;
               Text.Write (Line (Line'First .. Pos - 1));
               Include (Get_Source (Line, "src="));

         end case;
      end Process;

   begin
      if Rule.Level >= Util.Log.INFO_LEVEL then
         Log.Info ("webmerge {0}", Path);
      end if;

      Ada.Directories.Create_Path (Dir);
      Output.Create (Name => Path, Mode => Ada.Streams.Stream_IO.Out_File);
      Text.Initialize (Output'Unchecked_Access, 16 * 1024);
      Util.Files.Read_File (Source, Process'Access);
      Text.Flush;
      Output.Close;
   end Install;

end Gen.Artifacts.Distribs.Merges;

Add the ?build=<build> in the generated merged link and script links


-----------------------------------------------------------------------
--  awa-events-queues -- AWA Event Queues
--  Copyright (C) 2012, 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.
-----------------------------------------------------------------------

private with Util.Refs;

with EL.Beans;
with EL.Contexts;

with AWA.Events.Models;
package AWA.Events.Queues is

   type Queue_Ref is tagged private;

   --  Queue the event.
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class);

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class));

   --  Returns true if the queue is available.
   function Has_Queue (Queue : in Queue_Ref'Class) return Boolean;

   --  Returns the queue name.
   function Get_Name (Queue : in Queue_Ref'Class) return String;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref;

   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref;

   function Null_Queue return Queue_Ref;

private

   type Queue is limited interface;
   type Queue_Access is access all Queue'Class;

   --  Get the queue name.
   function Get_Name (From : in Queue) return String is abstract;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (From : in Queue) return AWA.Events.Models.Queue_Ref is abstract;

   --  Queue the event.
   procedure Enqueue (Into  : in out Queue;
                      Event : in AWA.Events.Module_Event'Class) is abstract;

   --  Dequeue an event and process it with the Process procedure.
   procedure Dequeue (From    : in out Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is abstract;

   --  Release the queue storage.
   procedure Finalize (From : in out Queue) is null;

   type Queue_Info (Length : Natural) is new Util.Refs.Ref_Entity with record
      Queue : Queue_Access := null;
      Name  : String (1 .. Length);
   end record;
   type Queue_Info_Access is access all Queue_Info;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out Queue_Info);

   package Queue_Refs is
     new Util.Refs.Indefinite_References (Queue_Info, Queue_Info_Access);

   subtype Queue_Info_Accessor is Queue_Refs.Element_Accessor;

   type Queue_Ref is new Queue_Refs.Ref with null record;

end AWA.Events.Queues;

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

with Util.Listeners;
private with Util.Refs;

with EL.Beans;
with EL.Contexts;

with AWA.Events.Models;
package AWA.Events.Queues is

   FIFO_QUEUE_TYPE       : constant String := "fifo";
   PERSISTENT_QUEUE_TYPE : constant String := "persist";

   type Queue_Ref is tagged private;

   --  Queue the event.
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class);

   --  Dequeue an event and process it with the <b>Process</b> procedure.
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class));

   --  Add a listener that will be called each time an event is queued.
   procedure Add_Listener (Into     : in Queue_Ref;
                           Listener : in Util.Listeners.Listener_Access);

   --  Returns true if the queue is available.
   function Has_Queue (Queue : in Queue_Ref'Class) return Boolean;

   --  Returns the queue name.
   function Get_Name (Queue : in Queue_Ref'Class) return String;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (Queue : in Queue_Ref'Class) return Events.Models.Queue_Ref;

   --  Create the event queue identified by the name `Name`.  The queue factory
   --  identified by `Kind` is called to create the event queue instance.
   --  Returns a reference to the queue.
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref;

   function Null_Queue return Queue_Ref;

private

   type Queue is limited interface;
   type Queue_Access is access all Queue'Class;

   --  Get the queue name.
   function Get_Name (From : in Queue) return String is abstract;

   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   function Get_Queue (From : in Queue) return Events.Models.Queue_Ref is abstract;

   --  Queue the event.
   procedure Enqueue (Into  : in out Queue;
                      Event : in AWA.Events.Module_Event'Class) is abstract;

   --  Dequeue an event and process it with the `Process` procedure.
   procedure Dequeue (From    : in out Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is abstract;

   --  Release the queue storage.
   procedure Finalize (From : in out Queue) is null;

   type Queue_Info (Length : Natural) is new Util.Refs.Ref_Entity with record
      Queue     : Queue_Access := null;
      Listeners : Util.Listeners.List;
      Name      : String (1 .. Length);
   end record;
   type Queue_Info_Access is access all Queue_Info;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out Queue_Info);

   package Queue_Refs is
     new Util.Refs.Indefinite_References (Queue_Info, Queue_Info_Access);

   subtype Queue_Info_Accessor is Queue_Refs.Element_Accessor;

   type Queue_Ref is new Queue_Refs.Ref with null record;

end AWA.Events.Queues;

Add Add_Listener to allow registration of a listener to be notified when the queue is updated


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

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with Util.Properties;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Connections.Sqlite is

   use Ada.Strings.Unbounded;
   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
   begin
      Log.Info ("Close connection {0}", Database.Name);
      Database.Server := null;
   end Close;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      ADO.Schemas.Sqlite.Load_Schema (Database, Schema);
   end Load_Schema;

   protected body Sqlite_Connections is

      procedure Open (Config : in Configuration'Class;
                      Result : in out Ref.Ref'Class) is
         use Strings;

         URI      : constant String := Config.Get_URI;
         Database : Database_Connection_Access;
         Pos      : Database_List.Cursor := Database_List.First (List);
         DB       : SQLite_Database;
      begin
         --  Look first in the database list.
         while Database_List.Has_Element (Pos) loop
            DB := Database_List.Element (Pos);
            if DB.URI = URI then
               Database := new Database_Connection;
               Database.URI := DB.URI;
               Database.Name := DB.Name;
               Database.Server := DB.Server;
               Result := Ref.Create (Database.all'Access);
               return;
            end if;
            Database_List.Next (Pos);
         end loop;

         --  Now we can open a new database connection.
         declare
            Name     : constant String := Config.Get_Database;
            Filename : Strings.chars_ptr;
            Status   : int;
            Handle   : aliased access Sqlite3;
            Flags    : int
              := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
         begin
            if Config.Is_On (CREATE_NAME) then
               Flags := Flags + Sqlite3_H.SQLITE_OPEN_CREATE;
            end if;
            Filename := Strings.New_String (Name);
            Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                                 Flags,
                                                 Strings.Null_Ptr);

            Strings.Free (Filename);
            if Status /= Sqlite3_H.SQLITE_OK then
               declare
                  Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
                  Msg   : constant String := Strings.Value (Error);
               begin
                  Log.Error ("Cannot open SQLite database: {0}", Msg);
                  raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
               end;
            end if;

            Database := new Database_Connection;
            declare

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value);
               function Escape (Value : in Util.Properties.Value) return String;

               function Escape (Value : in Util.Properties.Value) return String is
                  S : constant String := Util.Properties.To_String (Value);
               begin
                  if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
                     return S;
                  elsif S'Length > 0 and then S (S'First) = ''' then
                     return S;
                  else
                     return "'" & S & "'";
                  end if;
               end Escape;

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value) is
                  SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
               begin
                  if Name /= CREATE_NAME then
                     if Util.Strings.Index (Name, '.') = 0 then
                        Log.Info ("Configure database with {0}", SQL);
                        ADO.Statements.Sqlite.Execute (Database.Server, SQL);
                     end if;
                  end if;

               exception
                  when SQL_Error =>
                     null;
               end Configure;

            begin
               Database.Server := Handle;
               Database.Name   := To_Unbounded_String (Config.Get_Database);
               Database.URI    := To_Unbounded_String (URI);
               Result := Ref.Create (Database.all'Access);

               DB.Server := Handle;
               DB.Name := Database.Name;
               DB.URI := Database.URI;
               Database_List.Prepend (Container => List, New_Item => DB);

               --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
               --  Typical configuration includes:
               --    synchronous=OFF
               --    temp_store=MEMORY
               --    encoding='UTF-8'
               Config.Iterate (Process => Configure'Access);
            end;
         end;
      end Open;

      procedure Clear is
         DB     : SQLite_Database;
         Result : int;
      begin
         while not Database_List.Is_Empty (List) loop
            DB := Database_List.First_Element (List);
            Database_List.Delete_First (List);
            if DB.Server /= null then
               Result := Sqlite3_H.sqlite3_close_v2 (DB.Server);
               if Result /= Sqlite3_H.SQLITE_OK then
                  declare
                     Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
                     Msg   : constant String := Strings.Value (Error);
                  begin
                     Log.Error ("Cannot close database {0}: {1}", To_String (DB.Name), Msg);
                  end;
               end if;
            end if;
         end loop;
      end Clear;

   end Sqlite_Connections;

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
   begin
      D.Map.Open (Config, Result);
   end Create_Connection;

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection.
   --  ------------------------------
   overriding
   procedure Create_Database (D           : in out Sqlite_Driver;
                              Admin       : in Configs.Configuration'Class;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      pragma Unreferenced (D, Admin);

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Messages.Append ("Command " & Command & " failed with exit code "
                            & Util.Strings.Image (Status));
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

   --  ------------------------------
   --  Deletes the SQLite driver.
   --  ------------------------------
   overriding
   procedure Finalize (D : in out Sqlite_Driver) is
   begin
      Log.Debug ("Deleting the sqlite driver");
      D.Map.Clear;
   end Finalize;

end ADO.Connections.Sqlite;

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

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with Util.Properties;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Connections.Sqlite is

   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
   begin
      Log.Info ("Close connection {0}", Database.Name);
      Database.Server := null;
   end Close;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      ADO.Schemas.Sqlite.Load_Schema (Database, Schema);
   end Load_Schema;

   protected body Sqlite_Connections is

      procedure Open (Config : in Configuration'Class;
                      Result : in out Ref.Ref'Class) is
         use Strings;

         URI      : constant String := Config.Get_URI;
         Database : Database_Connection_Access;
         Pos      : Database_List.Cursor := Database_List.First (List);
         DB       : SQLite_Database;
      begin
         --  Look first in the database list.
         while Database_List.Has_Element (Pos) loop
            DB := Database_List.Element (Pos);
            if DB.URI = URI then
               Database := new Database_Connection;
               Database.URI := DB.URI;
               Database.Name := DB.Name;
               Database.Server := DB.Server;
               Result := Ref.Create (Database.all'Access);
               return;
            end if;
            Database_List.Next (Pos);
         end loop;

         --  Now we can open a new database connection.
         declare
            Name     : constant String := Config.Get_Database;
            Filename : Strings.chars_ptr;
            Status   : int;
            Handle   : aliased access Sqlite3;
            Flags    : int
              := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
         begin
            if Config.Is_On (CREATE_NAME) then
               Flags := Flags + Sqlite3_H.SQLITE_OPEN_CREATE;
            end if;
            Filename := Strings.New_String (Name);
            Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                                 Flags,
                                                 Strings.Null_Ptr);

            Strings.Free (Filename);
            if Status /= Sqlite3_H.SQLITE_OK then
               declare
                  Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
                  Msg   : constant String := Strings.Value (Error);
               begin
                  Log.Error ("Cannot open SQLite database: {0}", Msg);
                  raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
               end;
            end if;

            Database := new Database_Connection;
            declare

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value);
               function Escape (Value : in Util.Properties.Value) return String;

               function Escape (Value : in Util.Properties.Value) return String is
                  S : constant String := Util.Properties.To_String (Value);
               begin
                  if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
                     return S;
                  elsif S'Length > 0 and then S (S'First) = ''' then
                     return S;
                  else
                     return "'" & S & "'";
                  end if;
               end Escape;

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value) is
                  SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
               begin
                  if Name /= CREATE_NAME then
                     if Util.Strings.Index (Name, '.') = 0 then
                        Log.Info ("Configure database with {0}", SQL);
                        ADO.Statements.Sqlite.Execute (Database.Server, SQL);
                     end if;
                  end if;

               exception
                  when SQL_Error =>
                     null;
               end Configure;

            begin
               Database.Server := Handle;
               Database.Name   := To_Unbounded_String (Config.Get_Database);
               Database.URI    := To_Unbounded_String (URI);
               Result := Ref.Create (Database.all'Access);

               DB.Server := Handle;
               DB.Name := Database.Name;
               DB.URI := Database.URI;
               Database_List.Prepend (Container => List, New_Item => DB);

               --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
               --  Typical configuration includes:
               --    synchronous=OFF
               --    temp_store=MEMORY
               --    encoding='UTF-8'
               Config.Iterate (Process => Configure'Access);
            end;
         end;
      end Open;

      procedure Clear is
         DB     : SQLite_Database;
         Result : int;
      begin
         while not Database_List.Is_Empty (List) loop
            DB := Database_List.First_Element (List);
            Database_List.Delete_First (List);
            if DB.Server /= null then
               Result := Sqlite3_H.sqlite3_close_v2 (DB.Server);
               if Result /= Sqlite3_H.SQLITE_OK then
                  declare
                     Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
                     Msg   : constant String := Strings.Value (Error);
                  begin
                     Log.Error ("Cannot close database {0}: {1}", To_String (DB.Name), Msg);
                  end;
               end if;
            end if;
         end loop;
      end Clear;

   end Sqlite_Connections;

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
   begin
      D.Map.Open (Config, Result);
   end Create_Connection;

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection.
   --  ------------------------------
   overriding
   procedure Create_Database (D           : in out Sqlite_Driver;
                              Admin       : in Configs.Configuration'Class;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      pragma Unreferenced (D, Admin);

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Messages.Append ("Command " & Command & " failed with exit code "
                            & Util.Strings.Image (Status));
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

   --  ------------------------------
   --  Deletes the SQLite driver.
   --  ------------------------------
   overriding
   procedure Finalize (D : in out Sqlite_Driver) is
   begin
      Log.Debug ("Deleting the sqlite driver");
      D.Map.Clear;
   end Finalize;

end ADO.Connections.Sqlite;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 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;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Vectors;
private with Util.Concurrent.Counters;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Beans.Objects.Object));

   --  Collect the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with the prefix are
   --  returned.
   procedure Get_Names (Self   : in Manager;
                        Into   : in out Util.Strings.Vectors.Vector;
                        Prefix : in String := "");

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager;
                        Name : in String) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Util.Beans.Objects.Object))
      is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 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;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Vectors;
private with Util.Concurrent.Counters;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Util.Beans.Objects.Object;

   function "+" (S : String) return Unbounded_String renames To_Unbounded_String;

   function "-" (S : Unbounded_String) return String renames To_String;

   function To_String (V : in Value) return String
     renames Util.Beans.Objects.To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Unbounded_String) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Unbounded_String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Unbounded_String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Unbounded_String);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name : in String;
                                                  Item : in Value));

   --  Collect the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with the prefix are
   --  returned.
   procedure Get_Names (Self   : in Manager;
                        Into   : in out Util.Strings.Vectors.Vector;
                        Prefix : in String := "");

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager;
                        Name : in String) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Value))
      is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Refactor the Properties implementation (step 5): - Change type Value to refer to the Object - Define To_String operation for Value type - Update operations to use Unbounded_String for some name parameters


-----------------------------------------------------------------------
--  ADO Dialects -- Driver support for basic SQL Generation
--  Copyright (C) 2010, 2011, 2012, 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.
-----------------------------------------------------------------------

--  The ADO.Drivers.Dialects package controls the database specific SQL dialects.
package ADO.Drivers.Dialects is

   --  --------------------
   --  SQL Dialect
   --  --------------------
   --  The Dialect defines the specific characteristics that must be
   --  taken into account when building the SQL statement.  This includes:
   --

   --
The definition of reserved keywords that must be escaped

   --
How to escape those keywords

   --
How to escape special characters

   --

   type Dialect is abstract tagged private;
   type Dialect_Access is access all Dialect'Class;

   --  Check if the string is a reserved keyword.
   function Is_Reserved (D    : Dialect;
                         Name : String) return Boolean is abstract;

   --  Get the quote character to escape an identifier.
   function Get_Identifier_Quote (D : in Dialect) return Character;

   --  Append the item in the buffer escaping some characters if necessary.
   --  The default implementation only escapes the single quote ' by doubling them.
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in String);

   --  Append the item in the buffer escaping some characters if necessary
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in ADO.Blob_Ref);

private

   type Dialect is abstract tagged null record;

end ADO.Drivers.Dialects;

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

--  The ADO.Drivers.Dialects package controls the database specific SQL dialects.
package ADO.Drivers.Dialects is

   --  --------------------
   --  SQL Dialect
   --  --------------------
   --  The Dialect defines the specific characteristics that must be
   --  taken into account when building the SQL statement.  This includes:
   --

   --
The definition of reserved keywords that must be escaped

   --
How to escape those keywords

   --
How to escape special characters

   --

   type Dialect is abstract tagged private;
   type Dialect_Access is access all Dialect'Class;

   --  Check if the string is a reserved keyword.
   function Is_Reserved (D    : Dialect;
                         Name : String) return Boolean is abstract;

   --  Get the quote character to escape an identifier.
   function Get_Identifier_Quote (D : in Dialect) return Character;

   --  Append the item in the buffer escaping some characters if necessary.
   --  The default implementation only escapes the single quote ' by doubling them.
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in String);

   --  Append the item in the buffer escaping some characters if necessary
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in ADO.Blob_Ref);

   --  Append the boolean item in the buffer.
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in Boolean);

private

   type Dialect is abstract tagged null record;

end ADO.Drivers.Dialects;

Declare Escape_Sql to format a boolean value


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

package body ASF.Servlets.Mappers is

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the FILTER_MAPPING, SERVLET_MAPPING or CONTEXT_PARAM field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
      use type Ada.Containers.Count_Type;

      procedure Add_Filter (Pattern : in Util.Beans.Objects.Object);
      procedure Add_Mapping (Pattern : in Util.Beans.Objects.Object);
      procedure Add_Mapping (Handler : access procedure (Pattern : in Util.Beans.Objects.Object);
                             Message : in String);

      procedure Add_Filter (Pattern : in Util.Beans.Objects.Object) is
      begin
         N.Handler.Add_Filter_Mapping (Pattern => To_String (Pattern),
                                       Name    => To_String (N.Filter_Name));
      end Add_Filter;

      procedure Add_Mapping (Pattern : in Util.Beans.Objects.Object) is
      begin
         N.Handler.Add_Mapping (Pattern => To_String (Pattern),
                                Name    => To_String (N.Servlet_Name));
      end Add_Mapping;

      procedure Add_Mapping (Handler : access procedure (Pattern : in Util.Beans.Objects.Object);
                             Message : in String) is
         Last : constant Ada.Containers.Count_Type := N.URL_Patterns.Length;
      begin
         if Last = 0 then
            raise Util.Serialize.Mappers.Field_Error with Message;
         end if;
         for I in 1 .. Last loop
            N.URL_Patterns.Query_Element (Positive (I), Handler);
         end loop;
         N.URL_Patterns.Clear;
      end Add_Mapping;

   begin
      --  <context-param>
      --    <param-name>property</param-name>
      --    <param-value>false</param-value>
      --  </context-param>
      --  <filter-mapping>
      --    <filter-name>Dump Filter</filter-name>
      --    <servlet-name>Faces Servlet</servlet-name>
      --  </filter-mapping>
      case Field is
         when FILTER_NAME =>
            N.Filter_Name := Value;

         when SERVLET_NAME =>
            N.Servlet_Name := Value;

         when URL_PATTERN =>
            N.URL_Patterns.Append (Value);

         when PARAM_NAME =>
            N.Param_Name := Value;

         when PARAM_VALUE =>
            N.Param_Value := EL.Utils.Eval (To_String (Value), N.Context.all);

         when MIME_TYPE =>
            N.Mime_Type := Value;

         when EXTENSION =>
            N.Extension := Value;

         when ERROR_CODE =>
            N.Error_Code := Value;

         when LOCATION =>
            N.Location := Value;

         when FILTER_MAPPING =>
            Add_Mapping (Add_Filter'Access, "Missing url-pattern for the filter mapping");

         when SERVLET_MAPPING =>
            Add_Mapping (Add_Mapping'Access, "Missing url-pattern for the servlet mapping");

         when CONTEXT_PARAM =>
            declare
               Name : constant String := To_String (N.Param_Name);
            begin
               --  If the context parameter already has a value, do not set it again.
               --  The value comes from an application setting and we want to keep it.
               if N.Handler.Get_Init_Parameter (Name) = "" then
                  if Util.Beans.Objects.Is_Null (N.Param_Value) then
                     N.Handler.Set_Init_Parameter (Name  => Name,
                                                   Value => "");
                  else
                     N.Handler.Set_Init_Parameter (Name  => Name,
                                                   Value => To_String (N.Param_Value));
                  end if;
               end if;
            end;

         when MIME_MAPPING =>
            null;

         when ERROR_PAGE =>
            N.Handler.Set_Error_Page (Error => To_Integer (N.Error_Code),
                                      Page  => To_String (N.Location));

      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", SMapper'Access);
      Reader.Add_Mapping ("module", SMapper'Access);
      Reader.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("filter-mapping", FILTER_MAPPING);
   SMapper.Add_Mapping ("filter-mapping/filter-name", FILTER_NAME);
   SMapper.Add_Mapping ("filter-mapping/servlet-name", SERVLET_NAME);
   SMapper.Add_Mapping ("filter-mapping/url-pattern", URL_PATTERN);

   SMapper.Add_Mapping ("servlet-mapping", SERVLET_MAPPING);
   SMapper.Add_Mapping ("servlet-mapping/servlet-name", SERVLET_NAME);
   SMapper.Add_Mapping ("servlet-mapping/url-pattern", URL_PATTERN);

   SMapper.Add_Mapping ("context-param", CONTEXT_PARAM);
   SMapper.Add_Mapping ("context-param/param-name", PARAM_NAME);
   SMapper.Add_Mapping ("context-param/param-value", PARAM_VALUE);

   SMapper.Add_Mapping ("error-page", ERROR_PAGE);
   SMapper.Add_Mapping ("error-page/error-code", ERROR_CODE);
   SMapper.Add_Mapping ("error-page/location", LOCATION);

end ASF.Servlets.Mappers;

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

package body ASF.Servlets.Mappers is

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the FILTER_MAPPING, SERVLET_MAPPING or CONTEXT_PARAM field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
      use type Ada.Containers.Count_Type;

      procedure Add_Filter (Pattern : in Util.Beans.Objects.Object);
      procedure Add_Mapping (Pattern : in Util.Beans.Objects.Object);
      procedure Add_Mapping (Handler : access procedure (Pattern : in Util.Beans.Objects.Object);
                             Message : in String);

      procedure Add_Filter (Pattern : in Util.Beans.Objects.Object) is
      begin
         N.Handler.Add_Filter_Mapping (Pattern => To_String (Pattern),
                                       Name    => To_String (N.Filter_Name));
      end Add_Filter;

      procedure Add_Mapping (Pattern : in Util.Beans.Objects.Object) is
      begin
         N.Handler.Add_Mapping (Pattern => To_String (Pattern),
                                Name    => To_String (N.Servlet_Name));
      end Add_Mapping;

      procedure Add_Mapping (Handler : access procedure (Pattern : in Util.Beans.Objects.Object);
                             Message : in String) is
         Last : constant Ada.Containers.Count_Type := N.URL_Patterns.Length;
      begin
         if Last = 0 then
            raise Util.Serialize.Mappers.Field_Error with Message;
         end if;
         for I in 0 .. Last - 1 loop
            N.URL_Patterns.Query_Element (Natural (I), Handler);
         end loop;
         N.URL_Patterns.Clear;
      end Add_Mapping;

   begin
      --  <context-param>
      --    <param-name>property</param-name>
      --    <param-value>false</param-value>
      --  </context-param>
      --  <filter-mapping>
      --    <filter-name>Dump Filter</filter-name>
      --    <servlet-name>Faces Servlet</servlet-name>
      --  </filter-mapping>
      case Field is
         when FILTER_NAME =>
            N.Filter_Name := Value;

         when SERVLET_NAME =>
            N.Servlet_Name := Value;

         when URL_PATTERN =>
            N.URL_Patterns.Append (Value);

         when PARAM_NAME =>
            N.Param_Name := Value;

         when PARAM_VALUE =>
            N.Param_Value := EL.Utils.Eval (To_String (Value), N.Context.all);

         when MIME_TYPE =>
            N.Mime_Type := Value;

         when EXTENSION =>
            N.Extension := Value;

         when ERROR_CODE =>
            N.Error_Code := Value;

         when LOCATION =>
            N.Location := Value;

         when FILTER_MAPPING =>
            Add_Mapping (Add_Filter'Access, "Missing url-pattern for the filter mapping");

         when SERVLET_MAPPING =>
            Add_Mapping (Add_Mapping'Access, "Missing url-pattern for the servlet mapping");

         when CONTEXT_PARAM =>
            declare
               Name : constant String := To_String (N.Param_Name);
            begin
               --  If the context parameter already has a value, do not set it again.
               --  The value comes from an application setting and we want to keep it.
               if N.Handler.Get_Init_Parameter (Name) = "" then
                  if Util.Beans.Objects.Is_Null (N.Param_Value) then
                     N.Handler.Set_Init_Parameter (Name  => Name,
                                                   Value => "");
                  else
                     N.Handler.Set_Init_Parameter (Name  => Name,
                                                   Value => To_String (N.Param_Value));
                  end if;
               end if;
            end;

         when MIME_MAPPING =>
            null;

         when ERROR_PAGE =>
            N.Handler.Set_Error_Page (Error => To_Integer (N.Error_Code),
                                      Page  => To_String (N.Location));

      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", SMapper'Access);
      Reader.Add_Mapping ("module", SMapper'Access);
      Reader.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("filter-mapping", FILTER_MAPPING);
   SMapper.Add_Mapping ("filter-mapping/filter-name", FILTER_NAME);
   SMapper.Add_Mapping ("filter-mapping/servlet-name", SERVLET_NAME);
   SMapper.Add_Mapping ("filter-mapping/url-pattern", URL_PATTERN);

   SMapper.Add_Mapping ("servlet-mapping", SERVLET_MAPPING);
   SMapper.Add_Mapping ("servlet-mapping/servlet-name", SERVLET_NAME);
   SMapper.Add_Mapping ("servlet-mapping/url-pattern", URL_PATTERN);

   SMapper.Add_Mapping ("context-param", CONTEXT_PARAM);
   SMapper.Add_Mapping ("context-param/param-name", PARAM_NAME);
   SMapper.Add_Mapping ("context-param/param-value", PARAM_VALUE);

   SMapper.Add_Mapping ("error-page", ERROR_PAGE);
   SMapper.Add_Mapping ("error-page/error-code", ERROR_CODE);
   SMapper.Add_Mapping ("error-page/location", LOCATION);

end ASF.Servlets.Mappers;

Fix the filter/servlet mapping installation