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

with Ahven;
with Ahven.Framework;
with Ahven.Results;

with Ada.Strings.Unbounded;

with GNAT.Source_Info;

--  The <b>Util.XUnit</b> package exposes a common package definition used by the Ada testutil
--  library.  This implementation exposes an implementation on top of Ahven.
--
--  Ahven is written by Tero Koskinen and licensed under permissive ISC license.
--  See http://ahven.stronglytyped.org/
package Util.XUnit is

   type Status is (Success, Failure);

   subtype Message_String is String;
   subtype Test_Suite is Ahven.Framework.Test_Suite;
   type Access_Test_Suite is access all Test_Suite;

   type Test_Access is access all Ahven.Framework.Test_Case'Class;

   type Test_Object;
   type Test_Object_Access is access all Test_Object;

   type Test_Object is record
      Test : Test_Access;
      Next : Test_Object_Access;
   end record;

   --  Register a test object in the test suite.
   procedure Register (T : in Test_Object_Access);

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

   --  Build a message with the source and line number.
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String;

   --  ------------------------------
   --  A simple test case
   --  ------------------------------
   type Test_Case is abstract new Ahven.Framework.Test_Case with null record;

   overriding
   procedure Initialize (T : in out Test_Case);

   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   --  Return the name of the test case.
   overriding
   function Get_Name (T : Test_Case) return String;

   --  Test case name (this is the AUnit function that must be implemented).
   function Name (T : in Test_Case) return Message_String is abstract;

   --  Perform the test (AUnit function to implement).
   procedure Run_Test (T : in out Test_Case) is abstract;

   --  ------------------------------
   --  A test with fixture
   --  ------------------------------
   type Test is new Ahven.Framework.Test_Case with null record;

   --  Check that the value matches what we expect.
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line);

   --  Report passes, skips, failures, and errors from the result collection.
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Time    : in Duration);

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

end Util.XUnit;

-----------------------------------------------------------------------
--  util-xunit - Unit tests on top of AHven
--  Copyright (C) 2011, 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 Ahven;
with Ahven.Framework;
with Ahven.Results;

with GNAT.Source_Info;

--  The <b>Util.XUnit</b> package exposes a common package definition used by the Ada testutil
--  library.  This implementation exposes an implementation on top of Ahven.
--
--  Ahven is written by Tero Koskinen and licensed under permissive ISC license.
--  See http://ahven.stronglytyped.org/
package Util.XUnit is

   type Status is (Success, Failure);

   subtype Message_String is String;
   subtype Test_Suite is Ahven.Framework.Test_Suite;
   type Access_Test_Suite is access all Test_Suite;

   type Test_Access is access all Ahven.Framework.Test_Case'Class;

   type Test_Object;
   type Test_Object_Access is access all Test_Object;

   type Test_Object is record
      Test : Test_Access;
      Next : Test_Object_Access;
   end record;

   --  Register a test object in the test suite.
   procedure Register (T : in Test_Object_Access);

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

   --  Build a message with the source and line number.
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String;

   --  ------------------------------
   --  A simple test case
   --  ------------------------------
   type Test_Case is abstract new Ahven.Framework.Test_Case with null record;

   overriding
   procedure Initialize (T : in out Test_Case);

   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line);

   --  Return the name of the test case.
   overriding
   function Get_Name (T : Test_Case) return String;

   --  Test case name (this is the AUnit function that must be implemented).
   function Name (T : in Test_Case) return Message_String is abstract;

   --  Perform the test (AUnit function to implement).
   procedure Run_Test (T : in out Test_Case) is abstract;

   --  ------------------------------
   --  A test with fixture
   --  ------------------------------
   type Test is new Ahven.Framework.Test_Case with null record;

   --  Check that the value matches what we expect.
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line);

   --  Report passes, skips, failures, and errors from the result collection.
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Label   : in String;
                             Time    : in Duration);

   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   generic
      with function Suite return Access_Test_Suite;
   procedure Harness (Output : in String;
                      XML    : in Boolean;
                      Label  : in String;
                      Result : out Status);

end Util.XUnit;

Add Label parameter to Harness procedure


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

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log     : constant Logger := Create ("log", "samples/log4j.properties");

   Factory : Util.Properties.Bundles.Loader;

   Bundle  : Util.Properties.Bundles.Manager;

   Locale  : Unbounded_String := To_Unbounded_String ("en");
   Result  : Ada.Strings.Unbounded.Unbounded_String;
begin
   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            Log.Info ("Usage: date -l locale format");
            return;
      end case;
   end loop;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Util.Dates.Formats.Format (Pattern => Pattern,
                                    Date    => Ada.Calendar.Clock,
                                    Bundle  => Bundle,
                                    Into    => Result);
         Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Result));
      end;
   end loop;
end Date;

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

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use type Ada.Calendar.Time;
   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log     : constant Logger := Create ("log", "samples/log4j.properties");

   Factory : Util.Properties.Bundles.Loader;

   Bundle  : Util.Properties.Bundles.Manager;

   Locale  : Unbounded_String := To_Unbounded_String ("en");
   Date    : Ada.Calendar.Time := Ada.Calendar.Clock;

begin
   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");

   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            Log.Info ("Usage: date -l locale format");
            return;
      end case;
   end loop;
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => Pattern,
                                                          Date    => Date,
                                                          Bundle  => Bundle));
      end;
   end loop;
end Date;

Update the date example so that -l option works


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

--  == Command line driver ==
--  The <tt>Util.Commands.Drivers</tt> generic package provides a support to build command line
--  tools that have different commands identified by a name.
generic
   --  The command execution context.
   type Context_Type (<>) is limited private;
   Driver_Name : String := "Drivers";
package Util.Commands.Drivers is

   --  A simple command handler executed when the command with the given name is executed.
   type Command_Handler is not null access procedure (Name    : in String;
                                                      Args    : in Argument_List'Class;
                                                      Context : in out Context_Type);

   --  A more complex command handler that has a command instance as context.
   type Command_Type is abstract tagged limited private;
   type Command_Access is access all Command_Type'Class;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is abstract;

   --  Write the help associated with the command.
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is abstract;

   --  Write the command usage.
   procedure Usage (Command : in Command_Type);

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

   type Help_Command_Type is new Command_Type with private;

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

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

   type Driver_Type is tagged limited private;

    --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access);

   --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Handler : in Command_Handler);

   --  Find the command having the given name.
   --  Returns null if the command was not found.
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access;

   --  Execute the command registered under the given name.
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

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

private

   package Command_Maps is
     new Ada.Containers.Indefinite_Ordered_Maps (Key_Type     => String,
                                                 Element_Type => Command_Access,
                                                 "<"          => "<");

   type Command_Type is abstract tagged limited record
      Driver : access Driver_Type'Class;
   end record;

   type Help_Command_Type is new Command_Type with null record;

   type Handler_Command_Type is new Command_Type with record
      Handler : Command_Handler;
   end record;

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

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

   type Driver_Type is tagged limited record
      List : Command_Maps.Map;
   end record;

end Util.Commands.Drivers;

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

--  == Command line driver ==
--  The <tt>Util.Commands.Drivers</tt> generic package provides a support to build command line
--  tools that have different commands identified by a name.
generic
   --  The command execution context.
   type Context_Type (<>) is limited private;
   Driver_Name : String := "Drivers";
package Util.Commands.Drivers is

   --  A simple command handler executed when the command with the given name is executed.
   type Command_Handler is not null access procedure (Name    : in String;
                                                      Args    : in Argument_List'Class;
                                                      Context : in out Context_Type);

   --  A more complex command handler that has a command instance as context.
   type Command_Type is abstract tagged limited private;
   type Command_Access is access all Command_Type'Class;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is abstract;

   --  Write the help associated with the command.
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is abstract;

   --  Write the command usage.
   procedure Usage (Command : in Command_Type);

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

   type Help_Command_Type is new Command_Type with private;

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

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

   type Driver_Type is tagged limited private;

   --  Set the driver description printed in the usage.
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String);

   --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access);

   --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Handler : in Command_Handler);

   --  Find the command having the given name.
   --  Returns null if the command was not found.
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access;

   --  Execute the command registered under the given name.
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

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

private

   package Command_Maps is
     new Ada.Containers.Indefinite_Ordered_Maps (Key_Type     => String,
                                                 Element_Type => Command_Access,
                                                 "<"          => "<");

   type Command_Type is abstract tagged limited record
      Driver : access Driver_Type'Class;
   end record;

   type Help_Command_Type is new Command_Type with null record;

   type Handler_Command_Type is new Command_Type with record
      Handler : Command_Handler;
   end record;

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

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

   type Driver_Type is tagged limited record
      List : Command_Maps.Map;
      Desc : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Util.Commands.Drivers;

Declare the Set_Description procedure to associate a description to the driver and have it printed in the usage


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

   type Code is mod 2**32;

   Conversion : constant String (1 .. 16) := "0123456789ABCDEF";

   procedure Put_Dec (Into  : in out Stream;
                      Value : in Code);

   procedure To_Hex (Into  : in out Stream;
                     Value : in Code);

   procedure Put (Into  : in out Stream;
                  Value : in String) is
   begin
      for I in Value'Range loop
         Put (Into, Value (I));
      end loop;
   end Put;

   --  ------------------------------
   --  Write in the output stream the value as a \uNNNN encoding form.
   --  ------------------------------
   procedure To_Hex (Into  : in out Stream;
                     Value : in Char) is
   begin
      To_Hex (Into, Code (Char'Pos (Value)));
   end To_Hex;

   --  ------------------------------
   --  Write in the output stream the value as a \uNNNN encoding form.
   --  ------------------------------
   procedure To_Hex (Into  : in out Stream;
                     Value : in Code) is
      S          : String (1 .. 6) := (1 => '\', 2 => 'u', others => '0');
      P          : Code := Value;
      N          : Code;
      I          : Positive := S'Last;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Positive'Val (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      Put (Into, S);
   end To_Hex;

   procedure Put_Dec (Into  : in out Stream;
                      Value : in Code) is
      S : String (1 .. 9) := (others => '0');
      P : Code := Value;
      N : Code;
      I : Positive := S'Last;
   begin
      while P /= 0 loop
         N := P mod 10;
         P := P / 10;
         S (I) := Conversion (Positive'Val (N + 1));
         exit when P = 0;
         I := I - 1;
      end loop;
      Put (Into, S (I .. S'Last));
   end Put_Dec;

   --  ------------------------------
   --  Capitalize the string into the result stream.
   --  ------------------------------
   procedure Capitalize (Content : in Input;
                         Into    : in out Stream) is
      Upper  : Boolean := True;
      C      : Code;
   begin
      for I in Content'Range loop
         if Upper then
            C := Char'Pos (To_Upper (Content (I)));
            Upper := False;
         else
            C := Char'Pos (To_Lower (Content (I)));
            if C = Character'Pos ('_') or C = Character'Pos ('.') or C = Character'Pos (':')
              or C = Character'Pos (';') or C = Character'Pos (',') or C = Character'Pos (' ') then
               Upper := True;
            end if;
         end if;
         Put (Into, Character'Val (C));
      end loop;
   end Capitalize;

   --  ------------------------------
   --  Capitalize the string
   --  ------------------------------
   function Capitalize (Content : Input) return Input is
      Result : Stream;
   begin
      Capitalize (Content, Result);
      return To_Input (Result);
   end Capitalize;

   --  ------------------------------
   --  Translate the input string into an upper case string in the result stream.
   --  ------------------------------
   procedure To_Upper_Case (Content : in Input;
                            Into    : in out Stream) is
      C      : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (To_Upper (Content (I)));
         Put (Into, Character'Val (C));
      end loop;
   end To_Upper_Case;

   --  ------------------------------
   --  Translate the input string into an upper case string.
   --  ------------------------------
   function To_Upper_Case (Content : Input) return Input is
      Result : Input (Content'Range);
   begin
      for I in Content'Range loop
         Result (I) := To_Upper (Content (I));
      end loop;
      return Result;
   end To_Upper_Case;

   --  ------------------------------
   --  Translate the input string into a lower case string in the result stream.
   --  ------------------------------
   procedure To_Lower_Case (Content : in Input;
                            Into    : in out Stream) is
      C      : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (To_Lower (Content (I)));
         Put (Into, Character'Val (C));
      end loop;
   end To_Lower_Case;

   --  ------------------------------
   --  Translate the input string into a lower case string in the result stream.
   --  ------------------------------
   function To_Lower_Case (Content : Input) return Input is
      Result : Input (Content'Range);
   begin
      for I in Content'Range loop
         Result (I) := To_Lower (Content (I));
      end loop;
      return Result;
   end To_Lower_Case;

   procedure Escape_Java_Script (Content : in Input;
                                 Into    : in out Stream) is
   begin
      Escape_Java (Content             => Content, Into => Into,
                   Escape_Single_Quote => True);
   end Escape_Java_Script;

   function Escape_Java_Script (Content : Input) return Input is
      Result : Stream;
   begin
      Escape_Java (Content             => Content,
                   Into                => Result,
                   Escape_Single_Quote => True);
      return To_Input (Result);
   end Escape_Java_Script;

   procedure Escape_Java (Content : in Input;
                          Into    : in out Stream) is
   begin
      Escape_Java (Content             => Content, Into => Into,
                   Escape_Single_Quote => False);
   end Escape_Java;

   function Escape_Java (Content : Input) return Input is
      Result : Stream;
   begin
      Escape_Java (Content             => Content,
                   Into                => Result,
                   Escape_Single_Quote => False);
      return To_Input (Result);
   end Escape_Java;

   procedure Escape_Java (Content             : in Input;
                          Escape_Single_Quote : in Boolean;
                          Into                : in out Stream) is
      C : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (Content (I));
         if C < 16#20# then
            if C = 16#0A# then
               Put (Into, '\');
               Put (Into, 'n');

            elsif C = 16#0D# then
               Put (Into, '\');
               Put (Into, 'r');

            elsif C = 16#08# then
               Put (Into, '\');
               Put (Into, 'b');

            elsif C = 16#09# then
               Put (Into, '\');
               Put (Into, 't');

            elsif C = 16#0C# then
               Put (Into, '\');
               Put (Into, 'f');
            else
               To_Hex (Into, C);
            end if;

         elsif C = 16#27# then
            if Escape_Single_Quote then
               Put (Into, '\');
            end if;
            Put (Into, Character'Val (C));

         elsif C = 16#22# then
            Put (Into, '\');
            Put (Into, Character'Val (C));

         elsif C = 16#5C# then
            Put (Into, '\');
            Put (Into, Character'Val (C));

         elsif C >= 16#100# then
            To_Hex (Into, C);

         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Escape_Java;

   function Escape_Xml (Content : Input) return Input is
      Result : Stream;
   begin
      Escape_Xml (Content => Content,
                  Into    => Result);
      return To_Input (Result);
   end Escape_Xml;

   --  Escape the content into the result stream using the XML
   --  escape rules:
   --   '<' -> '<'
   --   '>' -> '>'
   --   ''' -> '''
   --   '&' -> '&'
   --       -> '&#nnn;' if Character'Pos >= 128
   procedure Escape_Xml (Content : in Input;
                         Into    : in out Stream) is
      C : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (Content (I));
         if C = Character'Pos ('<') then
            Put (Into, "<");

         elsif C = Character'Pos ('>') then
            Put (Into, ">");

         elsif C = Character'Pos ('&') then
            Put (Into, "&");

         elsif C = Character'Pos (''') then
            Put (Into, "'");

         elsif C > 16#7F# then
            Put (Into, '&');
            Put (Into, '#');
            Put_Dec (Into, C);
            Put (Into, ';');

         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Escape_Xml;

   --  ------------------------------
   --  Translate the XML entity represented by <tt>Entity</tt> into an UTF-8 sequence
   --  in the output stream.
   --  ------------------------------
   procedure Translate_Xml_Entity (Entity : in Input;
                                   Into   : in out Stream) is
   begin
      if Entity (Entity'First) = Char'Val (Character'Pos ('&'))
        and then Entity (Entity'Last) = Char'Val (Character'Pos (';')) then
         case Char'Pos (Entity (Entity'First + 1)) is
            when Character'Pos ('l') =>
               if Entity'Length = 4
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('t')) then
                  Put (Into, '<');
                  return;
               end if;

            when Character'Pos ('g') =>
               if Entity'Length = 4
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('t')) then
                  Put (Into, '>');
                  return;
               end if;

            when Character'Pos ('a') =>
               if Entity'Length = 5
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('m'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('p')) then
                  Put (Into, '&');
                  return;
               end if;
               if Entity'Length = 6
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('p'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('o'))
                 and then Entity (Entity'First + 4) = Char'Val (Character'Pos ('s')) then
                  Put (Into, ''');
                  return;
               end if;

            when Character'Pos ('q') =>
               if Entity'Length = 6
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('u'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('o'))
                 and then Entity (Entity'First + 4) = Char'Val (Character'Pos ('t')) then
                  Put (Into, '"');
                  return;
               end if;

            when Character'Pos ('#') =>
               declare
                  use Interfaces;

                  V : Unsigned_32 := 0;
                  C : Code;
               begin
                  if Entity (Entity'First + 2) = Char'Val (Character'Pos ('x')) then
                     for I in Entity'First + 3 .. Entity'Last - 1 loop
                        C := Char'Pos (Entity (I));
                        if C >= Character'Pos ('0') and C <= Character'Pos ('9') then
                           V := (V * 16) + Unsigned_32 (C - Character'Pos ('0'));
                        elsif C >= Character'Pos ('a') and C <= Character'Pos ('z') then
                           V := (V * 16) + 10 + Unsigned_32 (C - Character'Pos ('a'));
                        elsif C >= Character'Pos ('A') and C <= Character'Pos ('Z') then
                           V := (V * 16) + 10 + Unsigned_32 (C - Character'Pos ('A'));
                        end if;
                     end loop;
                  else
                     for I in Entity'First + 2 .. Entity'Last - 1 loop
                        C := Char'Pos (Entity (I));
                        if C >= Character'Pos ('0') and C <= Character'Pos ('9') then
                           V := (V * 10) + Unsigned_32 (C - Character'Pos ('0'));
                        end if;
                     end loop;
                  end if;
                  if V <= 16#007F# then
                     Put (Into, Character'Val (V));
                     return;

                  elsif V <= 16#07FF# then
                     Put (Into, Character'Val (16#C0# or Interfaces.Shift_Right (V, 6)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  elsif V <= 16#0FFFF# then
                     Put (Into, Character'Val (16#D0# or Shift_Right (V, 12)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 6) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  elsif V <= 16#10FFFF# then
                     Put (Into, Character'Val (16#E0# or Shift_Right (V, 18)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 12) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 6) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  end if;
               end;

            when others =>
               null;

         end case;
      end if;

      --  Invalid entity.
   end Translate_Xml_Entity;

   --  ------------------------------
   --  Unescape the XML entities from the content into the result stream.
   --  For each XML entity found, call the <tt>Translator</tt> procedure who is responsible
   --  for writing the result in the stream.  The XML entity starts with '&' and ends with ';'.
   --  The '&' and ';' are part of the entity when given to the translator.  If the trailing
   --  ';' is not part of the entity, it means the entity was truncated or the end of input
   --  stream is reached.
   --  ------------------------------
   procedure Unescape_Xml (Content    : in Input;
                           Translator : not null access
                             procedure (Entity : in Input;
                                        Into   : in out Stream) := Translate_Xml_Entity'Access;
                           Into       : in out Stream) is
      MAX_ENTITY_LENGTH : constant Positive := 30;

      Entity : Input (1 .. MAX_ENTITY_LENGTH);
      C      : Code;
      Pos    : Natural := Content'First;
      Last   : Natural;
   begin
      while Pos <= Content'Last loop
         C := Char'Pos (Content (Pos));
         Pos := Pos + 1;
         if C = Character'Pos ('&') then
            Entity (Entity'First) := Char'Val (C);
            Last := Entity'First;
            while Pos <= Content'Last loop
               C := Char'Pos (Content (Pos));
               Pos := Pos + 1;
               if Last < Entity'Last then
                  Last := Last + 1;
                  Entity (Last) := Char'Val (C);
               end if;
               exit when C = Character'Pos (';');
            end loop;
            Translator (Entity (Entity'First .. Last), Into);
         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Unescape_Xml;

end Util.Texts.Transforms;

-----------------------------------------------------------------------
--  Util-texts -- Various Text Transformation Utilities
--  Copyright (C) 2001, 2002, 2003, 2009, 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.
-----------------------------------------------------------------------
with Interfaces;
package body Util.Texts.Transforms is

   type Code is mod 2**32;

   Conversion : constant String (1 .. 16) := "0123456789ABCDEF";

   procedure Put_Dec (Into  : in out Stream;
                      Value : in Code);

   procedure To_Hex (Into  : in out Stream;
                     Value : in Code);

   procedure Put (Into  : in out Stream;
                  Value : in String) is
   begin
      for I in Value'Range loop
         Put (Into, Value (I));
      end loop;
   end Put;

   --  ------------------------------
   --  Write in the output stream the value as a \uNNNN encoding form.
   --  ------------------------------
   procedure To_Hex (Into  : in out Stream;
                     Value : in Char) is
   begin
      To_Hex (Into, Code (Char'Pos (Value)));
   end To_Hex;

   --  ------------------------------
   --  Write in the output stream the value as a \uNNNN encoding form.
   --  ------------------------------
   procedure To_Hex (Into  : in out Stream;
                     Value : in Code) is
      S          : String (1 .. 6) := (1 => '\', 2 => 'u', others => '0');
      P          : Code := Value;
      N          : Code;
      I          : Positive := S'Last;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Positive'Val (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      Put (Into, S);
   end To_Hex;

   procedure Put_Dec (Into  : in out Stream;
                      Value : in Code) is
      S : String (1 .. 9) := (others => '0');
      P : Code := Value;
      N : Code;
      I : Positive := S'Last;
   begin
      while P /= 0 loop
         N := P mod 10;
         P := P / 10;
         S (I) := Conversion (Positive'Val (N + 1));
         exit when P = 0;
         I := I - 1;
      end loop;
      Put (Into, S (I .. S'Last));
   end Put_Dec;

   --  ------------------------------
   --  Capitalize the string into the result stream.
   --  ------------------------------
   procedure Capitalize (Content : in Input;
                         Into    : in out Stream) is
      Upper  : Boolean := True;
      C      : Code;
   begin
      for I in Content'Range loop
         if Upper then
            C := Char'Pos (To_Upper (Content (I)));
            Upper := False;
         else
            C := Char'Pos (To_Lower (Content (I)));
            if C = Character'Pos ('_') or C = Character'Pos ('.') or C = Character'Pos (':')
              or C = Character'Pos (';') or C = Character'Pos (',') or C = Character'Pos (' ')
            then
               Upper := True;
            end if;
         end if;
         Put (Into, Character'Val (C));
      end loop;
   end Capitalize;

   --  ------------------------------
   --  Capitalize the string
   --  ------------------------------
   function Capitalize (Content : Input) return Input is
      Upper  : Boolean := True;
      C      : Code;
      Result : Input (Content'Range);
   begin
      for I in Content'Range loop
         if Upper then
            C := Char'Pos (To_Upper (Content (I)));
            Upper := False;
         else
            C := Char'Pos (To_Lower (Content (I)));
            if C = Character'Pos ('_') or C = Character'Pos ('.') or C = Character'Pos (':')
              or C = Character'Pos (';') or C = Character'Pos (',') or C = Character'Pos (' ')
            then
               Upper := True;
            end if;
         end if;
         Result (I) := Char'Val (C);
      end loop;
      return Result;
   end Capitalize;

   --  ------------------------------
   --  Translate the input string into an upper case string in the result stream.
   --  ------------------------------
   procedure To_Upper_Case (Content : in Input;
                            Into    : in out Stream) is
      C      : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (To_Upper (Content (I)));
         Put (Into, Character'Val (C));
      end loop;
   end To_Upper_Case;

   --  ------------------------------
   --  Translate the input string into an upper case string.
   --  ------------------------------
   function To_Upper_Case (Content : Input) return Input is
      Result : Input (Content'Range);
   begin
      for I in Content'Range loop
         Result (I) := To_Upper (Content (I));
      end loop;
      return Result;
   end To_Upper_Case;

   --  ------------------------------
   --  Translate the input string into a lower case string in the result stream.
   --  ------------------------------
   procedure To_Lower_Case (Content : in Input;
                            Into    : in out Stream) is
      C      : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (To_Lower (Content (I)));
         Put (Into, Character'Val (C));
      end loop;
   end To_Lower_Case;

   --  ------------------------------
   --  Translate the input string into a lower case string in the result stream.
   --  ------------------------------
   function To_Lower_Case (Content : Input) return Input is
      Result : Input (Content'Range);
   begin
      for I in Content'Range loop
         Result (I) := To_Lower (Content (I));
      end loop;
      return Result;
   end To_Lower_Case;

   procedure Escape_Java_Script (Content : in Input;
                                 Into    : in out Stream) is
   begin
      Escape_Java (Content             => Content, Into => Into,
                   Escape_Single_Quote => True);
   end Escape_Java_Script;

   procedure Escape_Java (Content : in Input;
                          Into    : in out Stream) is
   begin
      Escape_Java (Content             => Content, Into => Into,
                   Escape_Single_Quote => False);
   end Escape_Java;

   procedure Escape_Java (Content             : in Input;
                          Escape_Single_Quote : in Boolean;
                          Into                : in out Stream) is
      C : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (Content (I));
         if C < 16#20# then
            if C = 16#0A# then
               Put (Into, '\');
               Put (Into, 'n');

            elsif C = 16#0D# then
               Put (Into, '\');
               Put (Into, 'r');

            elsif C = 16#08# then
               Put (Into, '\');
               Put (Into, 'b');

            elsif C = 16#09# then
               Put (Into, '\');
               Put (Into, 't');

            elsif C = 16#0C# then
               Put (Into, '\');
               Put (Into, 'f');
            else
               To_Hex (Into, C);
            end if;

         elsif C = 16#27# then
            if Escape_Single_Quote then
               Put (Into, '\');
            end if;
            Put (Into, Character'Val (C));

         elsif C = 16#22# then
            Put (Into, '\');
            Put (Into, Character'Val (C));

         elsif C = 16#5C# then
            Put (Into, '\');
            Put (Into, Character'Val (C));

         elsif C >= 16#100# then
            To_Hex (Into, C);

         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Escape_Java;

   --  ------------------------------
   --  Escape the content into the result stream using the XML
   --  escape rules:
   --   '<' -> '<'
   --   '>' -> '>'
   --   ''' -> '''
   --   '&' -> '&'
   --       -> '&#nnn;' if Character'Pos >= 128
   --  ------------------------------
   procedure Escape_Xml (Content : in Input;
                         Into    : in out Stream) is
      C : Code;
   begin
      for I in Content'Range loop
         C := Char'Pos (Content (I));
         if C = Character'Pos ('<') then
            Put (Into, "<");

         elsif C = Character'Pos ('>') then
            Put (Into, ">");

         elsif C = Character'Pos ('&') then
            Put (Into, "&");

         elsif C = Character'Pos (''') then
            Put (Into, "'");

         elsif C > 16#7F# then
            Put (Into, '&');
            Put (Into, '#');
            Put_Dec (Into, C);
            Put (Into, ';');

         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Escape_Xml;

   --  ------------------------------
   --  Translate the XML entity represented by <tt>Entity</tt> into an UTF-8 sequence
   --  in the output stream.
   --  ------------------------------
   procedure Translate_Xml_Entity (Entity : in Input;
                                   Into   : in out Stream) is
   begin
      if Entity (Entity'First) = Char'Val (Character'Pos ('&'))
        and then Entity (Entity'Last) = Char'Val (Character'Pos (';'))
      then
         case Char'Pos (Entity (Entity'First + 1)) is
            when Character'Pos ('l') =>
               if Entity'Length = 4
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('t'))
               then
                  Put (Into, '<');
                  return;
               end if;

            when Character'Pos ('g') =>
               if Entity'Length = 4
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('t'))
               then
                  Put (Into, '>');
                  return;
               end if;

            when Character'Pos ('a') =>
               if Entity'Length = 5
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('m'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('p'))
               then
                  Put (Into, '&');
                  return;
               end if;
               if Entity'Length = 6
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('p'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('o'))
                 and then Entity (Entity'First + 4) = Char'Val (Character'Pos ('s'))
               then
                  Put (Into, ''');
                  return;
               end if;

            when Character'Pos ('q') =>
               if Entity'Length = 6
                 and then Entity (Entity'First + 2) = Char'Val (Character'Pos ('u'))
                 and then Entity (Entity'First + 3) = Char'Val (Character'Pos ('o'))
                 and then Entity (Entity'First + 4) = Char'Val (Character'Pos ('t'))
               then
                  Put (Into, '"');
                  return;
               end if;

            when Character'Pos ('#') =>
               declare
                  use Interfaces;

                  V : Unsigned_32 := 0;
                  C : Code;
               begin
                  if Entity (Entity'First + 2) = Char'Val (Character'Pos ('x')) then
                     for I in Entity'First + 3 .. Entity'Last - 1 loop
                        C := Char'Pos (Entity (I));
                        if C >= Character'Pos ('0') and C <= Character'Pos ('9') then
                           V := (V * 16) + Unsigned_32 (C - Character'Pos ('0'));
                        elsif C >= Character'Pos ('a') and C <= Character'Pos ('z') then
                           V := (V * 16) + 10 + Unsigned_32 (C - Character'Pos ('a'));
                        elsif C >= Character'Pos ('A') and C <= Character'Pos ('Z') then
                           V := (V * 16) + 10 + Unsigned_32 (C - Character'Pos ('A'));
                        end if;
                     end loop;
                  else
                     for I in Entity'First + 2 .. Entity'Last - 1 loop
                        C := Char'Pos (Entity (I));
                        if C >= Character'Pos ('0') and C <= Character'Pos ('9') then
                           V := (V * 10) + Unsigned_32 (C - Character'Pos ('0'));
                        end if;
                     end loop;
                  end if;
                  if V <= 16#007F# then
                     Put (Into, Character'Val (V));
                     return;

                  elsif V <= 16#07FF# then
                     Put (Into, Character'Val (16#C0# or Interfaces.Shift_Right (V, 6)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  elsif V <= 16#0FFFF# then
                     Put (Into, Character'Val (16#D0# or Shift_Right (V, 12)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 6) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  elsif V <= 16#10FFFF# then
                     Put (Into, Character'Val (16#E0# or Shift_Right (V, 18)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 12) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (Shift_Right (V, 6) and 16#03F#)));
                     Put (Into, Character'Val (16#80# or (V and 16#03F#)));
                     return;

                  end if;
               end;

            when others =>
               null;

         end case;
      end if;

      --  Invalid entity.
   end Translate_Xml_Entity;

   --  ------------------------------
   --  Unescape the XML entities from the content into the result stream.
   --  For each XML entity found, call the <tt>Translator</tt> procedure who is responsible
   --  for writing the result in the stream.  The XML entity starts with '&' and ends with ';'.
   --  The '&' and ';' are part of the entity when given to the translator.  If the trailing
   --  ';' is not part of the entity, it means the entity was truncated or the end of input
   --  stream is reached.
   --  ------------------------------
   procedure Unescape_Xml (Content    : in Input;
                           Translator : not null access
                             procedure (Entity : in Input;
                                        Into   : in out Stream) := Translate_Xml_Entity'Access;
                           Into       : in out Stream) is
      MAX_ENTITY_LENGTH : constant Positive := 30;

      Entity : Input (1 .. MAX_ENTITY_LENGTH);
      C      : Code;
      Pos    : Natural := Content'First;
      Last   : Natural;
   begin
      while Pos <= Content'Last loop
         C := Char'Pos (Content (Pos));
         Pos := Pos + 1;
         if C = Character'Pos ('&') then
            Entity (Entity'First) := Char'Val (C);
            Last := Entity'First;
            while Pos <= Content'Last loop
               C := Char'Pos (Content (Pos));
               Pos := Pos + 1;
               if Last < Entity'Last then
                  Last := Last + 1;
                  Entity (Last) := Char'Val (C);
               end if;
               exit when C = Character'Pos (';');
            end loop;
            Translator (Entity (Entity'First .. Last), Into);
         else
            Put (Into, Character'Val (C));
         end if;
      end loop;
   end Unescape_Xml;

end Util.Texts.Transforms;

Remove the functions which cannot be implemented for a Stream undefinite type


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

with Util.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;
      use Interfaces;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Lock.Write;

      --  Generate the random sequence.
      for I in 0 .. Factory.Id_Size - 1 loop
         declare
            Value : constant Unsigned_32 := Id_Random.Random (Factory.Random);
         begin
            Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
            Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
            Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
            Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
         end;
      end loop;
      Factory.Lock.Release_Write;

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access
        := new Session_Record '(Ada.Finalization.Limited_Controlled with
                                Ref_Counter  => Util.Concurrent.Counters.ONE,
                                Create_Time  => Ada.Calendar.Clock,
                                Max_Inactive => Factory.Max_Inactive,
                                others       => <>);
   begin
      Impl.Access_Time := Impl.Create_Time;
      Sess.Impl        := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Lock.Write;
      Factory.Sessions.Insert (Impl.Id.all'Access, Sess);
      Factory.Lock.Release_Write;

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      null;
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Null_Session;
      Factory.Lock.Read;
      declare
         Pos : constant Session_Maps.Cursor := Factory.Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            Result := Session_Maps.Element (Pos);
         end if;
      end;
      Factory.Lock.Release_Read;

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Id_Random.Reset (Factory.Random);
   end Initialize;

end ASF.Sessions.Factory;

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

with Util.Encoders.Base64;
with Util.Log.Loggers;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package body ASF.Sessions.Factory is

   use Ada.Finalization;
   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   --  ------------------------------
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access) is
      use Ada.Streams;

      Rand    : Stream_Element_Array (0 .. 4 * Factory.Id_Size - 1);
      Buffer  : Stream_Element_Array (0 .. 4 * 3 * Factory.Id_Size);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Stream_Element_Offset;
      Encoded : Stream_Element_Offset;
   begin
      Factory.Sessions.Generate_Id (Rand);

      --  Encode the random stream in base64 and save it into the Id string.
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);

      Id := new String (1 .. Natural (Encoded + 1));
      for I in 0 .. Encoded loop
         Id (Natural (I + 1)) := Character'Val (Buffer (I));
      end loop;

      Log.Info ("Allocated session {0}", Id.all);
   end Allocate_Session_Id;

   --  ------------------------------
   --  Create a new session
   --  ------------------------------
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session) is

      Sess    : Session;
      Impl    : constant Session_Record_Access
        := new Session_Record '(Ada.Finalization.Limited_Controlled with
                                Ref_Counter  => Util.Concurrent.Counters.ONE,
                                Create_Time  => Ada.Calendar.Clock,
                                Max_Inactive => Factory.Max_Inactive,
                                others       => <>);
   begin
      Impl.Access_Time := Impl.Create_Time;
      Sess.Impl        := Impl;

      Session_Factory'Class (Factory).Allocate_Session_Id (Impl.Id);

      Factory.Sessions.Insert (Sess);

      Result := Sess;
   end Create_Session;

   --  ------------------------------
   --  Deletes the session.
   --  ------------------------------
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session) is
   begin
      null;
   end Delete_Session;

   --  ------------------------------
   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   --  ------------------------------
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session) is
   begin
      Result := Factory.Sessions.Find (Id);

      if Result.Is_Valid then
         Result.Impl.Access_Time := Ada.Calendar.Clock;
         Log.Info ("Found active session {0}", Id);
      else
         Log.Info ("Invalid session {0}", Id);
      end if;
   end Find_Session;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration is
   begin
      return Factory.Max_Inactive;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration) is
   begin
      Factory.Max_Inactive := Interval;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Initialize the session factory.
   --  ------------------------------
   overriding
   procedure Initialize (Factory : in out Session_Factory) is
   begin
      Factory.Sessions.Initialize;
   end Initialize;

   protected body Session_Cache is

      --  ------------------------------
      --  Find the session in the session cache.
      --  ------------------------------
      function Find (Id : in String) return Session is
         Pos : constant Session_Maps.Cursor := Sessions.Find (Id'Unrestricted_Access);
      begin
         if Session_Maps.Has_Element (Pos) then
            return Session_Maps.Element (Pos);
         else
            return Null_Session;
         end if;
      end Find;

      --  ------------------------------
      --  Insert the session in the session cache.
      --  ------------------------------
      procedure Insert (Sess : in Session) is
      begin
         Sessions.Insert (Sess.Impl.Id.all'Access, Sess);
      end Insert;

      --  ------------------------------
      --  Generate a random bitstream.
      --  ------------------------------
      procedure Generate_Id (Rand : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;
         use Interfaces;

         Size : Stream_Element_Offset := Rand'Length / 4;
      begin
         --  Generate the random sequence.
         for I in 0 .. Size - 1 loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Random);
            begin
               Rand (4 * I)     := Stream_Element (Value and 16#0FF#);
               Rand (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Rand (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Rand (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate_Id;

      --  ------------------------------
      --  Initialize the random generator.
      --  ------------------------------
      procedure Initialize is
      begin
         Id_Random.Reset (Random);
      end Initialize;

   end Session_Cache;

end ASF.Sessions.Factory;

Use a protected type for the session cache management and session id generation


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

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Rest");

   --  ------------------------------
   --  Get the permission index associated with the REST operation.
   --  ------------------------------
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index is
   begin
      return Handler.Permission;
   end Get_Permission;

   --  ------------------------------
   --  Register the API descriptor in a list.
   --  ------------------------------
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access) is
   begin
      Item.Next := List;
      List := Item;
   end Register;

   --  ------------------------------
   --  Register the list of API descriptors for a given servlet and a root path.
   --  ------------------------------
   procedure Register (Registry  : in out ASF.Servlets.Servlet_Registry;
                       Name      : in String;
                       URI       : in String;
                       ELContext : in EL.Contexts.ELContext'Class;
                       List      : in Descriptor_Access) is
      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);
      use type ASF.Routes.Route_Type_Access;
      Item : Descriptor_Access := List;

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0}/{1} already used by another page",
                          URI, Item.Pattern.all);
               return;
            end if;
            D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
         else
            D := ASF.Servlets.Rest.Create_Route (Registry, Name);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Item.Method) /= null then
            Log.Error ("Route API for {0}/{1} is already used", URI, Item.Pattern.all);
         end if;
         D.Descriptors (Item.Method) := Item;
      end Insert;

   begin
      Log.Info ("Adding API route {0}", URI);
      while Item /= null loop
         Log.Debug ("Adding API route {0}/{1}", URI, Item.Pattern.all);
         Registry.Add_Route (URI & "/" & Item.Pattern.all, ELContext, Insert'Access);
         Item := Item.Next;
      end loop;
   end Register;

end ASF.Rest;

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

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Rest");

   --  ------------------------------
   --  Get the permission index associated with the REST operation.
   --  ------------------------------
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index is
   begin
      return Handler.Permission;
   end Get_Permission;

   --  ------------------------------
   --  Register the API descriptor in a list.
   --  ------------------------------
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access) is
   begin
      Item.Next := List;
      List := Item;
   end Register;

   --  ------------------------------
   --  Register the list of API descriptors for a given servlet and a root path.
   --  ------------------------------
   procedure Register (Registry  : in out ASF.Servlets.Servlet_Registry;
                       Name      : in String;
                       URI       : in String;
                       ELContext : in EL.Contexts.ELContext'Class;
                       List      : in Descriptor_Access) is
      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);
      use type ASF.Routes.Route_Type_Access;
      Item : Descriptor_Access := List;

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0}/{1} already used by another page",
                          URI, Item.Pattern.all);
               return;
            end if;
            D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
         else
            D := ASF.Servlets.Rest.Create_Route (Registry, Name);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Item.Method) /= null then
            Log.Error ("Route API for {0}/{1} is already used", URI, Item.Pattern.all);
         end if;
         D.Descriptors (Item.Method) := Item;
      end Insert;

   begin
      Log.Info ("Adding API route {0}", URI);
      while Item /= null loop
         Log.Debug ("Adding API route {0}/{1}", URI, Item.Pattern.all);
         Registry.Add_Route (URI & "/" & Item.Pattern.all, ELContext, Insert'Access);
         Item := Item.Next;
      end loop;
   end Register;

   --  Dispatch the request to the API handler.
   overriding
   procedure Dispatch (Handler : in Static_Descriptor;
                       Req     : in out ASF.Rest.Request'Class;
                       Reply   : in out ASF.Rest.Response'Class;
                       Stream  : in out Output_Stream'Class) is
   begin
      Handler.Handler (Req, Reply, Stream);
   end Dispatch;

   --  Register the API definition in the servlet registry.
   procedure Register (Registry   : in out ASF.Servlets.Servlet_Registry'Class;
                       Definition : in Descriptor_Access) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Servlets.Servlet_Access;

      Dispatcher : constant ASF.Servlets.Request_Dispatcher
         := Registry.Get_Request_Dispatcher (Definition.Pattern.all);
      Servlet    : ASF.Servlets.Servlet_Access := ASF.Servlets.Get_Servlet (Dispatcher);

      procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
         R : constant ASF.Routes.Route_Type_Access := Route.Value;
         D : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
      begin
         if R /= null then
            if not (R.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
               Log.Error ("Route API for {0} already used by another page",
                          Definition.Pattern.all);
               return;
            end if;
            D := ASF.Routes.Servlets.Rest.API_Route_Type (R.all)'Access;
         else
            D := ASF.Servlets.Rest.Create_Route (Servlet);
            Route := ASF.Routes.Route_Type_Refs.Create (D.all'Access);
         end if;
         if D.Descriptors (Definition.Method) /= null then
            Log.Error ("Route API for {0} is already used", Definition.Pattern.all);
         end if;
         D.Descriptors (Definition.Method) := Definition;
      end Insert;

      Ctx     : EL.Contexts.Default.Default_Context;
   begin
      if Servlet = null then
         Log.Error ("Cannot register REST operation {0}: no REST servlet",
                    Definition.Pattern.all);
         return;
      end if;
      Registry.Add_Route (Definition.Pattern.all, Ctx, Insert'Access);
   end Register;

end ASF.Rest;

Implement the Dispatch and Register operation


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

with ADO.Sequences.Hilo;
with ADO.Schemas.Entities;
with ADO.Queries.Loaders;

package body ADO.Sessions.Factory is

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
   begin
      R.Impl := S;
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      S.Queries  := Factory.Queries'Unrestricted_Access;
      Factory.Source.Create_Connection (S.Database);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy;
      Util.Concurrent.Counters.Increment (R.Impl.Counter);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
   begin
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      S.Queries  := Factory.Queries'Unrestricted_Access;
      Factory.Source.Create_Connection (S.Database);
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source) is
   begin
      Factory.Source := Source;
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      ADO.Queries.Loaders.Initialize (Factory.Queries, Factory.Source);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      ADO.Queries.Loaders.Initialize (Factory.Queries, Factory.Source);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

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

with ADO.Sequences.Hilo;
with ADO.Schemas.Entities;
with ADO.Queries.Loaders;

package body ADO.Sessions.Factory is

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
   begin
      R.Impl := S;
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      S.Queries  := Factory.Queries'Unrestricted_Access;
      Factory.Source.Create_Connection (S.Database);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the Session_Error exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise Session_Error;
      end if;
      R.Impl := Proxy;
      Util.Concurrent.Counters.Increment (R.Impl.Counter);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
   begin
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      S.Queries  := Factory.Queries'Unrestricted_Access;
      Factory.Source.Create_Connection (S.Database);
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source) is
   begin
      Factory.Source := Source;
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      ADO.Queries.Loaders.Initialize (Factory.Queries, Factory.Source);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      ADO.Queries.Loaders.Initialize (Factory.Queries, Factory.Source);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

Raise the Session_Error exception instead of SESSION_EXPIRED