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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  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 is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  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 is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Rename Set_Reader_Config into Prepare_Config


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

with Ada.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:
--
--    <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>
--
--  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

   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;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

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

with Ada.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

   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;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Fix the XML documentation

Fix the XML documentation


-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 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 Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;

with ASF.Applications;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  Modules define the events that they can generate by instantiating the Definition
--  package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  The module can post an event to inform other modules or the system that a particular
--  action occurred.  The module creates the event instance of type Module_Event and
--  populates that event with useful properties for event receivers.
--
--      Event : AWA.Events.Module_Event;
--
--      Event.Set_Event_Kind (Event_New_User.Kind);
--      Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  Modules or applications interested by a particular event will configure the event manager
--  to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--  implement a procedure that matches the prototype:
--
--        type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--        procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--  The Ada bean method and object are registered as other Ada beans.
--
--  The configuration file indicates how to bind the Ada bean action and the event together.
--  The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--       <on-event name="new_user">
--           <action>#{ada_bean.action}</action>
--       </on-event>
--
--  == Data Model ==
--  @include Queues.hbm.xml
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind  : Event_Index := Invalid_Event;
      Props : ASF.Applications.Config;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 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 Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;

with ASF.Applications;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  === Declaration ===
--  Modules define the events that they can generate by instantiating the Definition
--  package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  === Posting an event ===
--  The module can post an event to inform other modules or the system that a particular
--  action occurred.  The module creates the event instance of type Module_Event and
--  populates that event with useful properties for event receivers.
--
--    Event : AWA.Events.Module_Event;
--
--    Event.Set_Event_Kind (Event_New_User.Kind);
--    Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  === Receiving an event ===
--  Modules or applications interested by a particular event will configure the event manager
--  to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--  implement a procedure that matches the prototype:
--
--    type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--    procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--  The Ada bean method and object are registered as other Ada beans.
--
--  The configuration file indicates how to bind the Ada bean action and the event together.
--  The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--    <on-event name="new_user">
--        <action>#{ada_bean.action}</action>
--    </on-event>
--
--  === Event queues and dispatchers ===
--  The *AWA.Events* framework posts events on queues and it uses a dispatcher to process them.
--  There are two kinds of dispatchers:
--
--    * Synchronous dispatcher process the event when it is posted.  The task which posts
--      the event invokes the Ada bean action.  In this dispatching mode, there is no event queue.
--      If the action method raises an exception, it will however be blocked.
--
--    * Asynchronous dispatcher are executed by dedicated tasks.  The event is put in an event
--      queue.  A dispatcher task processes the event and invokes the action method at a later
--      time.
--
--  When the event is queued, there are two types of event queues:
--
--    * A Fifo memory queue manages the event and dispatches them in FIFO order.
--      If the application is stopped, the events present in the Fifo queue are lost.
--
--    * A persistent event queue manages the event in a similar way as the FIFO queue but
--      saves them in the database.  If the application is stopped, events that have not yet
--      been processed will be dispatched when the application is started again.
--
--  == Data Model ==
--  @include Queues.hbm.xml
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind  : Event_Index := Invalid_Event;
      Props : ASF.Applications.Config;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

Document the event queues and dispatchers


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

with Util.Tests;

package Util.Texts.Builders_Tests is

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

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

   --  Test the length operation.
   procedure Test_Length (T : in out Test);

   --  Test the append operation.
   procedure Test_Append (T : in out Test);

   --  Test the iterate operation.
   procedure Test_Iterate (T : in out Test);

   --  Test the clear operation.
   procedure Test_Clear (T : in out Test);

   --  Test the tail operation.
   procedure Test_Tail (T : in out Test);

   --  Test the append and iterate performance.
   procedure Test_Perf (T : in out Test);

end Util.Texts.Builders_Tests;

-----------------------------------------------------------------------
--  util-texts-builders_tests -- Unit tests for text builders
--  Copyright (C) 2013, 2016, 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.Tests;

package Util.Texts.Builders_Tests is

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

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

   --  Test the length operation.
   procedure Test_Length (T : in out Test);

   --  Test the append operation.
   procedure Test_Append (T : in out Test);

   --  Test the iterate operation.
   procedure Test_Iterate (T : in out Test);

   --  Test the iterate operation.
   procedure Test_Inline_Iterate (T : in out Test);

   --  Test the clear operation.
   procedure Test_Clear (T : in out Test);

   --  Test the tail operation.
   procedure Test_Tail (T : in out Test);

   --  Test the append and iterate performance.
   procedure Test_Perf (T : in out Test);

end Util.Texts.Builders_Tests;

Declare Test_Inline_Iterate procedure

Declare Test_Inline_Iterate procedure


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

package MAT.Memory.Tools is

   type Size_Info_Type is record
      Count : Natural;
   end record;

   use type MAT.Types.Target_Size;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

   --  Collect the information about memory slot sizes for the memory slots in the map.
   procedure Size_Information (Memory : in MAT.Memory.Allocation_Map;
                               Sizes  : in out Size_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
   --  it does not already contains the memory slot.
   procedure Find (Memory : in MAT.Memory.Allocation_Map;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Allocation_Map);

end MAT.Memory.Tools;

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

package MAT.Memory.Tools is

   type Size_Info_Type is record
      Count : Natural;
   end record;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

   --  Collect the information about memory slot sizes for the memory slots in the map.
   procedure Size_Information (Memory : in MAT.Memory.Allocation_Map;
                               Sizes  : in out Size_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
   --  it does not already contains the memory slot.
   procedure Find (Memory : in MAT.Memory.Allocation_Map;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Allocation_Map);

end MAT.Memory.Tools;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  mat-readers-tests -- Unit tests for MAT readers
--  Copyright (C) 2014, 2015, 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;

with MAT.Readers.Streams.Files;
package body MAT.Targets.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Targets.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test MAT.Types.Tick_Value",
                       Test_Conversions'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      pragma Unreferenced (T);

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/files/file-v1.dat");
      Target : MAT.Targets.Target_Type;
      Reader : MAT.Readers.Streams.Files.File_Reader_Type;
   begin
      Target.Initialize (Reader);
      Reader.Open (Path);
      Reader.Read_All;
   end Test_Read_File;

   --  ------------------------------
   --  Test various type conversions.
   --  ------------------------------
   procedure Test_Conversions (T : in out Test) is
      use MAT.Types;
      Time : MAT.Types.Target_Tick_Ref;
   begin
      Time := MAT.Types.Tick_Value ("1.1");
      Util.Tests.Assert_Equals (T, 1, Natural (Time / 1_000000), "Invalid Tick_Value conversion");
      Util.Tests.Assert_Equals (T, 100_000, Natural (Time mod 1_000000),
                                "Invalid Tick_Value conversion");

      Time := MAT.Types.Tick_Value ("12.001234");
      Util.Tests.Assert_Equals (T, 12, Natural (Time / 1_000000), "Invalid Tick_Value conversion");
      Util.Tests.Assert_Equals (T, 1_234, Natural (Time mod 1_000000),
                                "Invalid Tick_Value conversion");
   end Test_Conversions;

end MAT.Targets.Tests;

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

with Util.Test_Caller;

with MAT.Readers.Streams.Files;
package body MAT.Targets.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Targets.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test MAT.Types.Tick_Value",
                       Test_Conversions'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      pragma Unreferenced (T);

      Path   : constant String := Util.Tests.Get_Path ("regtests/files/file-v1.dat");
      Target : MAT.Targets.Target_Type;
      Reader : MAT.Readers.Streams.Files.File_Reader_Type;
   begin
      Target.Initialize (Reader);
      Reader.Open (Path);
      Reader.Read_All;
   end Test_Read_File;

   --  ------------------------------
   --  Test various type conversions.
   --  ------------------------------
   procedure Test_Conversions (T : in out Test) is
      use MAT.Types;
      Time : MAT.Types.Target_Tick_Ref;
   begin
      Time := MAT.Types.Tick_Value ("1.1");
      Util.Tests.Assert_Equals (T, 1, Natural (Time / 1_000000), "Invalid Tick_Value conversion");
      Util.Tests.Assert_Equals (T, 100_000, Natural (Time mod 1_000000),
                                "Invalid Tick_Value conversion");

      Time := MAT.Types.Tick_Value ("12.001234");
      Util.Tests.Assert_Equals (T, 12, Natural (Time / 1_000000), "Invalid Tick_Value conversion");
      Util.Tests.Assert_Equals (T, 1_234, Natural (Time mod 1_000000),
                                "Invalid Tick_Value conversion");
   end Test_Conversions;

end MAT.Targets.Tests;

Replace Get_Test_Path by Get_Path

Replace Get_Test_Path by Get_Path


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

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is mod 16;

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Time;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

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

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is mod 16;

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Time;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the probe event with the given allocated unique id.
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type;

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

Define the Get_Event function

Define the Get_Event function


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

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return String is
   begin
      return Self.Get (Param.Name.all, Param.Default.all);
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      if Self.Exists (Param.Name.all) then
         return Self.Get (Param.Name.all);
      else
         return Ada.Strings.Unbounded.To_Unbounded_String (Param.Default.all);
      end if;
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Boolean is
      use Util.Properties.Basic.Boolean_Property;
   begin
      return Get (Self, Param.Name.all, Boolean'Value (Param.Default.all));
   end Get;

   --  ------------------------------
   --  Create the configuration parameter definition instance.
   --  ------------------------------
   package body Parameter is
      Param       : constant Config_Param := ASF.Applications.P '(Name => PARAM_NAME'Access,
                                                                  Default => PARAM_VALUE'Access);

      --  ------------------------------
      --  Returns the configuration parameter.
      --  ------------------------------
      function P return Config_Param is
      begin
         return Param;
      end P;

   end Parameter;

end ASF.Applications;

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

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return String is
   begin
      return Self.Get (Param.Name.all, Param.Default.all);
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      if Self.Exists (Param.Name.all) then
         return Self.Get (Param.Name.all);
      else
         return Ada.Strings.Unbounded.To_Unbounded_String (Param.Default.all);
      end if;
   end Get;

   --  ------------------------------
   --  Get the configuration parameter;
   --  ------------------------------
   function Get (Self  : Config;
                 Param : Config_Param) return Boolean is
      use Util.Properties.Basic.Boolean_Property;
   begin
      return Get (Self, Param.Name.all, Boolean'Value (Param.Default.all));
   end Get;

   function Get (Self  : Config;
                 Param : Config_Param) return Integer is
      use Util.Properties.Basic.Integer_Property;
   begin
      return Get (Self, Param.Name.all, Integer'Value (Param.Default.all));
   end Get;

   --  ------------------------------
   --  Create the configuration parameter definition instance.
   --  ------------------------------
   package body Parameter is
      Param       : constant Config_Param := ASF.Applications.P '(Name => PARAM_NAME'Access,
                                                                  Default => PARAM_VALUE'Access);

      --  ------------------------------
      --  Returns the configuration parameter.
      --  ------------------------------
      function P return Config_Param is
      begin
         return Param;
      end P;

   end Parameter;

end ASF.Applications;

Implement the Get function returning integer


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

with GNAT.Command_Line;

with Readline;

with Util.Strings;
with Util.Properties;
with Util.Log.Loggers;

with MAT.Commands;
with MAT.Interrupts;
with MAT.Targets.Probes;
package body MAT.Targets is

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Events.Targets.Target_Events'Class,
                                     MAT.Events.Targets.Target_Events_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Frames.Targets.Target_Frames'Class,
                                     MAT.Frames.Targets.Target_Frames_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Target_Process_Type'Class,
                                     Target_Process_Type_Access);

   --  Configure the log managers used by mat.
   procedure Initialize_Logs (Path : in String);

   --  ------------------------------
   --  Release the target process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Process_Type) is
   begin
      Free (Target.Events);
      Free (Target.Frames);
   end Finalize;

   --  ------------------------------
   --  Find the region that matches the given name.
   --  ------------------------------
   overriding
   function Find_Region (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
   begin
      return Resolver.Memory.Find_Region (Name);
   end Find_Region;

   --  ------------------------------
   --  Find the symbol in the symbol table and return the start and end address.
   --  ------------------------------
   overriding
   function Find_Symbol (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver.Symbols.Is_Null then
         raise MAT.Memory.Targets.Not_Found;
      end if;
      Resolver.Symbols.Value.Find_Symbol_Range (Name, Region.Start_Addr, Region.End_Addr);
      return Region;
   end Find_Symbol;

   --  ------------------------------
   --  Get the start time for the tick reference.
   --  ------------------------------
   overriding
   function Get_Start_Time (Resolver : in Target_Process_Type)
                            return MAT.Types.Target_Tick_Ref is
      Start  : MAT.Types.Target_Tick_Ref;
      Finish : MAT.Types.Target_Tick_Ref;
   begin
      Resolver.Events.Get_Time_Range (Start, Finish);
      return Start;
   end Get_Start_Time;

   --  ------------------------------
   --  Get the console instance.
   --  ------------------------------
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access is
   begin
      return Target.Console;
   end Console;

   --  ------------------------------
   --  Set the console instance.
   --  ------------------------------
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access) is
   begin
      Target.Console := Console;
   end Console;

   --  ------------------------------
   --  Get the current process instance.
   --  ------------------------------
   function Process (Target : in Target_Type) return Target_Process_Type_Access is
   begin
      return Target.Current;
   end Process;

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
   begin
      MAT.Targets.Probes.Initialize (Target  => Target,
                                     Manager => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
      Path_String : constant String := Ada.Strings.Unbounded.To_String (Path);
   begin
      Process := Target.Find_Process (Pid);
      if Process = null then
         Process := new Target_Process_Type;
         Process.Pid := Pid;
         Process.Path := Path;
         Process.Symbols := MAT.Symbols.Targets.Target_Symbols_Refs.Create;
         Process.Symbols.Value.Console := Target.Console;
         Process.Symbols.Value.Search_Path := Target.Options.Search_Path;
         Target.Processes.Insert (Pid, Process);
         Target.Console.Notice (MAT.Consoles.N_PID_INFO,
                                "Process" & MAT.Types.Target_Process_Ref'Image (Pid) & " created");
         Target.Console.Notice (MAT.Consoles.N_PATH_INFO,
                                "Path " & Path_String);
      end if;
      if Target.Current = null then
         Target.Current := Process;
      end if;
   end Create_Process;

   --  ------------------------------
   --  Find the process instance from the process ID.
   --  ------------------------------
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access is
      Pos : constant Process_Cursor := Target.Processes.Find (Pid);
   begin
      if Process_Maps.Has_Element (Pos) then
         return Process_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Process;

   --  ------------------------------
   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class)) is
      Iter : Process_Cursor := Target.Processes.First;
   begin
      while Process_Maps.Has_Element (Iter) loop
         Process (Process_Maps.Element (Iter).all);
         Process_Maps.Next (Iter);
      end loop;
   end Iterator;

   --  ------------------------------
   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   --  ------------------------------
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type is
      Pos    : constant Natural := Util.Strings.Index (Param, ':');
      Result : GNAT.Sockets.Sock_Addr_Type;
   begin
      if Pos > 0 then
         Result.Port := GNAT.Sockets.Port_Type'Value (Param (Pos + 1 .. Param'Last));
         Result.Addr := GNAT.Sockets.Inet_Addr (Param (Param'First .. Pos - 1));
      else
         Result.Port := GNAT.Sockets.Port_Type'Value (Param);
         Result.Addr := GNAT.Sockets.Any_Inet_Addr;
      end if;
      return Result;
   end To_Sock_Addr_Type;

   --  ------------------------------
   --  Print the application usage.
   --  ------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line ("Usage: mat [-i] [-e] [-nw] [-ns] [-s] [-b [ip:]port] [-d path] [file.mat]");
      Put_Line ("-i            Enable the interactive mode");
      Put_Line ("-e            Print the probe events as they are received");
      Put_Line ("-nw           Disable the graphical mode");
      Put_Line ("-s            Start the TCP/IP server to receive events");
      Put_Line ("-b [ip:]port  Define the port and local address to bind");
      Put_Line ("-ns           Disable the automatic symbols loading");
      Put_Line ("-d path       Search path to find shared libraries and load their symbols");
      Ada.Command_Line.Set_Exit_Status (2);
      raise Usage_Error;
   end Usage;

   --  ------------------------------
   --  Add a search path for the library and symbol loader.
   --  ------------------------------
   procedure Add_Search_Path (Target : in out MAT.Targets.Target_Type;
                              Path   : in String) is
   begin
      if Ada.Strings.Unbounded.Length (Target.Options.Search_Path) > 0 then
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, ";");
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, Path);
      else
         Target.Options.Search_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      end if;
   end Add_Search_Path;

   --  ------------------------------
   --  Configure the log managers used by mat.
   --  ------------------------------
   procedure Initialize_Logs (Path : in String) is
      Props : Util.Properties.Manager;
   begin
      begin
         Props.Load_Properties (Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            --  Default log configuration.
            Props.Set ("log4j.rootCategory", "INFO,console,mat");
            Props.Set ("log4j.appender.console", "Console");
            Props.Set ("log4j.appender.console.level", "WARN");
            Props.Set ("log4j.appender.console.layout", "level-message");
            Props.Set ("log4j.appender.mat", "File");
            Props.Set ("log4j.appender.mat.File", "mat.log");
      end;
      Util.Log.Loggers.Initialize (Props);
   end Initialize_Logs;

   --  ------------------------------
   --  Parse the command line arguments and configure the target instance.
   --  ------------------------------
   procedure Initialize_Options (Target  : in out MAT.Targets.Target_Type) is
   begin
      Initialize_Logs ("matp.properties");
      GNAT.Command_Line.Initialize_Option_Scan (Stop_At_First_Non_Switch => True,
                                                Section_Delimiters       => "targs");
      loop
         case GNAT.Command_Line.Getopt ("i e s nw ns b: d:") is
            when ASCII.NUL =>
               exit;

            when 'i' =>
               Target.Options.Interactive := True;

            when 'e' =>
               Target.Options.Print_Events := True;

            when 's' =>
               Target.Options.Server_Mode := True;

            when 'b' =>
               Target.Options.Server_Mode := True;
               Target.Options.Address := To_Sock_Addr_Type (GNAT.Command_Line.Parameter);

            when 'n' =>
               if GNAT.Command_Line.Full_Switch = "nw" then
                  Target.Options.Graphical := False;
               else
                  Target.Options.Load_Symbols := False;
               end if;

            when 'd' =>
               Add_Search_Path (Target, GNAT.Command_Line.Parameter);

            when '*' =>
               exit;

            when others =>
               Usage;

         end case;
      end loop;

   exception
      when Usage_Error =>
         raise;

      when others =>
         Usage;

   end Initialize_Options;

   --  ------------------------------
   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   --  ------------------------------
   procedure Interactive (Target : in out MAT.Targets.Target_Type) is
   begin
      MAT.Interrupts.Install;
      loop
         declare
            Line : constant String := Readline.Get_Line ("mat>");
         begin
            MAT.Interrupts.Clear;
            MAT.Commands.Execute (Target, Line);

         exception
            when MAT.Commands.Stop_Interp =>
               exit;
         end;
      end loop;
   end Interactive;

   --  ------------------------------
   --  Start the server to listen to MAT event socket streams.
   --  ------------------------------
   procedure Start (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Start (Target'Unchecked_Access, Target.Options.Address);
      end if;
   end Start;

   --  ------------------------------
   --  Stop the server thread.
   --  ------------------------------
   procedure Stop (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Stop;
      end if;
   end Stop;

   --  ------------------------------
   --  Release the storage used by the target object.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Type) is
   begin
      while not Target.Processes.Is_Empty loop
         declare
            Process : Target_Process_Type_Access := Target.Processes.First_Element;
         begin
            Free (Process);
            Target.Processes.Delete_First;
         end;
      end loop;
   end Finalize;

end MAT.Targets;

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

with GNAT.Command_Line;

with Readline;

with Util.Strings;
with Util.Properties;
with Util.Log.Loggers;

with MAT.Commands;
with MAT.Interrupts;
with MAT.Targets.Probes;
package body MAT.Targets is

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Events.Targets.Target_Events'Class,
                                     MAT.Events.Targets.Target_Events_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Frames.Targets.Target_Frames'Class,
                                     MAT.Frames.Targets.Target_Frames_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Target_Process_Type'Class,
                                     Target_Process_Type_Access);

   --  Configure the log managers used by mat.
   procedure Initialize_Logs (Path : in String);

   --  ------------------------------
   --  Release the target process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Process_Type) is
   begin
      Free (Target.Events);
      Free (Target.Frames);
   end Finalize;

   --  ------------------------------
   --  Find the region that matches the given name.
   --  ------------------------------
   overriding
   function Find_Region (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
   begin
      return Resolver.Memory.Find_Region (Name);
   end Find_Region;

   --  ------------------------------
   --  Find the symbol in the symbol table and return the start and end address.
   --  ------------------------------
   overriding
   function Find_Symbol (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver.Symbols.Is_Null then
         raise MAT.Memory.Targets.Not_Found;
      end if;
      Resolver.Symbols.Value.Find_Symbol_Range (Name, Region.Start_Addr, Region.End_Addr);
      return Region;
   end Find_Symbol;

   --  ------------------------------
   --  Find the symbol region in the symbol table that contains the given address
   --  and return the start and end address of that region.
   --  ------------------------------
   overriding
   function Find_Symbol (Resolver : in Target_Process_Type;
                         Addr     : in MAT.Types.Target_Addr) return MAT.Memory.Region_Info is
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver.Symbols.Is_Null then
         Region.Start_Addr := Addr;
         Region.End_Addr := Addr;
      else
         Resolver.Symbols.Value.Find_Symbol_Range (Addr, Region.Start_Addr, Region.End_Addr);
      end if;
      return Region;
   end Find_Symbol;

   --  ------------------------------
   --  Get the start time for the tick reference.
   --  ------------------------------
   overriding
   function Get_Start_Time (Resolver : in Target_Process_Type)
                            return MAT.Types.Target_Tick_Ref is
      Start  : MAT.Types.Target_Tick_Ref;
      Finish : MAT.Types.Target_Tick_Ref;
   begin
      Resolver.Events.Get_Time_Range (Start, Finish);
      return Start;
   end Get_Start_Time;

   --  ------------------------------
   --  Get the console instance.
   --  ------------------------------
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access is
   begin
      return Target.Console;
   end Console;

   --  ------------------------------
   --  Set the console instance.
   --  ------------------------------
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access) is
   begin
      Target.Console := Console;
   end Console;

   --  ------------------------------
   --  Get the current process instance.
   --  ------------------------------
   function Process (Target : in Target_Type) return Target_Process_Type_Access is
   begin
      return Target.Current;
   end Process;

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
   begin
      MAT.Targets.Probes.Initialize (Target  => Target,
                                     Manager => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
      Path_String : constant String := Ada.Strings.Unbounded.To_String (Path);
   begin
      Process := Target.Find_Process (Pid);
      if Process = null then
         Process := new Target_Process_Type;
         Process.Pid := Pid;
         Process.Path := Path;
         Process.Symbols := MAT.Symbols.Targets.Target_Symbols_Refs.Create;
         Process.Symbols.Value.Console := Target.Console;
         Process.Symbols.Value.Search_Path := Target.Options.Search_Path;
         Target.Processes.Insert (Pid, Process);
         Target.Console.Notice (MAT.Consoles.N_PID_INFO,
                                "Process" & MAT.Types.Target_Process_Ref'Image (Pid) & " created");
         Target.Console.Notice (MAT.Consoles.N_PATH_INFO,
                                "Path " & Path_String);
      end if;
      if Target.Current = null then
         Target.Current := Process;
      end if;
   end Create_Process;

   --  ------------------------------
   --  Find the process instance from the process ID.
   --  ------------------------------
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access is
      Pos : constant Process_Cursor := Target.Processes.Find (Pid);
   begin
      if Process_Maps.Has_Element (Pos) then
         return Process_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Process;

   --  ------------------------------
   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class)) is
      Iter : Process_Cursor := Target.Processes.First;
   begin
      while Process_Maps.Has_Element (Iter) loop
         Process (Process_Maps.Element (Iter).all);
         Process_Maps.Next (Iter);
      end loop;
   end Iterator;

   --  ------------------------------
   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   --  ------------------------------
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type is
      Pos    : constant Natural := Util.Strings.Index (Param, ':');
      Result : GNAT.Sockets.Sock_Addr_Type;
   begin
      if Pos > 0 then
         Result.Port := GNAT.Sockets.Port_Type'Value (Param (Pos + 1 .. Param'Last));
         Result.Addr := GNAT.Sockets.Inet_Addr (Param (Param'First .. Pos - 1));
      else
         Result.Port := GNAT.Sockets.Port_Type'Value (Param);
         Result.Addr := GNAT.Sockets.Any_Inet_Addr;
      end if;
      return Result;
   end To_Sock_Addr_Type;

   --  ------------------------------
   --  Print the application usage.
   --  ------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line ("Usage: mat [-i] [-e] [-nw] [-ns] [-s] [-b [ip:]port] [-d path] [file.mat]");
      Put_Line ("-i            Enable the interactive mode");
      Put_Line ("-e            Print the probe events as they are received");
      Put_Line ("-nw           Disable the graphical mode");
      Put_Line ("-s            Start the TCP/IP server to receive events");
      Put_Line ("-b [ip:]port  Define the port and local address to bind");
      Put_Line ("-ns           Disable the automatic symbols loading");
      Put_Line ("-d path       Search path to find shared libraries and load their symbols");
      Ada.Command_Line.Set_Exit_Status (2);
      raise Usage_Error;
   end Usage;

   --  ------------------------------
   --  Add a search path for the library and symbol loader.
   --  ------------------------------
   procedure Add_Search_Path (Target : in out MAT.Targets.Target_Type;
                              Path   : in String) is
   begin
      if Ada.Strings.Unbounded.Length (Target.Options.Search_Path) > 0 then
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, ";");
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, Path);
      else
         Target.Options.Search_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      end if;
   end Add_Search_Path;

   --  ------------------------------
   --  Configure the log managers used by mat.
   --  ------------------------------
   procedure Initialize_Logs (Path : in String) is
      Props : Util.Properties.Manager;
   begin
      begin
         Props.Load_Properties (Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            --  Default log configuration.
            Props.Set ("log4j.rootCategory", "INFO,console,mat");
            Props.Set ("log4j.appender.console", "Console");
            Props.Set ("log4j.appender.console.level", "WARN");
            Props.Set ("log4j.appender.console.layout", "level-message");
            Props.Set ("log4j.appender.mat", "File");
            Props.Set ("log4j.appender.mat.File", "mat.log");
      end;
      Util.Log.Loggers.Initialize (Props);
   end Initialize_Logs;

   --  ------------------------------
   --  Parse the command line arguments and configure the target instance.
   --  ------------------------------
   procedure Initialize_Options (Target  : in out MAT.Targets.Target_Type) is
   begin
      Initialize_Logs ("matp.properties");
      GNAT.Command_Line.Initialize_Option_Scan (Stop_At_First_Non_Switch => True,
                                                Section_Delimiters       => "targs");
      loop
         case GNAT.Command_Line.Getopt ("i e s nw ns b: d:") is
            when ASCII.NUL =>
               exit;

            when 'i' =>
               Target.Options.Interactive := True;

            when 'e' =>
               Target.Options.Print_Events := True;

            when 's' =>
               Target.Options.Server_Mode := True;

            when 'b' =>
               Target.Options.Server_Mode := True;
               Target.Options.Address := To_Sock_Addr_Type (GNAT.Command_Line.Parameter);

            when 'n' =>
               if GNAT.Command_Line.Full_Switch = "nw" then
                  Target.Options.Graphical := False;
               else
                  Target.Options.Load_Symbols := False;
               end if;

            when 'd' =>
               Add_Search_Path (Target, GNAT.Command_Line.Parameter);

            when '*' =>
               exit;

            when others =>
               Usage;

         end case;
      end loop;

   exception
      when Usage_Error =>
         raise;

      when others =>
         Usage;

   end Initialize_Options;

   --  ------------------------------
   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   --  ------------------------------
   procedure Interactive (Target : in out MAT.Targets.Target_Type) is
   begin
      MAT.Interrupts.Install;
      loop
         declare
            Line : constant String := Readline.Get_Line ("mat>");
         begin
            MAT.Interrupts.Clear;
            MAT.Commands.Execute (Target, Line);

         exception
            when MAT.Commands.Stop_Interp =>
               exit;
         end;
      end loop;
   end Interactive;

   --  ------------------------------
   --  Start the server to listen to MAT event socket streams.
   --  ------------------------------
   procedure Start (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Start (Target'Unchecked_Access, Target.Options.Address);
      end if;
   end Start;

   --  ------------------------------
   --  Stop the server thread.
   --  ------------------------------
   procedure Stop (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Stop;
      end if;
   end Stop;

   --  ------------------------------
   --  Release the storage used by the target object.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Type) is
   begin
      while not Target.Processes.Is_Empty loop
         declare
            Process : Target_Process_Type_Access := Target.Processes.First_Element;
         begin
            Free (Process);
            Target.Processes.Delete_First;
         end;
      end loop;
   end Finalize;

end MAT.Targets;

Implement the new Find_Symbol by using the Find_Symbol_Range operation