-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012, 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;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  Return the list of role names separated by ','.
   function To_String (List : in Role_Name_Array) return String;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Mapper : in out Util.Serialize.Mappers.Processing);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 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 Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The `Security.Policies.Roles` package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the `Role_Policy` must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: `admin` and `manager`
--  It defines a permission `create-workspace` that will be granted if the
--  user has either the `admin` or the `manager` role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a `Role_Type`.  To provide an efficient implementation, the `Role_Type`
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A `Security_Context` must be associated with a set of roles before checking the
--  permission.  This is done by using the `Set_Role_Context` operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  Return the list of role names separated by ','.
   function To_String (List : in Role_Name_Array) return String;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Mapper : in out Util.Serialize.Mappers.Processing);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

Update the documentation

Update the documentation


-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 2016, 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.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character);

   --  Enable or disable the double quotes by default for strings.
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean);

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the attribute with a null value.
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write an entity with a null value.
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
      Separator   : Character := ',';
      Quote       : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
      Sink        : access Reader'Class;
   end record;

end Util.Serialize.IO.CSV;

-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 2016, 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.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character);

   --  Enable or disable the double quotes by default for strings.
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean);

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the attribute with a null value.
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write an entity with a null value.
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Input_Buffer_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
      Separator   : Character := ',';
      Quote       : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
      Sink        : access Reader'Class;
   end record;

end Util.Serialize.IO.CSV;

Use the Input_Buffer_Stream instead of Buffered_Stream


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

   use type Ada.Calendar.Time;
   use type Ada.Directories.File_Size;

   --  ------------------------------
   --  Format the file pattern with the date and index to produce a file path.
   --  ------------------------------
   function Format (Pattern : in String;
                    Date    : in Ada.Calendar.Time;
                    Index   : in Natural) return String is
      Pos    : Natural := Pattern'First;
      Result : Unbounded_String;
      Info   : Util.Dates.Date_Record;
      First  : Natural;
   begin
      Util.Dates.Split (Info, Date);
      while Pos <= Pattern'Last loop
         if Pattern (Pos) /= '%' or else Pos = Pattern'Last then
            Ada.Strings.Unbounded.Append (Result, Pattern (Pos));
            Pos := Pos + 1;
         elsif Pattern (Pos + 1) = 'i' then
            Ada.Strings.Unbounded.Append (Result, Util.Strings.Image (Index));
            Pos := Pos + 2;
         elsif Pos + 3 < Pattern'Last and then Pattern (Pos + 1) = 'd'
           and then Pattern (Pos + 2) = '{'
         then
            Pos := Pos + 3;
            First := Pos;
            while Pos <= Pattern'Last and Pattern (Pos) /= '}' loop
               Pos := Pos + 1;
            end loop;
            Append (Result, Util.Dates.Simple_Format (Pattern (First .. Pos - 1), Date));
            Pos := Pos + 1;
         else
            Ada.Strings.Unbounded.Append (Result, Pattern (Pos));
            Pos := Pos + 1;
         end if;
      end loop;
      return To_String (Result);
   end Format;

   --  ------------------------------
   --  Initialize the file manager to roll the file referred by `Path` by using
   --  the pattern defined in `Pattern`.
   --  ------------------------------
   procedure Initialize (Manager  : in out File_Manager;
                         Path     : in String;
                         Pattern  : in String;
                         Policy   : in Policy_Type;
                         Strategy : in Strategy_Type) is
   begin
      Manager.Deadline := Ada.Calendar.Clock;
      Manager.File_Path := To_Unbounded_String (Path);
      Manager.Pattern := To_Unbounded_String (Pattern);
      Manager.Cur_Index := 0;
      Manager.Policy := Policy.Kind;
      case Policy.Kind is
         when Size_Policy | Size_Time_Policy | Time_Policy =>
            Manager.Max_Size := Policy.Size;
            Manager.Interval := Policy.Interval;

         when others =>
            null;

      end case;
      Manager.Strategy := Strategy.Kind;
      case Strategy.Kind is
         when Ascending_Strategy | Descending_Strategy =>
            Manager.Min_Index := Strategy.Min_Index;
            Manager.Max_Index := Strategy.Max_Index;
            Manager.Max_Files := Manager.Max_Index - Manager.Min_Index;

         when Direct_Strategy =>
            Manager.Max_Files := Strategy.Max_Files;

      end case;
      Manager.Rollover;
   end Initialize;

   --  ------------------------------
   --  Get the current path (it may or may not exist).
   --  ------------------------------
   function Get_Current_Path (Manager : in File_Manager) return String is
   begin
      return To_String (Manager.File_Path);
   end Get_Current_Path;

   --  ------------------------------
   --  Check if a rollover is necessary based on the rolling strategy.
   --  ------------------------------
   function Is_Rollover_Necessary (Manager : in out File_Manager) return Boolean is
      Now : Ada.Calendar.Time;
   begin
      if Manager.Policy = No_Policy then
         return False;
      end if;

      if Manager.Policy = Time_Policy then
         Now := Ada.Calendar.Clock;
         if Now < Manager.Deadline then
            return False;
         end if;
         --  Continue checking if the path has changed.
      end if;

      declare
         Current : constant String := To_String (Manager.File_Path);
         Exists  : constant Boolean := Ada.Directories.Exists (Current);
      begin
         if not Exists and Manager.Policy = Size_Policy then
            return False;
         end if;

         if Exists and then Manager.Policy in Size_Policy | Size_Time_Policy
           and then Ada.Directories.Size (Current) >= Manager.Max_Size
         then
            return True;
         end if;

         if Manager.Policy = Size_Policy then
            return False;
         end if;

         --  Time_Policy or Size_Time_Policy
         Now := Ada.Calendar.Clock;
         if Now < Manager.Deadline then
            return False;
         end if;

         --  Check if the file pattern was changed due to the date.
         declare
            Pat  : constant String := To_String (Manager.Pattern);
            Path : constant String := Format (Pattern => Pat,
                                              Date    => Now,
                                              Index   => Manager.Cur_Index);
         begin
            --  Get a new deadline to check for time change.
            Manager.Deadline := Now + Duration (Manager.Interval);
            return Current /= Path;
         end;

      exception
         when Ada.Directories.Name_Error =>
            --  Even if we check for file existence, an exception could
            --  be raised if the file is moved/deleted.
            return False;
      end;
   end Is_Rollover_Necessary;

   --  ------------------------------
   --  Perform a rollover according to the strategy that was configured.
   --  ------------------------------
   procedure Rollover (Manager : in out File_Manager) is
   begin
      case (Manager.Strategy) is
         when Ascending_Strategy =>
            Manager.Rollover_Ascending;

         when Descending_Strategy =>
            Manager.Rollover_Descending;

         when Direct_Strategy =>
            Manager.Rollover_Direct;

      end case;
   end Rollover;

   procedure Rollover_Ascending (Manager : in out File_Manager) is
      Now   : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Old   : constant String := Manager.Get_Current_Path;
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Now,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
      Names : Util.Strings.Vectors.Vector;
      First : Natural := 0;
      Last  : Natural := 0;
   begin
      if Ada.Directories.Exists (Dir) then
         Manager.Eligible_Files (Dir, Names, First, Last);

         while Natural (Names.Length) > Manager.Max_Files loop
            begin
               Ada.Directories.Delete_File (Compose (Dir, Names.First_Element));

            exception
               when Ada.Directories.Name_Error =>
                  null;
            end;
            Names.Delete_First;
         end loop;
      end if;

      Manager.Cur_Index := Last + 1;

      --  Too many files, rename old ones.
      if Manager.Cur_Index > Manager.Max_Index then
         Manager.Cur_Index := Manager.Max_Index - Natural (Names.Length);
         for Name of Names loop
            Manager.Rename (Compose (Dir, Name));
            Manager.Cur_Index := Manager.Cur_Index + 1;
         end loop;
      end if;

      Manager.Rename (Old);
   end Rollover_Ascending;

   procedure Rename (Manager : in File_Manager;
                     Old     : in String) is
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Manager.Deadline,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      if Ada.Directories.Exists (Old) then
         if not Ada.Directories.Exists (Dir) then
            Ada.Directories.Create_Path (Dir);
         end if;

         Util.Files.Rename (Old_Name => Old,
                            New_Name => Path);
      end if;
   end Rename;

   procedure Rollover_Descending (Manager : in out File_Manager) is
      Now   : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Old   : constant String := Manager.Get_Current_Path;
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Now,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
      Names : Util.Strings.Vectors.Vector;
      First : Natural := 0;
      Last  : Natural := 0;
   begin
      if Ada.Directories.Exists (Dir) then
         Manager.Eligible_Files (Dir, Names, First, Last);

         while Natural (Names.Length) > Manager.Max_Files loop
            begin
               Ada.Directories.Delete_File (Compose (Dir, Names.Last_Element));

            exception
               when Ada.Directories.Name_Error =>
                  null;
            end;
            Names.Delete_Last;
         end loop;
      end if;

      Manager.Cur_Index := First;

      if not Names.Is_Empty then
         Manager.Cur_Index := Manager.Min_Index + Natural (Names.Length);
         for Name of reverse Names loop
            Manager.Rename (Compose (Dir, Name));
            Manager.Cur_Index := Manager.Cur_Index - 1;
         end loop;
      end if;

      Manager.Rename (Old);
   end Rollover_Descending;

   procedure Rollover_Direct (Manager : in out File_Manager) is
   begin
      null;
   end Rollover_Direct;

   --  ------------------------------
   --  Get the regex pattern to identify a file that must be purged.
   --  The default is to extract the file pattern part of the file manager pattern.
   --  ------------------------------
   function Get_Purge_Pattern (Manager : in File_Manager) return String is
      Full_Pat : constant String := To_String (Manager.Pattern);
      Name_Pat : constant String := Ada.Directories.Simple_Name (Full_Pat);
      Pos      : Natural := Name_Pat'First;
      Result   : Unbounded_String;
      Found    : Boolean := False;
   begin
      while Pos <= Name_Pat'Last loop
         if Name_Pat (Pos) = '%' and then Pos + 1 <= Name_Pat'Last
           and then Name_Pat (Pos + 1) = 'i'
         then
            if not Found then
               Append (Result, "([0-9]+)");
               Found := True;
            else
               Append (Result, "[0-9]+");
            end if;
            Pos := Pos + 2;
         elsif Pos + 3 < Name_Pat'Last and then Name_Pat (Pos + 1) = 'd'
           and then Name_Pat (Pos + 2) = '{'
         then
            Pos := Pos + 3;
            while Pos <= Name_Pat'Last and then Name_Pat (Pos) /= '}' loop
               if Pos + 3 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 3) = "YYYY" then
                  Pos := Pos + 4;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "MM" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "dd" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "HH" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "mm" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "ss" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               else
                  Append (Result, Name_Pat (Pos));
                  Pos := Pos + 1;
               end if;
            end loop;
            Pos := Pos + 1;

         else
            Append (Result, Name_Pat (Pos));
            Pos := Pos + 1;
         end if;
      end loop;
      return To_String (Result);
   end Get_Purge_Pattern;

   --  ------------------------------
   --  Find the files that are eligible to purge in the given directory.
   --  ------------------------------
   procedure Eligible_Files (Manager     : in out File_Manager;
                             Path        : in String;
                             Names       : in out Util.Strings.Vectors.Vector;
                             First_Index : out Natural;
                             Last_Index  : out Natural) is
      function Get_Index (Name : in String) return Natural;
      function Compare (Left, Right : in String) return Boolean;

      Search_Filter : constant Ada.Directories.Filter_Type
        := (Ada.Directories.Ordinary_File => True,
            Ada.Directories.Directory     => False,
            Ada.Directories.Special_File  => False);
      Pattern  : constant String := Manager.Get_Purge_Pattern;
      Regex    : constant GNAT.Regpat.Pattern_Matcher := GNAT.Regpat.Compile (Pattern);
      Glob1    : constant String := Util.Strings.Replace (Pattern, "([0-9]+)", "*", False);
      Glob2    : constant String := Util.Strings.Replace (Glob1, "[0-9]+", "*", False);
      Search   : Ada.Directories.Search_Type;
      Ent      : Ada.Directories.Directory_Entry_Type;

      function Get_Index (Name : in String) return Natural is
         Matches : GNAT.Regpat.Match_Array (0 .. 1);
      begin
         if GNAT.Regpat.Match (Regex, Name) then
            GNAT.Regpat.Match (Regex, Name, Matches);
            return Natural'Value (Name (Matches (1).First .. Matches (1).Last));
         else
            return 0;
         end if;

      exception
         when others =>
            return 0;
      end Get_Index;

      function Compare (Left, Right : in String) return Boolean is
         Left_Index  : constant Natural := Get_Index (Left);
         Right_Index : constant Natural := Get_Index (Right);
      begin
         return Left_Index < Right_Index;
      end Compare;

      package Sort_Names is new Util.Strings.Vectors.Generic_Sorting (Compare);
   begin
      Ada.Directories.Start_Search (Search,
                                    Directory => Path,
                                    Pattern   => Glob2,
                                    Filter    => Search_Filter);
      while Ada.Directories.More_Entries (Search) loop
         Ada.Directories.Get_Next_Entry (Search, Ent);
         declare
            Name    : constant String := Ada.Directories.Simple_Name (Ent);
         begin
            Names.Append (Name);
         end;
      end loop;
      Sort_Names.Sort (Names);
      if not Names.Is_Empty then
         First_Index := Get_Index (Names.First_Element);
         Last_Index := Get_Index (Names.Last_Element);
      else
         First_Index := Manager.Min_Index;
         Last_Index := Manager.Min_Index;
      end if;
   end Eligible_Files;

end Util.Files.Rolling;

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

   use type Ada.Calendar.Time;
   use type Ada.Directories.File_Size;

   --  ------------------------------
   --  Format the file pattern with the date and index to produce a file path.
   --  ------------------------------
   function Format (Pattern : in String;
                    Date    : in Ada.Calendar.Time;
                    Index   : in Natural) return String is
      Pos    : Natural := Pattern'First;
      Result : Unbounded_String;
      Info   : Util.Dates.Date_Record;
      First  : Natural;
   begin
      Util.Dates.Split (Info, Date);
      while Pos <= Pattern'Last loop
         if Pattern (Pos) /= '%' or else Pos = Pattern'Last then
            Ada.Strings.Unbounded.Append (Result, Pattern (Pos));
            Pos := Pos + 1;
         elsif Pattern (Pos + 1) = 'i' then
            Ada.Strings.Unbounded.Append (Result, Util.Strings.Image (Index));
            Pos := Pos + 2;
         elsif Pos + 3 < Pattern'Last and then Pattern (Pos + 1) = 'd'
           and then Pattern (Pos + 2) = '{'
         then
            Pos := Pos + 3;
            First := Pos;
            while Pos <= Pattern'Last and Pattern (Pos) /= '}' loop
               Pos := Pos + 1;
            end loop;
            Append (Result, Util.Dates.Simple_Format (Pattern (First .. Pos - 1), Date));
            Pos := Pos + 1;
         else
            Ada.Strings.Unbounded.Append (Result, Pattern (Pos));
            Pos := Pos + 1;
         end if;
      end loop;
      return To_String (Result);
   end Format;

   --  ------------------------------
   --  Initialize the file manager to roll the file referred by `Path` by using
   --  the pattern defined in `Pattern`.
   --  ------------------------------
   procedure Initialize (Manager  : in out File_Manager;
                         Path     : in String;
                         Pattern  : in String;
                         Policy   : in Policy_Type;
                         Strategy : in Strategy_Type) is
   begin
      Manager.Deadline := Ada.Calendar.Clock;
      Manager.File_Path := To_Unbounded_String (Path);
      Manager.Pattern := To_Unbounded_String (Pattern);
      Manager.Cur_Index := 0;
      Manager.Policy := Policy.Kind;
      case Policy.Kind is
         when Size_Policy | Size_Time_Policy | Time_Policy =>
            Manager.Max_Size := Policy.Size;
            Manager.Interval := Policy.Interval;

         when others =>
            null;

      end case;
      Manager.Strategy := Strategy.Kind;
      case Strategy.Kind is
         when Ascending_Strategy | Descending_Strategy =>
            Manager.Min_Index := Strategy.Min_Index;
            Manager.Max_Index := Strategy.Max_Index;
            Manager.Max_Files := Manager.Max_Index - Manager.Min_Index;

         when Direct_Strategy =>
            Manager.Max_Files := Strategy.Max_Files;

      end case;
      Manager.Rollover;
   end Initialize;

   --  ------------------------------
   --  Get the current path (it may or may not exist).
   --  ------------------------------
   function Get_Current_Path (Manager : in File_Manager) return String is
   begin
      return To_String (Manager.File_Path);
   end Get_Current_Path;

   --  ------------------------------
   --  Check if a rollover is necessary based on the rolling strategy.
   --  ------------------------------
   function Is_Rollover_Necessary (Manager : in out File_Manager) return Boolean is
      Now : Ada.Calendar.Time;
   begin
      if Manager.Policy = No_Policy then
         return False;
      end if;

      if Manager.Policy = Time_Policy then
         Now := Ada.Calendar.Clock;
         if Now < Manager.Deadline then
            return False;
         end if;
         --  Continue checking if the path has changed.
      end if;

      declare
         Current : constant String := To_String (Manager.File_Path);
         Exists  : constant Boolean := Ada.Directories.Exists (Current);
      begin
         if not Exists and Manager.Policy = Size_Policy then
            return False;
         end if;

         if Exists and then Manager.Policy in Size_Policy | Size_Time_Policy
           and then Ada.Directories.Size (Current) >= Manager.Max_Size
         then
            return True;
         end if;

         if Manager.Policy = Size_Policy then
            return False;
         end if;

         --  Time_Policy or Size_Time_Policy
         Now := Ada.Calendar.Clock;
         if Now < Manager.Deadline then
            return False;
         end if;

         --  Check if the file pattern was changed due to the date.
         declare
            Pat  : constant String := To_String (Manager.Pattern);
            Path : constant String := Format (Pattern => Pat,
                                              Date    => Now,
                                              Index   => Manager.Cur_Index);
         begin
            --  Get a new deadline to check for time change.
            Manager.Deadline := Now + Duration (Manager.Interval);
            return Path /= Manager.Last_Path;
         end;

      exception
         when Ada.Directories.Name_Error =>
            --  Even if we check for file existence, an exception could
            --  be raised if the file is moved/deleted.
            return False;
      end;
   end Is_Rollover_Necessary;

   --  ------------------------------
   --  Perform a rollover according to the strategy that was configured.
   --  ------------------------------
   procedure Rollover (Manager : in out File_Manager) is
   begin
      case (Manager.Strategy) is
         when Ascending_Strategy =>
            Manager.Rollover_Ascending;

         when Descending_Strategy =>
            Manager.Rollover_Descending;

         when Direct_Strategy =>
            Manager.Rollover_Direct;

      end case;
   end Rollover;

   procedure Rollover_Ascending (Manager : in out File_Manager) is
      Now   : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Old   : constant String := Manager.Get_Current_Path;
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Now,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
      Names : Util.Strings.Vectors.Vector;
      First : Natural := 0;
      Last  : Natural := 0;
   begin
      if Ada.Directories.Exists (Dir) then
         Manager.Eligible_Files (Dir, Names, First, Last);

         while Natural (Names.Length) > Manager.Max_Files loop
            begin
               Ada.Directories.Delete_File (Compose (Dir, Names.First_Element));

            exception
               when Ada.Directories.Name_Error =>
                  null;
            end;
            Names.Delete_First;
         end loop;
      end if;

      Manager.Cur_Index := Last + 1;

      --  Too many files, rename old ones.
      if Manager.Cur_Index > Manager.Max_Index then
         Manager.Cur_Index := Manager.Max_Index - Natural (Names.Length);
         for Name of Names loop
            Manager.Rename (Compose (Dir, Name));
            Manager.Cur_Index := Manager.Cur_Index + 1;
         end loop;
      end if;

      Manager.Rename (Old);
   end Rollover_Ascending;

   procedure Rename (Manager : in out File_Manager;
                     Old     : in String) is
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Manager.Deadline,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      if Ada.Directories.Exists (Old) then
         if not Ada.Directories.Exists (Dir) then
            Ada.Directories.Create_Path (Dir);
         end if;

         Util.Files.Rename (Old_Name => Old,
                            New_Name => Path);
         Manager.Last_Path := To_Unbounded_String (Path);
      end if;
   end Rename;

   procedure Rollover_Descending (Manager : in out File_Manager) is
      Now   : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Old   : constant String := Manager.Get_Current_Path;
      Path  : constant String := Format (Pattern => To_String (Manager.Pattern),
                                         Date    => Now,
                                         Index   => Manager.Cur_Index);
      Dir   : constant String := Ada.Directories.Containing_Directory (Path);
      Names : Util.Strings.Vectors.Vector;
      First : Natural := 0;
      Last  : Natural := 0;
   begin
      if Ada.Directories.Exists (Dir) then
         Manager.Eligible_Files (Dir, Names, First, Last);

         while Natural (Names.Length) > Manager.Max_Files loop
            begin
               Ada.Directories.Delete_File (Compose (Dir, Names.Last_Element));

            exception
               when Ada.Directories.Name_Error =>
                  null;
            end;
            Names.Delete_Last;
         end loop;
      end if;

      Manager.Cur_Index := First;

      if not Names.Is_Empty then
         Manager.Cur_Index := Manager.Min_Index + Natural (Names.Length);
         for Name of reverse Names loop
            Manager.Rename (Compose (Dir, Name));
            Manager.Cur_Index := Manager.Cur_Index - 1;
         end loop;
      end if;

      Manager.Rename (Old);
   end Rollover_Descending;

   procedure Rollover_Direct (Manager : in out File_Manager) is
   begin
      null;
   end Rollover_Direct;

   --  ------------------------------
   --  Get the regex pattern to identify a file that must be purged.
   --  The default is to extract the file pattern part of the file manager pattern.
   --  ------------------------------
   function Get_Purge_Pattern (Manager : in File_Manager) return String is
      Full_Pat : constant String := To_String (Manager.Pattern);
      Name_Pat : constant String := Ada.Directories.Simple_Name (Full_Pat);
      Pos      : Natural := Name_Pat'First;
      Result   : Unbounded_String;
      Found    : Boolean := False;
   begin
      while Pos <= Name_Pat'Last loop
         if Name_Pat (Pos) = '%' and then Pos + 1 <= Name_Pat'Last
           and then Name_Pat (Pos + 1) = 'i'
         then
            if not Found then
               Append (Result, "([0-9]+)");
               Found := True;
            else
               Append (Result, "[0-9]+");
            end if;
            Pos := Pos + 2;
         elsif Pos + 3 < Name_Pat'Last and then Name_Pat (Pos + 1) = 'd'
           and then Name_Pat (Pos + 2) = '{'
         then
            Pos := Pos + 3;
            while Pos <= Name_Pat'Last and then Name_Pat (Pos) /= '}' loop
               if Pos + 3 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 3) = "YYYY" then
                  Pos := Pos + 4;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "MM" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "dd" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "HH" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "mm" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               elsif Pos + 1 <= Name_Pat'Last and then Name_Pat (Pos .. Pos + 1) = "ss" then
                  Pos := Pos + 2;
                  Append (Result, "[0-9]+");
               else
                  Append (Result, Name_Pat (Pos));
                  Pos := Pos + 1;
               end if;
            end loop;
            Pos := Pos + 1;

         else
            Append (Result, Name_Pat (Pos));
            Pos := Pos + 1;
         end if;
      end loop;
      return To_String (Result);
   end Get_Purge_Pattern;

   --  ------------------------------
   --  Find the files that are eligible to purge in the given directory.
   --  ------------------------------
   procedure Eligible_Files (Manager     : in out File_Manager;
                             Path        : in String;
                             Names       : in out Util.Strings.Vectors.Vector;
                             First_Index : out Natural;
                             Last_Index  : out Natural) is
      function Get_Index (Name : in String) return Natural;
      function Compare (Left, Right : in String) return Boolean;

      Search_Filter : constant Ada.Directories.Filter_Type
        := (Ada.Directories.Ordinary_File => True,
            Ada.Directories.Directory     => False,
            Ada.Directories.Special_File  => False);
      Pattern  : constant String := Manager.Get_Purge_Pattern;
      Regex    : constant GNAT.Regpat.Pattern_Matcher := GNAT.Regpat.Compile (Pattern);
      Glob1    : constant String := Util.Strings.Replace (Pattern, "([0-9]+)", "*", False);
      Glob2    : constant String := Util.Strings.Replace (Glob1, "[0-9]+", "*", False);
      Search   : Ada.Directories.Search_Type;
      Ent      : Ada.Directories.Directory_Entry_Type;

      function Get_Index (Name : in String) return Natural is
         Matches : GNAT.Regpat.Match_Array (0 .. 1);
      begin
         if GNAT.Regpat.Match (Regex, Name) then
            GNAT.Regpat.Match (Regex, Name, Matches);
            return Natural'Value (Name (Matches (1).First .. Matches (1).Last));
         else
            return 0;
         end if;

      exception
         when others =>
            return 0;
      end Get_Index;

      function Compare (Left, Right : in String) return Boolean is
         Left_Index  : constant Natural := Get_Index (Left);
         Right_Index : constant Natural := Get_Index (Right);
      begin
         return Left_Index < Right_Index;
      end Compare;

      package Sort_Names is new Util.Strings.Vectors.Generic_Sorting (Compare);
   begin
      Ada.Directories.Start_Search (Search,
                                    Directory => Path,
                                    Pattern   => Glob2,
                                    Filter    => Search_Filter);
      while Ada.Directories.More_Entries (Search) loop
         Ada.Directories.Get_Next_Entry (Search, Ent);
         declare
            Name    : constant String := Ada.Directories.Simple_Name (Ent);
         begin
            Names.Append (Name);
         end;
      end loop;
      Sort_Names.Sort (Names);
      if not Names.Is_Empty then
         First_Index := Get_Index (Names.First_Element);
         Last_Index := Get_Index (Names.Last_Element);
      else
         First_Index := Manager.Min_Index;
         Last_Index := Manager.Min_Index;
      end if;
   end Eligible_Files;

end Util.Files.Rolling;

Add Last_Path and record it when Rename is called


-----------------------------------------------------------------------
--  strings.tests -- Unit tests for Strings
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2018, 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.Tests;

package Util.Strings.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);
   procedure Test_Escape_Java (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);
   procedure Test_Starts_With (T : in out Test);
   procedure Test_Ends_With (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

end Util.Strings.Tests;

-----------------------------------------------------------------------
--  strings.tests -- Unit tests for Strings
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2018, 2020, 2021 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.Tests;

package Util.Strings.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Escape_Javascript (T : in out Test);

   procedure Test_Escape_Xml (T : in out Test);
   procedure Test_Escape_Java (T : in out Test);

   procedure Test_Unescape_Xml (T : in out Test);

   procedure Test_Capitalize (T : in out Test);

   procedure Test_To_Upper_Case (T : in out Test);

   procedure Test_To_Lower_Case (T : in out Test);
   procedure Test_To_Hex (T : in out Test);
   procedure Test_Measure_Copy (T : in out Test);
   procedure Test_Index (T : in out Test);
   procedure Test_Rindex (T : in out Test);
   procedure Test_Starts_With (T : in out Test);
   procedure Test_Ends_With (T : in out Test);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test);

   --  Test String_Ref creation
   procedure Test_String_Ref (T : in out Test);

   --  Benchmark comparison between the use of Iterate vs Query_Element.
   procedure Test_Perf_Vector (T : in out Test);

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test);

   --  Test the token iteration.
   procedure Test_Iterate_Token (T : in out Test);

   --  Test formatting strings.
   procedure Test_Format (T : in out Test);

end Util.Strings.Tests;

Add Test_Format procedure

Add Test_Format procedure


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

-----------------------------------------------------------------------
--  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 := Map_Bean_Access (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;

Fix compilation with GNAT 2020

Fix compilation with GNAT 2020