-----------------------------------------------------------------------
--  awa-users-servlets -- OpenID verification servlet for user authentication
--  Copyright (C) 2011, 2012, 2013, 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 Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;

with ASF.Cookies;
with ASF.Servlets;

with AWA.Users.Services;
with AWA.Users.Modules;
with AWA.Users.Filters;
with AWA.Users.Principals;
package body AWA.Users.Servlets is

   --  Name of the session attribute which holds the URI to redirect after authentication.
   REDIRECT_ATTRIBUTE : constant String := "awa-redirect";

   --  Name of the request attribute that contains the URI to redirect after authentication.
   REDIRECT_PARAM     : constant String := "redirect";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

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

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (Security.Auth.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      pragma Unreferenced (Server);

      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return URI (URI'First + 1 .. URI'Last);
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Ctx      : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Name     : constant String := Get_Provider_URL (Server, Request);
      URL      : constant String := Ctx.Get_Init_Parameter ("auth.url." & Name);
   begin
      Log.Info ("Request OpenId authentication to {0} - {1}", Name, URL);

      if Name'Length = 0 or URL'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : Security.Auth.Manager;
         OP    : Security.Auth.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
         Redirect : constant String := Request.Get_Parameter (REDIRECT_PARAM);
      begin
         Server.Initialize (Name, Mgr);

         --  Yadis discovery (get the XRDS file).  This step does nothing for OAuth.
         Mgr.Discover (URL, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
            if Redirect'Length > 0 then
               Session.Set_Attribute (Name  => REDIRECT_ATTRIBUTE,
                                      Value => Util.Beans.Objects.To_Object (Redirect));
            end if;
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   overriding
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in Security.Auth.Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);
      use AWA.Users.Modules;
      use AWA.Users.Services;

      Manager   : constant User_Service_Access := AWA.Users.Modules.Get_User_Manager;
      Principal : AWA.Users.Principals.Principal_Access;
   begin
      Manager.Authenticate (Auth    => Auth,
                            IpAddr  => "",
                            Principal => Principal);
      Result := Principal.all'Access;
   end Create_Principal;

   --  ------------------------------
   --  Get the redirection URL that must be used after the authentication succeeded.
   --  ------------------------------
   function Get_Redirect_URL (Server  : in Verify_Auth_Servlet;
                              Session : in ASF.Sessions.Session'Class;
                              Request : in ASF.Requests.Request'Class) return String is
      Redir : constant Util.Beans.Objects.Object := Session.Get_Attribute (REDIRECT_ATTRIBUTE);
      Ctx   : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if not Util.Beans.Objects.Is_Null (Redir) then
         return Util.Beans.Objects.To_String (Redir);
      end if;
      declare
         Cookies : constant ASF.Cookies.Cookie_Array := Request.Get_Cookies;
      begin
         for I in Cookies'Range loop
            if ASF.Cookies.Get_Name (Cookies (I)) = AWA.Users.Filters.REDIRECT_COOKIE then
               return ASF.Cookies.Get_Value (Cookies (I));
            end if;
         end loop;
      end;
      return Ctx.Get_Init_Parameter ("openid.success_url");
   end Get_Redirect_URL;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      use type Security.Auth.Auth_Result;

      type Auth_Params is new Security.Auth.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return Request.Get_Parameter (Name);
      end Get_Parameter;

      Session    : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean       : Util.Beans.Objects.Object;
      Mgr        : Security.Auth.Manager;
      Assoc      : Association_Access;
      Credential : Security.Auth.Authentication;
      Params     : Auth_Params;
   begin
      Log.Info ("Verify openid authentication");

      if not Session.Is_Valid then
         Log.Warn ("Session has expired during OpenID authentication process");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Bean := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Security.Auth.Get_Provider (Assoc.all), Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Params, Credential);
      if Security.Auth.Get_Status (Credential) /= Security.Auth.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", Security.Auth.Get_Email (Credential));

      --  Get a user principal and set it on the session.
      declare
         User     : ASF.Principals.Principal_Access;
         Redirect : constant String
           := Verify_Auth_Servlet'Class (Server).Get_Redirect_URL (Session, Request);
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Credential, User);
         Session.Set_Principal (User);
         Session.Remove_Attribute (REDIRECT_ATTRIBUTE);

         Log.Info ("Redirect user to URL: {0}", Redirect);
         Response.Send_Redirect (Redirect);
      end;
   end Do_Get;

end AWA.Users.Servlets;

-----------------------------------------------------------------------
--  awa-users-servlets -- OpenID verification servlet for user authentication
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;

with ASF.Cookies;
with ASF.Servlets;

with AWA.Users.Services;
with AWA.Users.Modules;
with AWA.Users.Filters;
with AWA.Users.Principals;
package body AWA.Users.Servlets is

   --  Name of the session attribute which holds the URI to redirect after authentication.
   REDIRECT_ATTRIBUTE : constant String := "awa-redirect";

   --  Name of the request attribute that contains the URI to redirect after authentication.
   REDIRECT_PARAM     : constant String := "redirect";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Servlets");

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (Security.Auth.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      pragma Unreferenced (Server);

      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return URI (URI'First + 1 .. URI'Last);
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Ctx      : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Name     : constant String := Get_Provider_URL (Server, Request);
      URL      : constant String := Ctx.Get_Init_Parameter ("auth.url." & Name);
   begin
      Log.Info ("GET: request OpenId authentication to {0} - {1}", Name, URL);

      if Name'Length = 0 or URL'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : Security.Auth.Manager;
         OP    : Security.Auth.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
         Redirect : constant String := Request.Get_Parameter (REDIRECT_PARAM);
      begin
         Server.Initialize (Name, Mgr);

         --  Yadis discovery (get the XRDS file).  This step does nothing for OAuth.
         Mgr.Discover (URL, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
            if Redirect'Length > 0 then
               Session.Set_Attribute (Name  => REDIRECT_ATTRIBUTE,
                                      Value => Util.Beans.Objects.To_Object (Redirect));
            end if;
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   overriding
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in Security.Auth.Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);
      use AWA.Users.Modules;
      use AWA.Users.Services;

      Manager   : constant User_Service_Access := AWA.Users.Modules.Get_User_Manager;
      Principal : AWA.Users.Principals.Principal_Access;
   begin
      Manager.Authenticate (Auth    => Auth,
                            IpAddr  => "",
                            Principal => Principal);
      Result := Principal.all'Access;
   end Create_Principal;

   --  ------------------------------
   --  Get the redirection URL that must be used after the authentication succeeded.
   --  ------------------------------
   function Get_Redirect_URL (Server  : in Verify_Auth_Servlet;
                              Session : in ASF.Sessions.Session'Class;
                              Request : in ASF.Requests.Request'Class) return String is
      Redir : constant Util.Beans.Objects.Object := Session.Get_Attribute (REDIRECT_ATTRIBUTE);
      Ctx   : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if not Util.Beans.Objects.Is_Null (Redir) then
         return Util.Beans.Objects.To_String (Redir);
      end if;
      declare
         Cookies : constant ASF.Cookies.Cookie_Array := Request.Get_Cookies;
      begin
         for I in Cookies'Range loop
            if ASF.Cookies.Get_Name (Cookies (I)) = AWA.Users.Filters.REDIRECT_COOKIE then
               return ASF.Cookies.Get_Value (Cookies (I));
            end if;
         end loop;
      end;
      return Ctx.Get_Init_Parameter ("openid.success_url");
   end Get_Redirect_URL;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      use type Security.Auth.Auth_Result;

      type Auth_Params is new Security.Auth.Parameters with null record;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String;

      overriding
      function Get_Parameter (Params : in Auth_Params;
                              Name   : in String) return String is
         pragma Unreferenced (Params);
      begin
         return Request.Get_Parameter (Name);
      end Get_Parameter;

      Session    : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean       : Util.Beans.Objects.Object;
      Mgr        : Security.Auth.Manager;
      Assoc      : Association_Access;
      Credential : Security.Auth.Authentication;
      Params     : Auth_Params;
   begin
      Log.Info ("GET: verify openid authentication");

      if not Session.Is_Valid then
         Log.Warn ("Session has expired during OpenID authentication process");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Bean := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Security.Auth.Get_Provider (Assoc.all), Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Params, Credential);
      if Security.Auth.Get_Status (Credential) /= Security.Auth.AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", Security.Auth.Get_Email (Credential));

      --  Get a user principal and set it on the session.
      declare
         User     : ASF.Principals.Principal_Access;
         Redirect : constant String
           := Verify_Auth_Servlet'Class (Server).Get_Redirect_URL (Session, Request);
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Credential, User);
         Session.Set_Principal (User);
         Session.Remove_Attribute (REDIRECT_ATTRIBUTE);

         Log.Info ("Redirect user to URL: {0}", Redirect);
         Response.Send_Redirect (Redirect);
      end;
   end Do_Get;

end AWA.Users.Servlets;

Update the logs to better help in analyzing problems


-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  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.
-----------------------------------------------------------------------
pragma Ada_2012;
with Babel.Files.Queues;
package Babel.Strategies.Default is

   type Default_Strategy_Type is new Babel.Strategies.Strategy_Type with private;

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean;

   --  Get the next directory that must be processed by the strategy.
   overriding
   function Peek_Directory (Strategy : in out Default_Strategy_Type) return String;

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type);

   overriding
   procedure Add_File (Into    : in out Default_Strategy_Type;
                       Path    : in String;
                       Element : in Babel.Files.File);

   overriding
   procedure Add_Directory (Into : in out Default_Strategy_Type;
                            Path : in String;
                            Name : in String);

private

   type Default_Strategy_Type is new Babel.Strategies.Strategy_Type with record
      Queue : Babel.Files.Queues.File_Queue;
   end record;

end Babel.Strategies.Default;

-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  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.
-----------------------------------------------------------------------
pragma Ada_2012;
with Babel.Files.Queues;
package Babel.Strategies.Default is

   type Default_Strategy_Type is new Babel.Strategies.Strategy_Type with private;

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean;

   --  Get the next directory that must be processed by the strategy.
   overriding
   procedure Peek_Directory (Strategy  : in out Default_Strategy_Type;
                             Directory : out Babel.Files.Directory_Type);

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type);

   overriding
   procedure Add_File (Into    : in out Default_Strategy_Type;
                       Path    : in String;
                       Element : in Babel.Files.File);

   overriding
   procedure Add_Directory (Into : in out Default_Strategy_Type;
                            Path : in String;
                            Name : in String);

private

   type Default_Strategy_Type is new Babel.Strategies.Strategy_Type with record
      Queue : Babel.Files.Queues.File_Queue;
   end record;

end Babel.Strategies.Default;

Change the Peek_Directory to a procedure


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

with Ada.Strings;
with Util.Strings;
with Util.Log.Loggers;
package body Gen.Model.Tables is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Tables");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
   begin

      if Name = "type" then
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return Util.Beans.Objects.To_Object (T.all'Access, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "index" then
         return Util.Beans.Objects.To_Object (From.Number);

      elsif Name = "isUnique" then
         return Util.Beans.Objects.To_Object (From.Unique);

      elsif Name = "isNull" then
         return Util.Beans.Objects.To_Object (not From.Not_Null);

      elsif Name = "isInserted" then
         return Util.Beans.Objects.To_Object (From.Is_Inserted);

      elsif Name = "isUpdated" then
         return Util.Beans.Objects.To_Object (From.Is_Updated);

      elsif Name = "sqlType" then
         if Length (From.Sql_Type) > 0 then
            return Util.Beans.Objects.To_Object (From.Sql_Type);
         end if;
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return T.Get_Value ("name");
         end;

      elsif Name = "sqlName" then
         return Util.Beans.Objects.To_Object (From.Sql_Name);

      elsif Name = "isVersion" then
         return Util.Beans.Objects.To_Object (From.Is_Version);

      elsif Name = "isReadable" then
         return Util.Beans.Objects.To_Object (From.Is_Readable);

      elsif Name = "isPrimaryKey" then
         return Util.Beans.Objects.To_Object (From.Is_Key);

      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Is_Basic_Type);

      elsif Name = "generator" then
         return From.Generator;

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Returns true if the column type is a basic type.
   --  ------------------------------
   function Is_Basic_Type (From : in Column_Definition) return Boolean is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      use type Gen.Model.Mappings.Basic_Type;

      T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
      Name : constant String := To_String (From.Type_Name);
   begin
      if T /= null then
         return T.Kind /= Gen.Model.Mappings.T_BLOB;
      end if;
      return Name = "int" or Name = "String"
        or Name = "ADO.Identifier" or Name = "Timestamp"
        or Name = "Integer"
        or Name = "long" or Name = "Long" or Name = "Date" or Name = "Time";
   end Is_Basic_Type;

   --  ------------------------------
   --  Returns the column type.
   --  ------------------------------
   function Get_Type (From : in Column_Definition) return String is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      T : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
   begin
      if T /= null then
         return To_String (T.Target);
      else
         return To_String (From.Type_Name);
      end if;
   end Get_Type;

   --  ------------------------------
   --  Returns the column type mapping.
   --  ------------------------------
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access is
      use type Mappings.Mapping_Definition_Access;

      Result : Gen.Model.Mappings.Mapping_Definition_Access := null;
      Pos    : constant Natural := Ada.Strings.Unbounded.Index (From.Type_Name, ".");
   begin
      if Pos = 0 then
         Result := Gen.Model.Mappings.Find_Type (From.Type_Name);
      end if;
      if From.Type_Name = "Gen.Tests.Tables.Test_Enum" then
         Log.Debug ("Found enum");
      end if;
      if Result = null then
         Result := From.Table.Package_Def.Find_Type (From.Type_Name);
      end if;
      return Result;
   end Get_Type_Mapping;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Column_Definition) is
      use type Mappings.Mapping_Definition_Access;
   begin
--        O.Type_Mapping := Gen.Model.Mappings.Find_Type (O.Type_Name);
--        if O.Type_Mapping = null then
--           O.Type_Mapping := O.Table.Package_Def.Find_Type (O.Type_Name);
--        end if;
      null;
   end Prepare;

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

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Table_Definition) is
   begin
      O.Members_Bean := Util.Beans.Objects.To_Object (O.Members'Unchecked_Access,
                                                      Util.Beans.Objects.STATIC);
      O.Operations_Bean := Util.Beans.Objects.To_Object (O.Operations'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Create a table with the given name.
   --  ------------------------------
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access is
      Table : constant Table_Definition_Access := new Table_Definition;
   begin
      Table.Name := Name;
      Table.Kind := Gen.Model.Mappings.T_TABLE;
      declare
         Pos : constant Natural := Index (Table.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Table.Pkg_Name := Unbounded_Slice (Table.Name, 1, Pos - 1);
            Table.Type_Name := Unbounded_Slice (Table.Name, Pos + 1, Length (Table.Name));
         else
            Table.Pkg_Name := To_Unbounded_String ("ADO");
            Table.Type_Name := Table.Name;
         end if;
         Table.Table_Name := Table.Type_Name;
      end;
      return Table;
   end Create_Table;

   --  ------------------------------
   --  Create a table column with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access) is
   begin
      Column := new Column_Definition;
      Column.Name     := Name;
      Column.Sql_Name := Name;
      Column.Number   := Table.Members.Get_Count;
      Column.Table    := Table'Unchecked_Access;
      Table.Members.Append (Column);
      if Name = "version" then
         Table.Version_Column := Column;
         Column.Is_Version  := True;
         Column.Is_Updated  := False;
         Column.Is_Inserted := False;

      elsif Name = "id" then
         Table.Id_Column := Column;
         Column.Is_Key := True;

      end if;
   end Add_Column;

   --  ------------------------------
   --  Create a table association with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access) is
   begin
      Assoc := new Association_Definition;
      Assoc.Name   := Name;
      Assoc.Number := Table.Members.Get_Count;
      Assoc.Table  := Table'Unchecked_Access;
      Assoc.Sql_Name := Name;
      Table.Members.Append (Assoc.all'Access);
      Table.Has_Associations := True;
   end Add_Association;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Table_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" or Name = "columns" then
         return From.Members_Bean;

      elsif Name = "operations" then
         return From.Operations_Bean;

      elsif Name = "id" and From.Id_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access := From.Id_Column.all'Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "version" and From.Version_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access
              := From.Version_Column.all'Unchecked_Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "hasAssociations" then
         return Util.Beans.Objects.To_Object (From.Has_Associations);

      elsif Name = "hasList" then
         return Util.Beans.Objects.To_Object (From.Has_List);

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "table" then
         return Util.Beans.Objects.To_Object (From.Table_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Table_Definition) is
      Iter : Column_List.Cursor := O.Members.First;
   begin
      while Column_List.Has_Element (Iter) loop
         Column_List.Element (Iter).Prepare;
         Column_List.Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Set the table name and determines the package name.
   --  ------------------------------
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      Table.Name := To_Unbounded_String (Name);
      if Pos > 0 then
         Table.Pkg_Name := To_Unbounded_String (Name (Name'First .. Pos - 1));
         Table.Type_Name := To_Unbounded_String (Name (Pos + 1 .. Name'Last));
      else
         Table.Pkg_Name := To_Unbounded_String ("ADO");
         Table.Type_Name := Table.Name;
      end if;
   end Set_Table_Name;

end Gen.Model.Tables;

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

with Ada.Strings;
with Util.Strings;
with Util.Log.Loggers;
package body Gen.Model.Tables is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Tables");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
   begin

      if Name = "type" then
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return Util.Beans.Objects.To_Object (T.all'Access, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "index" then
         return Util.Beans.Objects.To_Object (From.Number);

      elsif Name = "isUnique" then
         return Util.Beans.Objects.To_Object (From.Unique);

      elsif Name = "isNull" then
         return Util.Beans.Objects.To_Object (not From.Not_Null);

      elsif Name = "isInserted" then
         return Util.Beans.Objects.To_Object (From.Is_Inserted);

      elsif Name = "isUpdated" then
         return Util.Beans.Objects.To_Object (From.Is_Updated);

      elsif Name = "sqlType" then
         if Length (From.Sql_Type) > 0 then
            return Util.Beans.Objects.To_Object (From.Sql_Type);
         end if;
         declare
            T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
         begin
            if T = null then
               return Util.Beans.Objects.Null_Object;
            end if;
            return T.Get_Value ("name");
         end;

      elsif Name = "sqlName" then
         return Util.Beans.Objects.To_Object (From.Sql_Name);

      elsif Name = "isVersion" then
         return Util.Beans.Objects.To_Object (From.Is_Version);

      elsif Name = "isReadable" then
         return Util.Beans.Objects.To_Object (From.Is_Readable);

      elsif Name = "isPrimaryKey" then
         return Util.Beans.Objects.To_Object (From.Is_Key);

      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Is_Basic_Type);

      elsif Name = "generator" then
         return From.Generator;

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Returns true if the column type is a basic type.
   --  ------------------------------
   function Is_Basic_Type (From : in Column_Definition) return Boolean is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      use type Gen.Model.Mappings.Basic_Type;

      T    : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
      Name : constant String := To_String (From.Type_Name);
   begin
      if T /= null then
         return T.Kind /= Gen.Model.Mappings.T_BLOB;
      end if;
      return Name = "int" or Name = "String"
        or Name = "ADO.Identifier" or Name = "Timestamp"
        or Name = "Integer"
        or Name = "long" or Name = "Long" or Name = "Date" or Name = "Time";
   end Is_Basic_Type;

   --  ------------------------------
   --  Returns the column type.
   --  ------------------------------
   function Get_Type (From : in Column_Definition) return String is
      use type Gen.Model.Mappings.Mapping_Definition_Access;
      T : constant Gen.Model.Mappings.Mapping_Definition_Access := From.Get_Type_Mapping;
   begin
      if T /= null then
         return To_String (T.Target);
      else
         return To_String (From.Type_Name);
      end if;
   end Get_Type;

   --  ------------------------------
   --  Returns the column type mapping.
   --  ------------------------------
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access is
      use type Mappings.Mapping_Definition_Access;

      Result : Gen.Model.Mappings.Mapping_Definition_Access := null;
      Pos    : constant Natural := Ada.Strings.Unbounded.Index (From.Type_Name, ".");
   begin
      if Pos = 0 then
         Result := Gen.Model.Mappings.Find_Type (From.Type_Name);
      end if;
      if From.Type_Name = "Gen.Tests.Tables.Test_Enum" then
         Log.Debug ("Found enum");
      end if;
      if Result = null then
         Result := From.Table.Package_Def.Find_Type (From.Type_Name);
      end if;
      return Result;
   end Get_Type_Mapping;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Column_Definition) is
      use type Mappings.Mapping_Definition_Access;
   begin
--        O.Type_Mapping := Gen.Model.Mappings.Find_Type (O.Type_Name);
--        if O.Type_Mapping = null then
--           O.Type_Mapping := O.Table.Package_Def.Find_Type (O.Type_Name);
--        end if;
      null;
   end Prepare;

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

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Table_Definition) is
   begin
      O.Members_Bean := Util.Beans.Objects.To_Object (O.Members'Unchecked_Access,
                                                      Util.Beans.Objects.STATIC);
      O.Operations_Bean := Util.Beans.Objects.To_Object (O.Operations'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Create a table with the given name.
   --  ------------------------------
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access is
      Table : constant Table_Definition_Access := new Table_Definition;
   begin
      Table.Name := Name;
      Table.Kind := Gen.Model.Mappings.T_TABLE;
      declare
         Pos : constant Natural := Index (Table.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Table.Pkg_Name := Unbounded_Slice (Table.Name, 1, Pos - 1);
            Table.Type_Name := Unbounded_Slice (Table.Name, Pos + 1, Length (Table.Name));
         else
            Table.Pkg_Name := To_Unbounded_String ("ADO");
            Table.Type_Name := Table.Name;
         end if;
         Table.Table_Name := Table.Type_Name;
      end;
      return Table;
   end Create_Table;

   --  ------------------------------
   --  Create a table column with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access) is
   begin
      Column := new Column_Definition;
      Column.Name     := Name;
      Column.Sql_Name := Name;
      Column.Number   := Table.Members.Get_Count;
      Column.Table    := Table'Unchecked_Access;
      Table.Members.Append (Column);
      if Name = "version" then
         Table.Version_Column := Column;
         Column.Is_Version  := True;
         Column.Is_Updated  := False;
         Column.Is_Inserted := False;

      elsif Name = "id" then
         Table.Id_Column := Column;
         Column.Is_Key := True;

      end if;
   end Add_Column;

   --  ------------------------------
   --  Create a table association with the given name and add it to the table.
   --  ------------------------------
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access) is
   begin
      Assoc := new Association_Definition;
      Assoc.Name   := Name;
      Assoc.Number := Table.Members.Get_Count;
      Assoc.Table  := Table'Unchecked_Access;
      Assoc.Sql_Name := Name;
      Table.Members.Append (Assoc.all'Access);
      Table.Has_Associations := True;
   end Add_Association;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Table_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" or Name = "columns" then
         return From.Members_Bean;

      elsif Name = "operations" then
         return From.Operations_Bean;

      elsif Name = "id" and From.Id_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access := From.Id_Column.all'Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "version" and From.Version_Column /= null then
         declare
            Bean : constant Util.Beans.Basic.Readonly_Bean_Access
              := From.Version_Column.all'Unchecked_Access;
         begin
            return Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;

      elsif Name = "hasAssociations" then
         return Util.Beans.Objects.To_Object (From.Has_Associations);

      elsif Name = "hasList" then
         return Util.Beans.Objects.To_Object (From.Has_List);

      elsif Name = "type" then
         return Util.Beans.Objects.To_Object (From.Type_Name);

      elsif Name = "table" then
         return Util.Beans.Objects.To_Object (From.Table_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Table_Definition) is
      Iter : Column_List.Cursor := O.Members.First;
      C    : Column_Definition_Access;
   begin
      Log.Info ("Prepare table {0}", O.Name);

      while Column_List.Has_Element (Iter) loop
         C := Column_List.Element (Iter);
         C.Prepare;
         if C.Is_Key then
            Log.Info ("Found key {0}", C.Name);
            O.Id_Column := C;
         end if;
         Column_List.Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Set the table name and determines the package name.
   --  ------------------------------
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      Table.Name := To_Unbounded_String (Name);
      if Pos > 0 then
         Table.Pkg_Name := To_Unbounded_String (Name (Name'First .. Pos - 1));
         Table.Type_Name := To_Unbounded_String (Name (Pos + 1 .. Name'Last));
      else
         Table.Pkg_Name := To_Unbounded_String ("ADO");
         Table.Type_Name := Table.Name;
      end if;
   end Set_Table_Name;

end Gen.Model.Tables;

Prepare the table to identify the primary key


-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  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.Containers.Ordered_Maps;
with Ada.Containers.Vectors;
package MAT.Events.Tools is

   Not_Found : exception;

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

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

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type;

   type Event_Info_Type is record
      First_Event : Target_Event_Type;
      Last_Event  : Target_Event_Type;
      Frame_Addr  : MAT.Types.Target_Addr;
      Count       : Natural;
      Alloc_Size  : MAT.Types.Target_Size := 0;
      Free_Size   : MAT.Types.Target_Size := 0;
   end record;

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   --  The frame key is composed of the frame address and the frame level.
   type Frame_Key_Type is record
      Addr  : MAT.Types.Target_Addr;
      Level : Natural;
   end record;
   function "<" (Left, Right : in Frame_Key_Type) return Boolean;

   --  Ordered map to collect event info statistics by <frame, level> pair.
   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Frame_Key_Type,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

end MAT.Events.Tools;

-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  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.Containers.Ordered_Maps;
with Ada.Containers.Vectors;
package MAT.Events.Tools is

   Not_Found : exception;

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

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

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type;

   type Event_Info_Type is record
      First_Event : Target_Event_Type;
      Last_Event  : Target_Event_Type;
      Frame_Addr  : MAT.Types.Target_Addr;
      Count       : Natural;
      Alloc_Size  : MAT.Types.Target_Size := 0;
      Free_Size   : MAT.Types.Target_Size := 0;
   end record;

   package Size_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Size,
                                      Element_Type => Event_Info_Type);
   subtype Size_Event_Info_Map is Size_Event_Info_Maps.Map;
   subtype Size_Event_Info_Cursor is Size_Event_Info_Maps.Cursor;

   --  The frame key is composed of the frame address and the frame level.
   type Frame_Key_Type is record
      Addr  : MAT.Types.Target_Addr;
      Level : Natural;
   end record;
   function "<" (Left, Right : in Frame_Key_Type) return Boolean;

   --  Ordered map to collect event info statistics by <frame, level> pair.
   package Frame_Event_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Frame_Key_Type,
                                      Element_Type => Event_Info_Type);
   subtype Frame_Event_Info_Map is Frame_Event_Info_Maps.Map;
   subtype Frame_Event_Info_Cursor is Frame_Event_Info_Maps.Cursor;

   package Event_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Event_Info_Type);
   subtype Event_Info_Vector is Event_Info_Vectors.Vector;
   subtype Event_Info_Cursor is Event_Info_Vectors.Cursor;

   --  Extract from the frame info map, the list of event info sorted on the count.
   procedure Build_Event_Info (Map : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector);

   type Frame_Info_Type is record
      Key  : Frame_Key_Type;
      Info : Event_Info_Type;
   end record;

   package Frame_Info_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Frame_Info_Type);
   subtype Frame_Info_Vector is Frame_Info_Vectors.Vector;
   subtype Frame_Info_Cursor is Frame_Info_Vectors.Cursor;

end MAT.Events.Tools;

Declare the Frame_Info_Type record Instantiate the Frame_Info_Vectors package


-- Lumen.Window -- Create and destroy native windows and associated OpenGL
-- rendering contexts
--
-- Chip Richards, NiEstu, Phoenix AZ, Spring 2010

-- This code is covered by the ISC License:
--
-- Copyright © 2010, NiEstu
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- The software is provided "as is" and the author disclaims all warranties
-- with regard to this software including all implied warranties of
-- merchantability and fitness. In no event shall the author be liable for any
-- special, direct, indirect, or consequential damages or any damages
-- whatsoever resulting from loss of use, data or profits, whether in an
-- action of contract, negligence or other tortious action, arising out of or
-- in connection with the use or performance of this software.

-- Environment
with Lumen.Internal;

package Lumen.Window is

   -- Handle for a Lumen window
   type Handle is access Internal.Window_Info;

   -- Handle for an OpenGL rendering context
   subtype Context_Handle is Internal.GLX_Context;

   -- Null window; in X, this means the root window is the parent
   No_Window : constant Handle := null;

   -- Means "no GL context"; for Create, means create a new one
   No_Context : constant Context_Handle := Internal.Null_Context;

   -- Types of events wanted, and a set listing them.
   type Wanted_Event is (Want_Key_Press, Want_Key_Release, Want_Button_Press,  Want_Button_Release,
                         Want_Window_Enter, Want_Window_Leave,
                         Want_Pointer_Move, Want_Pointer_Drag,
                         Want_Exposure, Want_Focus_Change);
   type Wanted_Event_Set is array (Wanted_Event) of Boolean;
   Want_No_Events  : Wanted_Event_Set := (others => False);
   Want_All_Events : Wanted_Event_Set := (others => True);

   -- Rendering context's color depth
   type Color_Depth is (Pseudo_Color, True_Color);

   -- OpenGL context ("visual") attribute specifiers
   type Context_Attribute_Name is
      (
       Attr_None,
       Attr_Use_GL,             -- unused
       Attr_Buffer_Size,        -- color index buffer size, ignored if TrueColor
       Attr_Level,              -- buffer level for over/underlays
       Attr_RGBA,               -- set by Depth => TrueColor
       Attr_Doublebuffer,       -- set by Animate => True
       Attr_Stereo,             -- wow, you have stereo visuals?
       Attr_Aux_Buffers,        -- number of auxiliary buffers
       Attr_Red_Size,           -- bit depth, red
       Attr_Green_Size,         -- bit depth, green
       Attr_Blue_Size,          -- bit depth, blue
       Attr_Alpha_Size,         -- bit depth, alpha
       Attr_Depth_Size,         -- depth buffer size
       Attr_Stencil_Size,       -- stencil buffer size
       Attr_Accum_Red_Size,     -- accumulation buffer bit depth, red
       Attr_Accum_Green_Size,   -- accumulation buffer bit depth, green
       Attr_Accum_Blue_Size,    -- accumulation buffer bit depth, blue
       Attr_Accum_Alpha_Size    -- accumulation buffer bit depth, alpha
      );

   type Context_Attribute (Name  : Context_Attribute_Name := Attr_None) is record
      case Name is
         when Attr_None | Attr_Use_GL | Attr_RGBA | Attr_Doublebuffer | Attr_Stereo =>
            null;  -- all present or not, no value
         when Attr_Level =>
            Level : Integer := 0;
         when Attr_Buffer_Size | Attr_Aux_Buffers | Attr_Depth_Size | Attr_Stencil_Size |
              Attr_Red_Size | Attr_Green_Size | Attr_Blue_Size | Attr_Alpha_Size |
              Attr_Accum_Red_Size | Attr_Accum_Green_Size | Attr_Accum_Blue_Size | Attr_Accum_Alpha_Size =>
            Size : Natural := 0;
      end case;
   end record;

   type Context_Attributes is array (Positive range <>) of Context_Attribute;

   -- These are what we normally use, but other values are also possible
   Default_Context_Attributes : constant Context_Attributes :=
      (
       (Attr_Red_Size,    8),
       (Attr_Green_Size,  8),
       (Attr_Blue_Size,   8),
       (Attr_Alpha_Size,  8),
       (Attr_Depth_Size, 24)
      );

   -- Local exceptions raised by these procedures
   Connection_Failed : exception;  -- can't connect to X server
   Context_Failed    : exception;  -- can't create or attach OpenGL context
   Not_Available     : exception;  -- can't find a visual with given attributes

   -- Create a native window, with defaults for configuration intended to
   -- create a "usable" window.  Details about the parameters are:
   --
   -- Parent: Handle of an existing window that will act as the new window's
   -- parent, or No_Window, meaning an independent top-level window.
   --
   -- Width, Height: Window dimensions in pixels.
   --
   -- Events: Set of events this window wishes to receive.
   --
   -- Name: Name associated with new window, often displayed in the window's
   -- title bar.  If blank, the executable's filename is used.
   --
   -- Icon_Name: Name associated with the window's icon.  If blank, the
   -- executable's filename is used.
   --
   -- Class_Name, Instance_Name: Together these make up the window's "class".
   -- If blank, the class name is set to the executable's filename with
   -- initial capitalization; the instance name is set to the executable's
   -- filename.
   --
   -- Context: An existing GL rendering context to be used in the new window,
   -- or No_Context, meaning a new context is created for the window.
   --
   -- Depth: The color depth of the GL rendering context, either true-color or
   -- indexed/pseudo-color.
   --
   -- Animated: Whether the GL rendering context will be double-buffered, thus
   -- allowing smooth animation.
   --
   -- Attributes: The various GL context attributes which can be set.  The
   -- defaults work for most modern systems.
   procedure Create (Win           : in out Handle;
                     Parent        : in     Handle             := No_Window;
                     Width         : in     Natural            := 400;
                     Height        : in     Natural            := 400;
                     Events        : in     Wanted_Event_Set   := Want_No_Events;
                     Name          : in     String             := "";
                     Icon_Name     : in     String             := "";
                     Class_Name    : in     String             := "";
                     Instance_Name : in     String             := "";
                     Context       : in     Context_Handle     := No_Context;
                     Depth         : in     Color_Depth        := True_Color;
                     Direct        : in     Boolean            := True;
                     Animated      : in     Boolean            := True;
                     Attributes    : in     Context_Attributes := Default_Context_Attributes);

   -- Destroy a native window, including its current rendering context.
   procedure Destroy (Win : in out Handle);

   -- Set various textual names associated with a window.  Null string means
   -- leave the current value unchanged;
   procedure Set_Names (Win           : in Handle;
                        Name          : in String           := "";
                        Icon_Name     : in String           := "";
                        Class_Name    : in String           := "";
                        Instance_Name : in String           := "");

   -- Create an OpenGL rendering context; needed only when you want a second
   -- or subsequent context for a window, since Create makes one to start
   -- with
   function Create_Context (Win    : in Handle;
                            Direct : in Boolean := True)
   return Context_Handle;

   -- Destroy a window's OpenGL rendering context; should be followed either
   -- by a Make_Current or a Destroy_Window
   procedure Destroy_Context (Win : in out Handle);

   -- Make a rendering context the current one for a window
   procedure Make_Current (Win     : in out Handle;
                           Context : in     Context_Handle);

   -- Promotes the back buffer to front; only valid if the window is double
   -- buffered, meaning Animated was true when the window was created.  Useful
   -- for smooth animation.
   procedure Swap (Win : in Handle);

private

   pragma Linker_Options ("-lX11");
   pragma Linker_Options ("-lGL");

end Lumen.Window;

-- Lumen.Window -- Create and destroy native windows and associated OpenGL
-- rendering contexts
--
-- Chip Richards, NiEstu, Phoenix AZ, Spring 2010

-- This code is covered by the ISC License:
--
-- Copyright © 2010, NiEstu
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- The software is provided "as is" and the author disclaims all warranties
-- with regard to this software including all implied warranties of
-- merchantability and fitness. In no event shall the author be liable for any
-- special, direct, indirect, or consequential damages or any damages
-- whatsoever resulting from loss of use, data or profits, whether in an
-- action of contract, negligence or other tortious action, arising out of or
-- in connection with the use or performance of this software.

-- Environment
with Lumen.Internal;

package Lumen.Window is

   -- Handle for a Lumen window
   type Handle is access Internal.Window_Info;

   -- Handle for an OpenGL rendering context
   subtype Context_Handle is Internal.GLX_Context;

   -- Null window; in X, this means the root window is the parent
   No_Window : constant Handle := null;

   -- Means "no GL context"; for Create, means create a new one
   No_Context : constant Context_Handle := Internal.Null_Context;

   -- Types of events wanted, and a set listing them.
   type Wanted_Event is (Want_Key_Press, Want_Key_Release, Want_Button_Press,  Want_Button_Release,
                         Want_Window_Enter, Want_Window_Leave,
                         Want_Pointer_Move, Want_Pointer_Drag,
                         Want_Exposure, Want_Focus_Change);
   type Wanted_Event_Set is array (Wanted_Event) of Boolean;
   Want_No_Events  : Wanted_Event_Set := (others => False);
   Want_All_Events : Wanted_Event_Set := (others => True);

   -- Rendering context's color depth
   type Color_Depth is (Pseudo_Color, True_Color);

   -- OpenGL context ("visual") attribute specifiers
   type Context_Attribute_Name is
      (
       Attr_None,
       Attr_Use_GL,             -- unused
       Attr_Buffer_Size,        -- color index buffer size, ignored if TrueColor
       Attr_Level,              -- buffer level for over/underlays
       Attr_RGBA,               -- set by Depth => TrueColor
       Attr_Doublebuffer,       -- set by Animate => True
       Attr_Stereo,             -- wow, you have stereo visuals?
       Attr_Aux_Buffers,        -- number of auxiliary buffers
       Attr_Red_Size,           -- bit depth, red
       Attr_Green_Size,         -- bit depth, green
       Attr_Blue_Size,          -- bit depth, blue
       Attr_Alpha_Size,         -- bit depth, alpha
       Attr_Depth_Size,         -- depth buffer size
       Attr_Stencil_Size,       -- stencil buffer size
       Attr_Accum_Red_Size,     -- accumulation buffer bit depth, red
       Attr_Accum_Green_Size,   -- accumulation buffer bit depth, green
       Attr_Accum_Blue_Size,    -- accumulation buffer bit depth, blue
       Attr_Accum_Alpha_Size    -- accumulation buffer bit depth, alpha
      );

   type Context_Attribute (Name  : Context_Attribute_Name := Attr_None) is record
      case Name is
         when Attr_None | Attr_Use_GL | Attr_RGBA | Attr_Doublebuffer | Attr_Stereo =>
            null;  -- present or not, no value
         when Attr_Level =>
            Level : Integer := 0;
         when Attr_Buffer_Size | Attr_Aux_Buffers | Attr_Depth_Size | Attr_Stencil_Size |
              Attr_Red_Size | Attr_Green_Size | Attr_Blue_Size | Attr_Alpha_Size |
              Attr_Accum_Red_Size | Attr_Accum_Green_Size | Attr_Accum_Blue_Size | Attr_Accum_Alpha_Size =>
            Size : Natural := 0;
      end case;
   end record;

   type Context_Attributes is array (Positive range <>) of Context_Attribute;

   -- These are what we normally use, but other values are also possible
   Default_Context_Attributes : constant Context_Attributes :=
      (
       (Attr_Red_Size,    8),
       (Attr_Green_Size,  8),
       (Attr_Blue_Size,   8),
       (Attr_Alpha_Size,  8),
       (Attr_Depth_Size, 24)
      );

   -- Local exceptions raised by these procedures
   Connection_Failed : exception;  -- can't connect to X server
   Context_Failed    : exception;  -- can't create or attach OpenGL context
   Not_Available     : exception;  -- can't find a visual with given attributes

   -- Create a native window, with defaults for configuration intended to
   -- create a "usable" window.  Details about the parameters are:
   --
   -- Parent: Handle of an existing window that will act as the new window's
   -- parent, or No_Window, meaning an independent top-level window.
   --
   -- Width, Height: Window dimensions in pixels.
   --
   -- Events: Set of events this window wishes to receive.
   --
   -- Name: Name associated with new window, often displayed in the window's
   -- title bar.  If blank, the executable's filename is used.
   --
   -- Icon_Name: Name associated with the window's icon.  If blank, the
   -- executable's filename is used.
   --
   -- Class_Name, Instance_Name: Together these make up the window's "class".
   -- If blank, the class name is set to the executable's filename with
   -- initial capitalization; the instance name is set to the executable's
   -- filename.
   --
   -- Context: An existing GL rendering context to be used in the new window,
   -- or No_Context, meaning a new context is created for the window.
   --
   -- Depth: The color depth of the GL rendering context, either true-color or
   -- indexed/pseudo-color.
   --
   -- Animated: Whether the GL rendering context will be double-buffered, thus
   -- allowing smooth animation.
   --
   -- Attributes: The various GL context attributes which can be set.  The
   -- defaults work for most modern systems.
   procedure Create (Win           : in out Handle;
                     Parent        : in     Handle             := No_Window;
                     Width         : in     Natural            := 400;
                     Height        : in     Natural            := 400;
                     Events        : in     Wanted_Event_Set   := Want_No_Events;
                     Name          : in     String             := "";
                     Icon_Name     : in     String             := "";
                     Class_Name    : in     String             := "";
                     Instance_Name : in     String             := "";
                     Context       : in     Context_Handle     := No_Context;
                     Depth         : in     Color_Depth        := True_Color;
                     Direct        : in     Boolean            := True;
                     Animated      : in     Boolean            := True;
                     Attributes    : in     Context_Attributes := Default_Context_Attributes);

   -- Destroy a native window, including its current rendering context.
   procedure Destroy (Win : in out Handle);

   -- Set various textual names associated with a window.  Null string means
   -- leave the current value unchanged;
   procedure Set_Names (Win           : in Handle;
                        Name          : in String           := "";
                        Icon_Name     : in String           := "";
                        Class_Name    : in String           := "";
                        Instance_Name : in String           := "");

   -- Create an OpenGL rendering context; needed only when you want a second
   -- or subsequent context for a window, since Create makes one to start
   -- with
   function Create_Context (Win    : in Handle;
                            Direct : in Boolean := True)
   return Context_Handle;

   -- Destroy a window's OpenGL rendering context; should be followed either
   -- by a Make_Current or a Destroy_Window
   procedure Destroy_Context (Win : in out Handle);

   -- Make a rendering context the current one for a window
   procedure Make_Current (Win     : in out Handle;
                           Context : in     Context_Handle);

   -- Promotes the back buffer to front; only valid if the window is double
   -- buffered, meaning Animated was true when the window was created.  Useful
   -- for smooth animation.
   procedure Swap (Win : in Handle);

private

   pragma Linker_Options ("-lX11");
   pragma Linker_Options ("-lGL");

end Lumen.Window;

Clarify comment

Clarify comment


-----------------------------------------------------------------------
--  util-streams-aes -- AES encoding and decoding streams
--  Copyright (C) 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.Encoders.AES;
with Util.Streams.Buffered.Encoders;

--  == AES Encoding Streams ==
--  The `Util.Streams.AES` package define the `Encoding_Stream` and `Decoding_Stream` to
--  encrypt and descrypt using the AES cipher.
package Util.Streams.AES is

   package Encoding is
      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Encoder);

   package Decoding is
      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Decoder);

   type Encoding_Stream is new Encoding.Encoder_Stream with null record;

   --  Set the encryption key and mode to be used.
   procedure Set_Key (Stream : in out Encoding_Stream;
                      Data   : in Ada.Streams.Stream_Element_Array;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC);

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (Stream  : in out Encoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type);

   type Decoding_Stream is new Decoding.Encoder_Stream with null record;

   --  Set the encryption key and mode to be used.
   procedure Set_Key (Stream : in out Decoding_Stream;
                      Data   : in Ada.Streams.Stream_Element_Array;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC);

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (Stream  : in out Decoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type);

end Util.Streams.AES;

-----------------------------------------------------------------------
--  util-streams-aes -- AES encoding and decoding streams
--  Copyright (C) 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.Encoders.AES;
with Util.Streams.Buffered.Encoders;

--  == AES Encoding Streams ==
--  The `Util.Streams.AES` package define the `Encoding_Stream` and `Decoding_Stream` to
--  encrypt and descrypt using the AES cipher.
package Util.Streams.AES is

   package Encoding is
      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Encoder);

   package Decoding is
      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Decoder);

   type Encoding_Stream is new Encoding.Encoder_Stream with null record;

   --  Set the encryption key and mode to be used.
   procedure Set_Key (Stream : in out Encoding_Stream;
                      Secret : in Util.Encoders.Secret_Key;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC);

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (Stream  : in out Encoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type);

   type Decoding_Stream is new Decoding.Encoder_Stream with null record;

   --  Set the encryption key and mode to be used.
   procedure Set_Key (Stream : in out Decoding_Stream;
                      Secret : in Util.Encoders.Secret_Key;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC);

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (Stream  : in out Decoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type);

end Util.Streams.AES;

Use the Secret_Key type for the AES secret keys


-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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 MAT.Frames;
with Util.Events;
with MAT.Memory.Events;
with MAT.Readers;
with Ada.Containers.Ordered_Maps;
package MAT.Memory.Targets is

   type Target_Memory is record
      Reader        : MAT.Readers.Reader_Access;
      Memory_Slots  : Allocation_Map;
      Frames        : MAT.Frames.Frame_Ptr;
--        Event_Channel : MAT.Memory.Events.Memory_Event_Channel.Channel;
   end record;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   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 allocated by the application.
   procedure Size_Information (Memory : in Target_Memory;
                               Sizes  : in out Size_Info_Map);

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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 MAT.Frames;
with Util.Events;
with MAT.Memory.Events;
with MAT.Readers;
with Ada.Containers.Ordered_Maps;
package MAT.Memory.Targets is

   type Target_Memory is record
      Reader        : MAT.Readers.Reader_Access;
      Memory_Slots  : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type;
--        Event_Channel : MAT.Memory.Events.Memory_Event_Channel.Channel;
   end record;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   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 allocated by the application.
   procedure Size_Information (Memory : in Target_Memory;
                               Sizes  : in out Size_Info_Map);

end MAT.Memory.Targets;

Use Frame_Type type

Use Frame_Type type


-----------------------------------------------------------------------
--  asf-servlets-mappers -- Read servlet configuration files
--  Copyright (C) 2011, 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.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with Util.Beans.Objects.Vectors;

with EL.Contexts;

--  The ASF.Servlets.Mappers package defines an XML mapper that can be used
--  to read the servlet configuration files.
--
--  The servlet configuration used by ASF is a subset of the servlet deployment descriptor
--  defined in JSR 315 - Java Servlet Specification Version 3.0.  It includes:
--
--

--
Definition of filter mapping (filter-mapping tag)

--
Definition of servlet mapping (servlet-mapping tag)

--
Definition of context parameters (context-param tag)

--
Definition of mime types (mime-mapping tag)

--
Definition of error pages (error-page tag)

--

--
--  Other configurations are ignored by the mapper.
--
--  Note: several JSR 315 configuration parameters do not makes sense in the ASF world
--  because we cannot create a servlet or a filter through the configuration file.
package ASF.Servlets.Mappers is

   type Servlet_Fields is (FILTER_MAPPING, FILTER_NAME, SERVLET_NAME,
                           URL_PATTERN, SERVLET_MAPPING,
                           CONTEXT_PARAM, PARAM_NAME, PARAM_VALUE,
                           MIME_MAPPING, MIME_TYPE, EXTENSION,
                           ERROR_PAGE, ERROR_CODE, LOCATION);

   --  ------------------------------
   --  Servlet Config Reader
   --  ------------------------------
   --  When reading and parsing the servlet configuration file, the Servlet_Config object
   --  is populated by calls through the Set_Member procedure.  The data is
   --  collected and when the end of an element (FILTER_MAPPING, SERVLET_MAPPING, CONTEXT_PARAM)
   --  is reached, the definition is updated in the servlet registry.
   type Servlet_Config is limited record
      Filter_Name      : Util.Beans.Objects.Object;
      Servlet_Name     : Util.Beans.Objects.Object;
      URL_Patterns     : Util.Beans.Objects.Vectors.Vector;
      Param_Name       : Util.Beans.Objects.Object;
      Param_Value      : Util.Beans.Objects.Object;
      Mime_Type        : Util.Beans.Objects.Object;
      Extension        : Util.Beans.Objects.Object;
      Error_Code       : Util.Beans.Objects.Object;
      Location         : Util.Beans.Objects.Object;
      Handler          : Servlet_Registry_Access;
      Context          : EL.Contexts.ELContext_Access;
      Override_Context : Boolean := True;
   end record;
   type Servlet_Config_Access is access all Servlet_Config;

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

   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Handler : in Servlet_Registry_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Servlet_Config;
   end Reader_Config;

private

   package Servlet_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Servlet_Config,
                                               Element_Type_Access => Servlet_Config_Access,
                                               Fields              => Servlet_Fields,
                                               Set_Member          => Set_Member);

end ASF.Servlets.Mappers;

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

with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Beans.Objects.Vectors;

with EL.Contexts;

--  The ASF.Servlets.Mappers package defines an XML mapper that can be used
--  to read the servlet configuration files.
--
--  The servlet configuration used by ASF is a subset of the servlet deployment descriptor
--  defined in JSR 315 - Java Servlet Specification Version 3.0.  It includes:
--
--

--
Definition of filter mapping (filter-mapping tag)

--
Definition of servlet mapping (servlet-mapping tag)

--
Definition of context parameters (context-param tag)

--
Definition of mime types (mime-mapping tag)

--
Definition of error pages (error-page tag)

--

--
--  Other configurations are ignored by the mapper.
--
--  Note: several JSR 315 configuration parameters do not makes sense in the ASF world
--  because we cannot create a servlet or a filter through the configuration file.
package ASF.Servlets.Mappers is

   type Servlet_Fields is (FILTER_MAPPING, FILTER_NAME, SERVLET_NAME,
                           URL_PATTERN, SERVLET_MAPPING,
                           CONTEXT_PARAM, PARAM_NAME, PARAM_VALUE,
                           MIME_MAPPING, MIME_TYPE, EXTENSION,
                           ERROR_PAGE, ERROR_CODE, LOCATION);

   --  ------------------------------
   --  Servlet Config Reader
   --  ------------------------------
   --  When reading and parsing the servlet configuration file, the Servlet_Config object
   --  is populated by calls through the Set_Member procedure.  The data is
   --  collected and when the end of an element (FILTER_MAPPING, SERVLET_MAPPING, CONTEXT_PARAM)
   --  is reached, the definition is updated in the servlet registry.
   type Servlet_Config is limited record
      Filter_Name      : Util.Beans.Objects.Object;
      Servlet_Name     : Util.Beans.Objects.Object;
      URL_Patterns     : Util.Beans.Objects.Vectors.Vector;
      Param_Name       : Util.Beans.Objects.Object;
      Param_Value      : Util.Beans.Objects.Object;
      Mime_Type        : Util.Beans.Objects.Object;
      Extension        : Util.Beans.Objects.Object;
      Error_Code       : Util.Beans.Objects.Object;
      Location         : Util.Beans.Objects.Object;
      Handler          : Servlet_Registry_Access;
      Context          : EL.Contexts.ELContext_Access;
      Override_Context : Boolean := True;
   end record;
   type Servlet_Config_Access is access all Servlet_Config;

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

   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   generic
      Mapper  : in out Util.Serialize.Mappers.Processing;
      Handler : in Servlet_Registry_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Servlet_Config;
   end Reader_Config;

private

   package Servlet_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Servlet_Config,
                                               Element_Type_Access => Servlet_Config_Access,
                                               Fields              => Servlet_Fields,
                                               Set_Member          => Set_Member);

end ASF.Servlets.Mappers;

Update the Reader_Config to use the new parser/mapper interface


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.
-----------------------------------------------------------------------

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.
-----------------------------------------------------------------------

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

end Security.Permissions;

Document the permission

Document the permission