-----------------------------------------------------------------------
--  druss-tools -- Druss main tool
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;  use GNAT.Command_Line;
with Ada.Command_Line;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Util.Commands;
with Util.Http.Clients.Curl;
with Util.Log.Loggers;
with Util.Properties;
with Druss.Config;
with Druss.Commands;
procedure Druss.Tools is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   Log_Config  : Util.Properties.Manager;
   Config      : Ada.Strings.Unbounded.Unbounded_String;
   Output      : Ada.Strings.Unbounded.Unbounded_String;
   Debug       : Boolean := False;
   Verbose     : Boolean := False;
   Interactive : Boolean := False;
   First       : Natural := 0;
   All_Args    : Util.Commands.Default_Argument_List (0);
   Console     : aliased Druss.Commands.Text_Consoles.Console_Type;
   Ctx         : Druss.Commands.Context_Type;
begin
   Log_Config.Set ("log4j.rootCategory", "DEBUG,console");
   Log_Config.Set ("log4j.appender.console", "Console");
   Log_Config.Set ("log4j.appender.console.level", "ERROR");
   Log_Config.Set ("log4j.appender.console.layout", "level-message");
   Log_Config.Set ("log4j.appender.stdout", "Console");
   Log_Config.Set ("log4j.appender.stdout.level", "INFO");
   Log_Config.Set ("log4j.appender.stdout.layout", "message");
   Log_Config.Set ("log4j.logger.Util", "FATAL");
   Log_Config.Set ("log4j.logger.Bbox", "FATAL");

   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Commands.Initialize;
   Ctx.Console := Console'Unchecked_Access;
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");
   --  Parse the command line
   loop
      case Getopt ("* v d i o: c:") is
         when ASCII.NUL => exit;

         when 'c' =>
            Config := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'o' =>
            Output := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'd' =>
            Debug := True;

         when 'i' =>
            Interactive := True;

         when 'v' =>
            Verbose := True;

         when '*' =>
            exit;

         when others =>
            null;
      end case;
      First := First + 1;
   end loop;
   if Verbose or Debug then
      Log_Config.Set ("log4j.appender.console.level", "INFO");
      Log_Config.Set ("log4j.logger.Util", "WARN");
      Log_Config.Set ("log4j.logger.Bbox", "ERR");
   end if;
   if Debug then
      Log_Config.Set ("log4j.appender.console.level", "DEBUG");
   end if;
   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Config.Initialize (To_String (Config));
   Util.Http.Clients.Curl.Register;

   --  Enter in the interactive mode.
   if Interactive then
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Interactive (Ctx);
      return;
   end if;
   if First >= Ada.Command_Line.Argument_Count then
      Ada.Text_IO.Put_Line ("Missing command name to execute.");
      Druss.Commands.Driver.Usage (All_Args);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   declare
      Cmd_Name : constant String := Full_Switch;
      Args     : Util.Commands.Default_Argument_List (First + 1);
   begin
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Driver.Execute (Cmd_Name, Args, Ctx);
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Ada.Command_Line.Set_Exit_Status (2);

end Druss.Tools;

-----------------------------------------------------------------------
--  druss-tools -- Druss main tool
--  Copyright (C) 2017, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;  use GNAT.Command_Line;
with Ada.Command_Line;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Util.Commands;
with Util.Http.Clients.Curl;
with Util.Log.Loggers;
with Util.Properties;
with Druss.Config;
with Druss.Commands;
procedure Druss.Tools is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   Log_Config  : Util.Properties.Manager;
   Config      : Ada.Strings.Unbounded.Unbounded_String;
   Output      : Ada.Strings.Unbounded.Unbounded_String;
   Debug       : Boolean := False;
   Verbose     : Boolean := False;
   Interactive : Boolean := False;
   First       : Natural := 0;
   All_Args    : Util.Commands.Default_Argument_List (0);
   Console     : aliased Druss.Commands.Text_Consoles.Console_Type;
   Ctx         : Druss.Commands.Context_Type;
begin
   Log_Config.Set ("log4j.rootCategory", "DEBUG,console");
   Log_Config.Set ("log4j.appender.console", "Console");
   Log_Config.Set ("log4j.appender.console.level", "ERROR");
   Log_Config.Set ("log4j.appender.console.layout", "level-message");
   Log_Config.Set ("log4j.appender.stdout", "Console");
   Log_Config.Set ("log4j.appender.stdout.level", "INFO");
   Log_Config.Set ("log4j.appender.stdout.layout", "message");
   Log_Config.Set ("log4j.logger.Util", "FATAL");
   Log_Config.Set ("log4j.logger.Bbox", "FATAL");

   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Commands.Initialize;
   Ctx.Console := Console'Unchecked_Access;
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");
   --  Parse the command line
   loop
      case Getopt ("* v d i o: c:") is
         when ASCII.NUL => exit;

         when 'c' =>
            Config := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'o' =>
            Output := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'd' =>
            Debug := True;

         when 'i' =>
            Interactive := True;

         when 'v' =>
            Verbose := True;

         when '*' =>
            exit;

         when others =>
            null;
      end case;
      First := First + 1;
   end loop;
   if Verbose or Debug then
      Log_Config.Set ("log4j.appender.console.level", "INFO");
      Log_Config.Set ("log4j.logger.Util", "WARN");
      Log_Config.Set ("log4j.logger.Bbox", "ERR");
   end if;
   if Debug then
      Log_Config.Set ("log4j.appender.console.level", "DEBUG");
   end if;
   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Config.Initialize (To_String (Config));
   Util.Http.Clients.Curl.Register;

   --  Enter in the interactive mode.
   if Interactive then
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Interactive (Ctx);
      return;
   end if;
   if First >= Ada.Command_Line.Argument_Count then
      Ada.Text_IO.Put_Line ("Missing command name to execute.");
      Druss.Commands.Driver.Usage (All_Args, Ctx);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   declare
      Cmd_Name : constant String := Full_Switch;
      Args     : Util.Commands.Default_Argument_List (First + 1);
   begin
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Driver.Execute (Cmd_Name, Args, Ctx);
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Ada.Command_Line.Set_Exit_Status (2);

end Druss.Tools;

Update to use latest Ada Util

Update to use latest Ada Util


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

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

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

   --  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;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  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_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_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 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;

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

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

   --  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;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  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_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_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;

Declare the Get_Grants function

Declare the Get_Grants function


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

with Util.Test_Caller;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   procedure Load_Library (T : in out Test;
                           Lib : out Handle);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   procedure Load_Library (T : in out Test;
                           Lib : out Handle) is
      Lib1 : Handle;
      Lib2 : Handle;
      Lib3 : Handle;
      Lib4 : Handle;
      Lib5 : Handle;
   begin
      begin
         Lib1 := Util.Systems.DLLs.Load ("libcrypto.so");
         T.Assert (Lib1 /= Null_Handle, "Load operation returned null");
         Lib := Lib1;
      exception
         when Load_Error =>
            Lib1 := Null_Handle;
      end;

      begin
         Lib2 := Util.Systems.DLLs.Load ("libgmp.dylib");
         T.Assert (Lib2 /= Null_Handle, "Load operation returned null");
         Lib := Lib2;
      exception
         when Load_Error =>
            Lib2 := Null_Handle;
      end;

      begin
         Lib3 := Util.Systems.DLLs.Load ("zlib1.dll");
         T.Assert (Lib3 /= Null_Handle, "Load operation returned null");
         Lib := Lib3;
      exception
         when Load_Error =>
            Lib3 := Null_Handle;
      end;

      begin
         Lib4 := Util.Systems.DLLs.Load ("libz.so");
         T.Assert (Lib4 /= Null_Handle, "Load operation returned null");
         Lib := Lib4;
      exception
         when Load_Error =>
            Lib4 := Null_Handle;
      end;

      begin
         Lib5 := Util.Systems.DLLs.Load ("libgmp.so");
         T.Assert (Lib5 /= Null_Handle, "Load operation returned null");
         Lib := Lib5;
      exception
         when Load_Error =>
            Lib5 := Null_Handle;
      end;

      T.Assert (Lib1 /= Null_Handle or Lib2 /= Null_Handle or Lib3 /= Null_Handle
                or Lib4 /= Null_Handle or Lib5 /= Null_Handle,
                "At least one Load operation should have succeeded");
   end Load_Library;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Load_Library (T, Lib);
      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address := System.Null_Address;
   begin
      Load_Library (T, Lib);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "EVP_sha1");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "compress");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "__gmpf_cmp");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      --  We must have found one of the two symbols
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

-----------------------------------------------------------------------
--  util-systems-dlls-tests -- Unit tests for shared libraries
--  Copyright (C) 2013, 2017, 2019, 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 Util.Test_Caller;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   procedure Load_Library (T : in out Test;
                           Lib : out Handle);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   procedure Load_Library (T : in out Test;
                           Lib : out Handle) is
      Lib1 : Handle;
      Lib2 : Handle;
      Lib3 : Handle;
      Lib4 : Handle;
      Lib5 : Handle;
      Lib6 : Handle;
   begin
      begin
         Lib1 := Util.Systems.DLLs.Load ("libcrypto.so");
         T.Assert (Lib1 /= Null_Handle, "Load operation returned null");
         Lib := Lib1;
      exception
         when Load_Error =>
            Lib1 := Null_Handle;
      end;

      begin
         Lib2 := Util.Systems.DLLs.Load ("libgmp.dylib");
         T.Assert (Lib2 /= Null_Handle, "Load operation returned null");
         Lib := Lib2;
      exception
         when Load_Error =>
            Lib2 := Null_Handle;
      end;

      begin
         Lib3 := Util.Systems.DLLs.Load ("zlib1.dll");
         T.Assert (Lib3 /= Null_Handle, "Load operation returned null");
         Lib := Lib3;
      exception
         when Load_Error =>
            Lib3 := Null_Handle;
      end;

      begin
         Lib4 := Util.Systems.DLLs.Load ("libz.so");
         T.Assert (Lib4 /= Null_Handle, "Load operation returned null");
         Lib := Lib4;
      exception
         when Load_Error =>
            Lib4 := Null_Handle;
      end;

      begin
         Lib5 := Util.Systems.DLLs.Load ("libgmp.so");
         T.Assert (Lib5 /= Null_Handle, "Load operation returned null");
         Lib := Lib5;
      exception
         when Load_Error =>
            Lib5 := Null_Handle;
      end;

      begin
         Lib6 := Util.Systems.DLLs.Load ("libexpat-1.dll");
         T.Assert (Lib6 /= Null_Handle, "Load operation returned null");
         Lib := Lib6;
      exception
         when Load_Error =>
            Lib6 := Null_Handle;
      end;

      T.Assert (Lib1 /= Null_Handle or Lib2 /= Null_Handle or Lib3 /= Null_Handle
                or Lib4 /= Null_Handle or Lib5 /= Null_Handle or Lib6 /= Null_Handle,
                "At least one Load operation should have succeeded");
   end Load_Library;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Load_Library (T, Lib);
      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address := System.Null_Address;
   begin
      Load_Library (T, Lib);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "EVP_sha1");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "compress");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "__gmpf_cmp");
         T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      exception
         when Not_Found =>
            null;
      end;

      --  We must have found one of the two symbols
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

Update unit test for Windows

Update unit test for Windows


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

with Util.Tests;

package Security.OAuth.Servers.Tests is

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

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

   --  Test the application manager.
   procedure Test_Application_Manager (T : in out Test);

   --  Test the user registration and verification.
   procedure Test_User_Verify (T : in out Test);

   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   procedure Test_Token_Password (T : in out Test);

end Security.OAuth.Servers.Tests;

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

with Util.Tests;

package Security.OAuth.Servers.Tests is

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

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

   --  Test the application manager.
   procedure Test_Application_Manager (T : in out Test);

   --  Test the user registration and verification.
   procedure Test_User_Verify (T : in out Test);

   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   procedure Test_Token_Password (T : in out Test);

   --  Test the access token validation with invalid tokens (bad formed).
   procedure Test_Bad_Token (T : in out Test);

end Security.OAuth.Servers.Tests;

Declare Test_Bad_Token procedure

Declare Test_Bad_Token procedure


-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012, 2015, 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.Containers.Indefinite_Vectors;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;
with Ada.Text_IO;

with Gen.Model.Packages;
private with Util.Strings.Maps;

--  with Asis;
--  with Asis.Text;
--  with Asis.Elements;
--  with Asis.Exceptions;
--  with Asis.Errors;
--  with Asis.Implementation;
--  with Asis.Elements;
--  with Asis.Declarations;
--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  Tag marker (same as Java).
   TAG_CHAR     : constant Character := '@';

   --  Specific tags recognized when analyzing the documentation.
   TAG_AUTHOR   : constant String := "author";
   TAG_TITLE    : constant String := "title";
   TAG_INCLUDE  : constant String := "include";
   TAG_SEE      : constant String := "see";

   type Doc_Format is (DOC_MARKDOWN, DOC_WIKI_GOOGLE);

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Set the output document format to generate.
   procedure Set_Format (Handler : in out Artifact;
                         Format  : in Doc_Format;
                         Footer  : in Boolean);

   --  Load from the file a list of link definitions which can be injected in the generated doc.
   --  This allows to avoid polluting the Ada code with external links.
   procedure Read_Links (Handler : in out Artifact;
                         Path    : in String);

private

   type Line_Kind is (L_TEXT, L_LIST, L_LIST_ITEM, L_SEE, L_INCLUDE, L_START_CODE, L_END_CODE,
                      L_HEADER_1, L_HEADER_2, L_HEADER_3, L_HEADER_4);

   type Line_Type (Len : Natural) is record
      Kind    : Line_Kind := L_TEXT;
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type Document_Formatter is abstract tagged record
      Links : Util.Strings.Maps.Map;
   end record;
   type Document_Formatter_Access is access all Document_Formatter'Class;

   type File_Document is record
      Name         : Ada.Strings.Unbounded.Unbounded_String;
      Title        : Ada.Strings.Unbounded.Unbounded_String;
      State        : Doc_State := IN_PARA;
      Line_Number  : Natural := 0;
      Lines        : Line_Vectors.Vector;
      Was_Included : Boolean := False;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is abstract;

   --  Start a new document.
   procedure Start_Document (Formatter : in out Document_Formatter;
                             Document  : in File_Document;
                             File      : in Ada.Text_IO.File_Type) is abstract;

   --  Write a line in the target document formatting the line if necessary.
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is abstract;

   --  Finish the document.
   procedure Finish_Document (Formatter : in out Document_Formatter;
                              Document  : in File_Document;
                              File      : in Ada.Text_IO.File_Type;
                              Source    : in String) is abstract;

   package Doc_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Document,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Include the document extract represented by Name into the document Into.
   --  The included document is marked so that it will not be generated.
   procedure Include (Docs     : in out Doc_Maps.Map;
                      Into     : in out File_Document;
                      Name     : in String;
                      Position : in Natural);

   --  Generate the project documentation that was collected in Docs.
   --  The documentation is merged so that the @include tags are replaced by the matching
   --  document extracts.
   procedure Generate (Docs : in out Doc_Maps.Map;
                       Dir  : in String);

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Look and analyze the tag defined on the line.
   procedure Append_Tag (Doc : in out File_Document;
                         Tag : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Set the title associated with the document extract.
   procedure Set_Title (Doc   : in out File_Document;
                        Title : in String);

   --  Scan the files in the directory refered to by Path and collect the documentation
   --  in the Docs hashed map.
   procedure Scan_Files (Handler : in out Artifact;
                         Path    : in String;
                         Docs    : in out Doc_Maps.Map);

   --  Read the Ada specification file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   procedure Read_Xml_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      Xslt_Command : Ada.Strings.Unbounded.Unbounded_String;
      Format       : Doc_Format := DOC_WIKI_GOOGLE;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

end Gen.Artifacts.Docs;

-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012, 2015, 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.Containers.Indefinite_Vectors;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;
with Ada.Text_IO;

with Gen.Model.Packages;
private with Util.Strings.Maps;

--  with Asis;
--  with Asis.Text;
--  with Asis.Elements;
--  with Asis.Exceptions;
--  with Asis.Errors;
--  with Asis.Implementation;
--  with Asis.Elements;
--  with Asis.Declarations;
--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  Tag marker (same as Java).
   TAG_CHAR     : constant Character := '@';

   --  Specific tags recognized when analyzing the documentation.
   TAG_AUTHOR         : constant String := "author";
   TAG_TITLE          : constant String := "title";
   TAG_INCLUDE        : constant String := "include";
   TAG_INCLUDE_CONFIG : constant String := "include-config";
   TAG_INCLUDE_BEAN   : constant String := "include-bean";
   TAG_INCLUDE_QUERY  : constant String := "include-query";
   TAG_INCLUDE_PERM   : constant String := "include-permission";
   TAG_SEE            : constant String := "see";

   type Doc_Format is (DOC_MARKDOWN, DOC_WIKI_GOOGLE);

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Set the output document format to generate.
   procedure Set_Format (Handler : in out Artifact;
                         Format  : in Doc_Format;
                         Footer  : in Boolean);

   --  Load from the file a list of link definitions which can be injected in the generated doc.
   --  This allows to avoid polluting the Ada code with external links.
   procedure Read_Links (Handler : in out Artifact;
                         Path    : in String);

private

   type Line_Kind is (L_TEXT, L_LIST, L_LIST_ITEM, L_SEE, L_INCLUDE, L_INCLUDE_CONFIG,
                      L_INCLUDE_BEAN, L_INCLUDE_PERMISSION, L_INCLUDE_QUERY,
                      L_START_CODE, L_END_CODE,
                      L_HEADER_1, L_HEADER_2, L_HEADER_3, L_HEADER_4);

   subtype Line_Include_Kind is Line_Kind range L_INCLUDE .. L_INCLUDE_QUERY;

   type Line_Type (Len : Natural) is record
      Kind    : Line_Kind := L_TEXT;
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Line_Group_Vector is array (Line_Include_Kind) of Line_Vectors.Vector;

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type Document_Formatter is abstract tagged record
      Links : Util.Strings.Maps.Map;
   end record;
   type Document_Formatter_Access is access all Document_Formatter'Class;

   type File_Document is record
      Name         : Ada.Strings.Unbounded.Unbounded_String;
      Title        : Ada.Strings.Unbounded.Unbounded_String;
      State        : Doc_State := IN_PARA;
      Line_Number  : Natural := 0;
      Lines        : Line_Group_Vector;
      Was_Included : Boolean := False;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is abstract;

   --  Start a new document.
   procedure Start_Document (Formatter : in out Document_Formatter;
                             Document  : in File_Document;
                             File      : in Ada.Text_IO.File_Type) is abstract;

   --  Write a line in the target document formatting the line if necessary.
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is abstract;

   --  Finish the document.
   procedure Finish_Document (Formatter : in out Document_Formatter;
                              Document  : in File_Document;
                              File      : in Ada.Text_IO.File_Type;
                              Source    : in String) is abstract;

   package Doc_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Document,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Include the document extract represented by Name into the document Into.
   --  The included document is marked so that it will not be generated.
   procedure Include (Docs     : in out Doc_Maps.Map;
                      Into     : in out File_Document;
                      Name     : in String;
                      Mode     : in Line_Include_Kind;
                      Position : in Natural);

   --  Generate the project documentation that was collected in Docs.
   --  The documentation is merged so that the @include tags are replaced by the matching
   --  document extracts.
   procedure Generate (Docs : in out Doc_Maps.Map;
                       Dir  : in String);

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Look and analyze the tag defined on the line.
   procedure Append_Tag (Doc : in out File_Document;
                         Tag : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Set the title associated with the document extract.
   procedure Set_Title (Doc   : in out File_Document;
                        Title : in String);

   --  Scan the files in the directory refered to by Path and collect the documentation
   --  in the Docs hashed map.
   procedure Scan_Files (Handler : in out Artifact;
                         Path    : in String;
                         Docs    : in out Doc_Maps.Map);

   --  Read the Ada specification file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   procedure Read_Xml_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      Xslt_Command : Ada.Strings.Unbounded.Unbounded_String;
      Format       : Doc_Format := DOC_WIKI_GOOGLE;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

end Gen.Artifacts.Docs;

Add TAG_INCLUDE_CONFIG...TAG_INCLUDE_PERM for new tags keywords Declare Line_Group_Vector array of lines Use Line_Group_Vector for the document representation


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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
   end record;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name : in Ada.Strings.Unbounded.Unbounded_String)
                       return Mapping_Definition_Access;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

end Gen.Model.Mappings;

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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
   end record;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name : in Ada.Strings.Unbounded.Unbounded_String)
                       return Mapping_Definition_Access;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

   subtype Map is Mapping_Maps.Map;

   subtype Cursor is Mapping_Maps.Cursor;

end Gen.Model.Mappings;

Define the Map and Cursor subtypes

Define the Map and Cursor subtypes


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

with Ada.Strings.Unbounded;
with Util.Properties;

--  == Localized date formatting ==
--  The `Util.Dates.Formats` provides a date formatting operation similar to the
--  Unix `strftime` or the `GNAT.Calendar.Time_IO`.  The localization of month
--  and day labels is however handled through `Util.Properties.Bundle` (similar to
--  the Java world).  Unlike `strftime`, this allows to have a multi-threaded application
--  that reports dates in several languages.  The `GNAT.Calendar.Time_IO` only supports
--  English and this is the reason why it is not used here.
--
--  The date pattern recognizes the following formats:
--
--  | Format | Description |
--  | --- | ---------- |
--  | %a  | The abbreviated weekday name according to the current locale.
--  | %A  | The full weekday name according to the current locale.
--  | %b  | The abbreviated month name according to the current locale.
--  | %h  | Equivalent to %b. (SU)
--  | %B  | The full month name according to the current locale.
--  | %c  | The preferred date and time representation for the current locale.
--  | %C  | The century number (year/100) as a 2-digit integer. (SU)
--  | %d  | The day of the month as a decimal number (range 01 to 31).
--  | %D  | Equivalent to %m/%d/%y
--  | %e  | Like %d, the day of the month as a decimal number,
--  |     | but a leading zero is replaced by a space. (SU)
--  | %F  | Equivalent to %Y\-%m\-%d (the ISO 8601 date format). (C99)
--  | %G  | The ISO 8601 week-based year
--  | %H  | The hour as a decimal number using a 24-hour clock (range 00 to 23).
--  | %I  | The hour as a decimal number using a 12-hour clock (range 01 to 12).
--  | %j  | The day of the year as a decimal number (range 001 to 366).
--  | %k  | The hour (24 hour clock) as a decimal number (range 0 to 23);
--  | %l  | The hour (12 hour clock) as a decimal number (range 1 to 12);
--  | %m  | The month as a decimal number (range 01 to 12).
--  | %M  | The minute as a decimal number (range 00 to 59).
--  | %n  | A newline character. (SU)
--  | %p  | Either "AM" or "PM"
--  | %P  | Like %p but in lowercase: "am" or "pm"
--  | %r  | The time in a.m. or p.m. notation.
--  |     | In the POSIX locale this is equivalent to %I:%M:%S %p. (SU)
--  | %R  | The time in 24 hour notation (%H:%M).
--  | %s  | The number of seconds since the Epoch, that is,
--  |     | since 1970\-01\-01 00:00:00 UTC. (TZ)
--  | %S  | The second as a decimal number (range 00 to 60).
--  | %t  | A tab character. (SU)
--  | %T  | The time in 24 hour notation (%H:%M:%S). (SU)
--  | %u  | The day of the week as a decimal, range 1 to 7,
--  |     | Monday being 1. See also %w. (SU)
--  | %U  | The week number of the current year as a decimal
--  |     | number, range 00 to 53
--  | %V  | The ISO 8601 week number
--  | %w  | The day of the week as a decimal, range 0 to 6,
--  |     | Sunday being 0. See also %u.
--  | %W  | The week number of the current year as a decimal number,
--  |     | range 00 to 53
--  | %x  | The preferred date representation for the current locale
--  |     | without the time.
--  | %X  | The preferred time representation for the current locale
--  |     | without the date.
--  | %y  | The year as a decimal number without a century (range 00 to 99).
--  | %Y  | The year as a decimal number including the century.
--  | %z  | The timezone as hour offset from GMT.
--  | %Z  | The timezone or name or abbreviation.
--
--  The following strftime flags are ignored:
--
--  %E     Modifier: use alternative format, see below. (SU)
--  %O     Modifier: use alternative format, see below. (SU)
--
--  SU:  Single Unix Specification
--  C99: C99 standard, POSIX.1-2001
--
--  See strftime (3) manual page
package Util.Dates.Formats is

   --  Month labels.
   MONTH_NAME_PREFIX         : constant String := "util.month";

   --  Day labels.
   DAY_NAME_PREFIX           : constant String := "util.day";

   --  Short month/day suffix.
   SHORT_SUFFIX              : constant String := ".short";

   --  Long month/day suffix.
   LONG_SUFFIX               : constant String := ".long";

   --  The date time pattern name to be used for the %x representation.
   --  This property name is searched in the bundle to find the localized date time pattern.
   DATE_TIME_LOCALE_NAME     : constant String := "util.datetime.pattern";

   --  The default date pattern for %c (English).
   DATE_TIME_DEFAULT_PATTERN : constant String := "%a %b %_d %T %Y";

   --  The date pattern to be used for the %x representation.
   --  This property name is searched in the bundle to find the localized date pattern.
   DATE_LOCALE_NAME          : constant String := "util.date.pattern";

   --  The default date pattern for %x (English).
   DATE_DEFAULT_PATTERN      : constant String := "%m/%d/%y";

   --  The time pattern to be used for the %X representation.
   --  This property name is searched in the bundle to find the localized time pattern.
   TIME_LOCALE_NAME          : constant String := "util.time.pattern";

   --  The default time pattern for %X (English).
   TIME_DEFAULT_PATTERN      : constant String := "%T %Y";

   AM_NAME                   : constant String := "util.date.am";
   PM_NAME                   : constant String := "util.date.pm";

   AM_DEFAULT                : constant String := "AM";
   PM_DEFAULT                : constant String := "PM";

   --  Format the date passed in Date using the date pattern specified in Pattern.
   --  The date pattern is similar to the Unix strftime operation.
   --
   --  For month and day of week strings, use the resource bundle passed in Bundle.
   --  Append the formatted date in the Into string.
   procedure Format (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                     Pattern   : in String;
                     Date      : in Date_Record;
                     Bundle    : in Util.Properties.Manager'Class);

   --  Format the date passed in Date using the date pattern specified in Pattern.
   --  For month and day of week strings, use the resource bundle passed in Bundle.
   --  Append the formatted date in the Into string.
   procedure Format (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                     Pattern   : in String;
                     Date      : in Ada.Calendar.Time;
                     Bundle    : in Util.Properties.Manager'Class);

   function Format (Pattern   : in String;
                    Date      : in Ada.Calendar.Time;
                    Bundle    : in Util.Properties.Manager'Class) return String;

   --  Append the localized month string in the Into string.
   --  The month string is found in the resource bundle under the name:
   --    util.month<month number>.short
   --    util.month<month number>.long
   --  If the month string is not found, the month is displayed as a number.
   procedure Append_Month (Into   : in out Ada.Strings.Unbounded.Unbounded_String;
                           Month  : in Ada.Calendar.Month_Number;
                           Bundle : in Util.Properties.Manager'Class;
                           Short  : in Boolean := True);

   --  Append the localized month string in the Into string.
   --  The month string is found in the resource bundle under the name:
   --    util.month<month number>.short
   --    util.month<month number>.long
   --  If the month string is not found, the month is displayed as a number.
   procedure Append_Day (Into   : in out Ada.Strings.Unbounded.Unbounded_String;
                         Day    : in Ada.Calendar.Formatting.Day_Name;
                         Bundle : in Util.Properties.Manager'Class;
                         Short  : in Boolean := True);

   --  Append a number with padding if necessary
   procedure Append_Number (Into    : in out Ada.Strings.Unbounded.Unbounded_String;
                            Value   : in Natural;
                            Padding : in Character;
                            Length  : in Natural := 2);

   --  Append the timezone offset
   procedure Append_Time_Offset (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                                 Offset    : in Ada.Calendar.Time_Zones.Time_Offset);

end Util.Dates.Formats;

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

with Ada.Strings.Unbounded;
with Util.Properties;

--  == Localized date formatting ==
--  The `Util.Dates.Formats` provides a date formatting operation similar to the
--  Unix `strftime` or the `GNAT.Calendar.Time_IO`.  The localization of month
--  and day labels is however handled through `Util.Properties.Bundle` (similar to
--  the Java world).  Unlike `strftime`, this allows to have a multi-threaded application
--  that reports dates in several languages.  The `GNAT.Calendar.Time_IO` only supports
--  English and this is the reason why it is not used here.
--
--  The date pattern recognizes the following formats:
--
--  | Format | Description |
--  | --- | ---------- |
--  | %a  | The abbreviated weekday name according to the current locale.
--  | %A  | The full weekday name according to the current locale.
--  | %b  | The abbreviated month name according to the current locale.
--  | %h  | Equivalent to %b. (SU)
--  | %B  | The full month name according to the current locale.
--  | %c  | The preferred date and time representation for the current locale.
--  | %C  | The century number (year/100) as a 2-digit integer. (SU)
--  | %d  | The day of the month as a decimal number (range 01 to 31).
--  | %D  | Equivalent to %m/%d/%y
--  | %e  | Like %d, the day of the month as a decimal number,
--  |     | but a leading zero is replaced by a space. (SU)
--  | %F  | Equivalent to %Y\-%m\-%d (the ISO 8601 date format). (C99)
--  | %G  | The ISO 8601 week-based year
--  | %H  | The hour as a decimal number using a 24-hour clock (range 00 to 23).
--  | %I  | The hour as a decimal number using a 12-hour clock (range 01 to 12).
--  | %j  | The day of the year as a decimal number (range 001 to 366).
--  | %k  | The hour (24 hour clock) as a decimal number (range 0 to 23);
--  | %l  | The hour (12 hour clock) as a decimal number (range 1 to 12);
--  | %m  | The month as a decimal number (range 01 to 12).
--  | %M  | The minute as a decimal number (range 00 to 59).
--  | %n  | A newline character. (SU)
--  | %p  | Either "AM" or "PM"
--  | %P  | Like %p but in lowercase: "am" or "pm"
--  | %r  | The time in a.m. or p.m. notation.
--  |     | In the POSIX locale this is equivalent to %I:%M:%S %p. (SU)
--  | %R  | The time in 24 hour notation (%H:%M).
--  | %s  | The number of seconds since the Epoch, that is,
--  |     | since 1970\-01\-01 00:00:00 UTC. (TZ)
--  | %S  | The second as a decimal number (range 00 to 60).
--  | %t  | A tab character. (SU)
--  | %T  | The time in 24 hour notation (%H:%M:%S). (SU)
--  | %u  | The day of the week as a decimal, range 1 to 7,
--  |     | Monday being 1. See also %w. (SU)
--  | %U  | The week number of the current year as a decimal
--  |     | number, range 00 to 53
--  | %V  | The ISO 8601 week number
--  | %w  | The day of the week as a decimal, range 0 to 6,
--  |     | Sunday being 0. See also %u.
--  | %W  | The week number of the current year as a decimal number,
--  |     | range 00 to 53
--  | %x  | The preferred date representation for the current locale
--  |     | without the time.
--  | %X  | The preferred time representation for the current locale
--  |     | without the date.
--  | %y  | The year as a decimal number without a century (range 00 to 99).
--  | %Y  | The year as a decimal number including the century.
--  | %z  | The timezone as hour offset from GMT.
--  | %Z  | The timezone or name or abbreviation.
--
--  The following strftime flags are ignored:
--
--  | Format | Description |
--  | --- | ---------- |
--  | %E  |  Modifier: use alternative format, see below. (SU)
--  | %O  |  Modifier: use alternative format, see below. (SU)
--
--  SU:  Single Unix Specification
--  C99: C99 standard, POSIX.1-2001
--
--  See strftime (3) manual page
--
--  To format and use the localize date, it is first necessary to get a bundle
--  for the `dates` so that date elements are translated into the given locale.
--
--     Factory     : Util.Properties.Bundles.Loader;
--     Bundle      : Util.Properties.Bundles.Manager;
--     ...
--        Load_Bundle (Factory, "dates", "fr", Bundle);
--
--  The date is formatted according to the pattern string described above.
--  The bundle is used by the formatter to use the day and month names in the
--  expected locale.
--
--     Date : String := Util.Dates.Formats.Format (Pattern => Pattern,
--                                                 Date    => Ada.Calendar.Clock,
--                                                 Bundle  => Bundle);
package Util.Dates.Formats is

   --  Month labels.
   MONTH_NAME_PREFIX         : constant String := "util.month";

   --  Day labels.
   DAY_NAME_PREFIX           : constant String := "util.day";

   --  Short month/day suffix.
   SHORT_SUFFIX              : constant String := ".short";

   --  Long month/day suffix.
   LONG_SUFFIX               : constant String := ".long";

   --  The date time pattern name to be used for the %x representation.
   --  This property name is searched in the bundle to find the localized date time pattern.
   DATE_TIME_LOCALE_NAME     : constant String := "util.datetime.pattern";

   --  The default date pattern for %c (English).
   DATE_TIME_DEFAULT_PATTERN : constant String := "%a %b %_d %T %Y";

   --  The date pattern to be used for the %x representation.
   --  This property name is searched in the bundle to find the localized date pattern.
   DATE_LOCALE_NAME          : constant String := "util.date.pattern";

   --  The default date pattern for %x (English).
   DATE_DEFAULT_PATTERN      : constant String := "%m/%d/%y";

   --  The time pattern to be used for the %X representation.
   --  This property name is searched in the bundle to find the localized time pattern.
   TIME_LOCALE_NAME          : constant String := "util.time.pattern";

   --  The default time pattern for %X (English).
   TIME_DEFAULT_PATTERN      : constant String := "%T %Y";

   AM_NAME                   : constant String := "util.date.am";
   PM_NAME                   : constant String := "util.date.pm";

   AM_DEFAULT                : constant String := "AM";
   PM_DEFAULT                : constant String := "PM";

   --  Format the date passed in Date using the date pattern specified in Pattern.
   --  The date pattern is similar to the Unix strftime operation.
   --
   --  For month and day of week strings, use the resource bundle passed in Bundle.
   --  Append the formatted date in the Into string.
   procedure Format (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                     Pattern   : in String;
                     Date      : in Date_Record;
                     Bundle    : in Util.Properties.Manager'Class);

   --  Format the date passed in Date using the date pattern specified in Pattern.
   --  For month and day of week strings, use the resource bundle passed in Bundle.
   --  Append the formatted date in the Into string.
   procedure Format (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                     Pattern   : in String;
                     Date      : in Ada.Calendar.Time;
                     Bundle    : in Util.Properties.Manager'Class);

   function Format (Pattern   : in String;
                    Date      : in Ada.Calendar.Time;
                    Bundle    : in Util.Properties.Manager'Class) return String;

   --  Append the localized month string in the Into string.
   --  The month string is found in the resource bundle under the name:
   --    util.month<month number>.short
   --    util.month<month number>.long
   --  If the month string is not found, the month is displayed as a number.
   procedure Append_Month (Into   : in out Ada.Strings.Unbounded.Unbounded_String;
                           Month  : in Ada.Calendar.Month_Number;
                           Bundle : in Util.Properties.Manager'Class;
                           Short  : in Boolean := True);

   --  Append the localized month string in the Into string.
   --  The month string is found in the resource bundle under the name:
   --    util.month<month number>.short
   --    util.month<month number>.long
   --  If the month string is not found, the month is displayed as a number.
   procedure Append_Day (Into   : in out Ada.Strings.Unbounded.Unbounded_String;
                         Day    : in Ada.Calendar.Formatting.Day_Name;
                         Bundle : in Util.Properties.Manager'Class;
                         Short  : in Boolean := True);

   --  Append a number with padding if necessary
   procedure Append_Number (Into    : in out Ada.Strings.Unbounded.Unbounded_String;
                            Value   : in Natural;
                            Padding : in Character;
                            Length  : in Natural := 2);

   --  Append the timezone offset
   procedure Append_Time_Offset (Into      : in out Ada.Strings.Unbounded.Unbounded_String;
                                 Offset    : in Ada.Calendar.Time_Zones.Time_Offset);

end Util.Dates.Formats;

Add some documentation

Add some documentation


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

--  == Timer Management ==
--  The <tt>Util.Events.Timers</tt> package provides a timer list that allows to have
--  operations called on regular basis when a deadline has expired.  It is very close to
--  the <tt>Ada.Real_Time.Timing_Events</tt> package but it provides more flexibility
--  by allowing to have several timer lists that run independently.  Unlike the GNAT
--  implementation, this timer list management does not use tasks at all.  The timer list
--  can therefore be used in a mono-task environment by the main process task.  Furthermore
--  you can control your own task priority by having your own task that uses the timer list.
--
--  The timer list is created by an instance of <tt>Timer_List</tt>:
--
--    Manager : Util.Events.Timers.Timer_List;
--
--  The timer list is protected against concurrent accesses so that timing events can be
--  setup by a task but the timer handler is executed by another task.
--
--  === Timer Creation ===
--  A timer handler is defined by implementing the <tt>Timer</tt> interface with the
--  <tt>Time_Handler</tt> procedure.  A typical timer handler could be declared as follows:
--
--    type Timeout is new Timer with null record;
--    overriding procedure Time_Handler (T : in out Timeout);
--
--    My_Timeout : aliased Timeout;
--
--  The timer instance is represented by the <tt>Timer_Ref</tt> type that describes the handler
--  to be called as well as the deadline time.  The timer instance is initialized as follows:
--
--    T : Util.Events.Timers.Timer_Ref;
--    Manager.Set_Timer (T, My_Timeout'Access, Ada.Real_Time.Seconds (1));
--
--  === Timer Main Loop ===
--  Because the implementation does not impose any execution model, the timer management must
--  be called regularly by some application's main loop.  The <tt>Process</tt> procedure
--  executes the timer handler that have ellapsed and it returns the deadline to wait for the
--  next timer to execute.
--
--    Deadline : Ada.Real_Time.Time;
--    loop
--       ...
--       Manager.Process (Deadline);
--       delay until Deadline;
--    end loop;
--
package Util.Events.Timers is

   type Timer_Ref is tagged private;

   --  The timer interface that must be implemented by applications.
   type Timer is limited interface;
   type Timer_Access is access all Timer'Class;

   --  The timer handler executed when the timer deadline has passed.
   procedure Time_Handler (T     : in out Timer;
                           Event : in out Timer_Ref'Class) is abstract;

   --  Repeat the timer.
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span);

   --  Cancel the timer.
   procedure Cancel (Event : in out Timer_Ref);

   --  Check if the timer is ready to be executed.
   function Is_Scheduled (Event : in Timer_Ref) return Boolean;

   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time;

   type Timer_List is tagged limited private;

   --  Set a timer to be called at the given time.
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time);

   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last);

private

   type Timer_Manager;
   type Timer_Manager_Access is access all Timer_Manager;

   type Timer_Node;
   type Timer_Node_Access is access all Timer_Node;

   type Timer_Ref is new Ada.Finalization.Controlled with record
      Value : Timer_Node_Access;
   end record;

   overriding
   procedure Adjust (Object : in out Timer_Ref);

   overriding
   procedure Finalize (Object : in out Timer_Ref);

   type Timer_Node is limited record
      Next     : Timer_Node_Access;
      Prev     : Timer_Node_Access;
      List     : Timer_Manager_Access;
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Handler  : Timer_Access;
      Deadline : Ada.Real_Time.Time;
   end record;

   protected type Timer_Manager is

      --  Add a timer.
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time);

      --  Cancel a timer.
      procedure Cancel (Timer : in out Timer_Node_Access);

      --  Find the next timer to be executed or return the next deadline.
      procedure Find_Next (Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref);

   private
      List : Timer_Node_Access;
   end Timer_Manager;

   type Timer_List is new Ada.Finalization.Limited_Controlled with record
      Manager : aliased Timer_Manager;
   end record;

   overriding
   procedure Finalize (Object : in out Timer_List);

end Util.Events.Timers;

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

--  == Timer Management ==
--  The <tt>Util.Events.Timers</tt> package provides a timer list that allows to have
--  operations called on regular basis when a deadline has expired.  It is very close to
--  the <tt>Ada.Real_Time.Timing_Events</tt> package but it provides more flexibility
--  by allowing to have several timer lists that run independently.  Unlike the GNAT
--  implementation, this timer list management does not use tasks at all.  The timer list
--  can therefore be used in a mono-task environment by the main process task.  Furthermore
--  you can control your own task priority by having your own task that uses the timer list.
--
--  The timer list is created by an instance of <tt>Timer_List</tt>:
--
--    Manager : Util.Events.Timers.Timer_List;
--
--  The timer list is protected against concurrent accesses so that timing events can be
--  setup by a task but the timer handler is executed by another task.
--
--  === Timer Creation ===
--  A timer handler is defined by implementing the <tt>Timer</tt> interface with the
--  <tt>Time_Handler</tt> procedure.  A typical timer handler could be declared as follows:
--
--    type Timeout is new Timer with null record;
--    overriding procedure Time_Handler (T : in out Timeout);
--
--    My_Timeout : aliased Timeout;
--
--  The timer instance is represented by the <tt>Timer_Ref</tt> type that describes the handler
--  to be called as well as the deadline time.  The timer instance is initialized as follows:
--
--    T : Util.Events.Timers.Timer_Ref;
--    Manager.Set_Timer (T, My_Timeout'Access, Ada.Real_Time.Seconds (1));
--
--  === Timer Main Loop ===
--  Because the implementation does not impose any execution model, the timer management must
--  be called regularly by some application's main loop.  The <tt>Process</tt> procedure
--  executes the timer handler that have ellapsed and it returns the deadline to wait for the
--  next timer to execute.
--
--    Deadline : Ada.Real_Time.Time;
--    loop
--       ...
--       Manager.Process (Deadline);
--       delay until Deadline;
--    end loop;
--
package Util.Events.Timers is

   type Timer_Ref is tagged private;

   --  The timer interface that must be implemented by applications.
   type Timer is limited interface;
   type Timer_Access is access all Timer'Class;

   --  The timer handler executed when the timer deadline has passed.
   procedure Time_Handler (T     : in out Timer;
                           Event : in out Timer_Ref'Class) is abstract;

   --  Repeat the timer.
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span);

   --  Cancel the timer.
   procedure Cancel (Event : in out Timer_Ref);

   --  Check if the timer is ready to be executed.
   function Is_Scheduled (Event : in Timer_Ref) return Boolean;

   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time;

   type Timer_List is tagged limited private;

   --  Set a timer to be called at the given time.
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time);

   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last);

private

   type Timer_Manager;
   type Timer_Manager_Access is access all Timer_Manager;

   type Timer_Node;
   type Timer_Node_Access is access all Timer_Node;

   type Timer_Ref is new Ada.Finalization.Controlled with record
      Value : Timer_Node_Access;
   end record;

   overriding
   procedure Adjust (Object : in out Timer_Ref);

   overriding
   procedure Finalize (Object : in out Timer_Ref);

   type Timer_Node is limited record
      Next     : Timer_Node_Access;
      Prev     : Timer_Node_Access;
      List     : Timer_Manager_Access;
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Handler  : Timer_Access;
      Deadline : Ada.Real_Time.Time;
   end record;

   protected type Timer_Manager is

      --  Add a timer.
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time);

      --  Cancel a timer.
      procedure Cancel (Timer : in out Timer_Node_Access);

      --  Find the next timer to be executed before the given time or return the next deadline.
      procedure Find_Next (Before   : in Ada.Real_Time.Time;
                           Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref);

   private
      List : Timer_Node_Access;
   end Timer_Manager;

   type Timer_List is new Ada.Finalization.Limited_Controlled with record
      Manager : aliased Timer_Manager;
   end record;

   overriding
   procedure Finalize (Object : in out Timer_List);

end Util.Events.Timers;

Update Find_Next to define the deadline to check as parameter