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

with Util.Tests;
with Util.Log.Loggers;

with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                     Name   => AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

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

with Util.Tests;
with Util.Log.Loggers;

with ASF.Principals;
with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                     Name   => AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Signup_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.SIGNUP_KEY);
      Password_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.RESET_PASSWORD_KEY);
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ? AND o.kind = ?");
      Query.Bind_Param (1, Email);
      Query.Bind_Param (2, Signup_Kind);
      Key.Find (DB, Query, Found);
      if not Found then
         Query.Bind_Param (2, Password_Kind);
         Key.Find (DB, Query, Found);
         if not Found then
            Log.Error ("Cannot find access key for email {0}", Email);
         end if;
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   --  ------------------------------
   --  Simulate the recovery password process for the given user.
   --  ------------------------------
   procedure Recover_Password (Email : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
         Log.Error ("Invalid redirect after lost password");
      end if;

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         if not Key.Is_Null then
            Log.Error ("There is no access key associated with the user");
         end if;

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "admin");
         Request.Set_Parameter ("reset-password", "1");
         ASF.Tests.Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
            Log.Error ("Invalid response");
         end if;

         --  Check that the user is logged and we have a user principal now.
         if Request.Get_User_Principal = null then
            Log.Error ("A user principal should be defined");
         end if;
      end;
   end Recover_Password;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

Implement the Recover_Password procedure to simulate a password recovery and reset the password for the user to the test password 'admin' Update Find_Access_Key to find the access key according to a SIGNUP_KEY or a RESET_PASSWORD_KEY type


-----------------------------------------------------------------------
--  el -- Evaluate an EL expression
--  Copyright (C) 2009, 2010 Free Software Foundation, Inc.
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  This file is part of ASF.
--
--  This program is free software; you can redistribute it and/or
--  modify it under the terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2,
--  or (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, 59 Temple Place - Suite 330,
--  Boston, MA 02111-1307, USA.
-----------------------------------------------------------------------
with EL.Expressions;
with EL.Objects;
with EL.Contexts.Default;
with EL.Beans;
with Ada.Text_IO;
with Bean;
procedure Variables is

   use Bean;

   Joe    : Person_Access := Create_Person ("Joe", "Smith", 12);
   Bill   : Person_Access := Create_Person ("Bill", "Johnson", 42);
   Ctx    : EL.Contexts.Default.Default_Context;
   E      : EL.Expressions.Expression;
   Result : EL.Objects.Object;

begin
   E := EL.Expressions.Create_Expression ("#{user.firstName} #{user.lastName}", Ctx);

   --  Bind the context to 'Joe' and evaluate
   Ctx.Set_Variable ("user", Joe);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("Joe's name is " & EL.Objects.To_String (Result));

   --  Bind the context to 'Bill' and evaluate
   Ctx.Set_Variable ("user", Bill);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("Bill's name is " & EL.Objects.To_String (Result));

   Free (Joe);
   Free (Bill);
end Variables;

-----------------------------------------------------------------------
--  el -- Evaluate an EL expression
--  Copyright (C) 2009, 2010 Free Software Foundation, Inc.
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  This file is part of ASF.
--
--  This program is free software; you can redistribute it and/or
--  modify it under the terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2,
--  or (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, 59 Temple Place - Suite 330,
--  Boston, MA 02111-1307, USA.
-----------------------------------------------------------------------
with EL.Expressions;
with EL.Objects;
with EL.Contexts.Default;
with Ada.Text_IO;
with Bean;
procedure Variables is

   use Bean;

   Joe    : Person_Access := Create_Person ("Joe", "Smith", 12);
   Bill   : Person_Access := Create_Person ("Bill", "Johnson", 42);
   Ctx    : EL.Contexts.Default.Default_Context;
   E      : EL.Expressions.Expression;
   VE     : EL.Expressions.Value_Expression;
   Result : EL.Objects.Object;

begin
   E := EL.Expressions.Create_Expression ("#{user.firstName} #{user.lastName}", Ctx);

   --  Bind the context to 'Joe' and evaluate
   Ctx.Set_Variable ("user", Joe);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("User name is " & EL.Objects.To_String (Result));

   --  Bind the context to 'Bill' and evaluate
   Ctx.Set_Variable ("user", Bill);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("User name is " & EL.Objects.To_String (Result));

   --  Create a value expression to change the user firstName property.
   VE := EL.Expressions.Create_Expression ("#{user.firstName}", Ctx);

   --  Change the user first name by setting the value expression.
   VE.Set_Value (Context => Ctx, Value => EL.Objects.To_Object (String '("Harold")));

   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("User name is " & EL.Objects.To_String (Result));

   Free (Joe);
   Free (Bill);
end Variables;

Add an example of Value_Expression and call to Set_Value


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

with Util.Tests;

package ASF.Requests.Tests is

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

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

   --  Test the Split_Header procedure.
   procedure Test_Split_Header (T : in out Test);

   --  Test the Accept_Locales procedure.
   procedure Test_Accept_Locales (T : in out Test);

end ASF.Requests.Tests;

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

with Util.Tests;

package ASF.Requests.Tests is

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

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

   --  Test the Split_Header procedure.
   procedure Test_Split_Header (T : in out Test);

   --  Test the Accept_Locales procedure.
   procedure Test_Accept_Locales (T : in out Test);

   --  Test the Set_Attribute procedure.
   procedure Test_Set_Attribute (T : in out Test);

end ASF.Requests.Tests;

Declare the Test_Set_Attribute procedure to check the Set/Get/Remove attribute


-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 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 ADO.Statements;
with ADO.Statements.Create;
with Ada.Strings.Fixed;
with Util.Strings.Transforms;
package body ADO.Schemas.Sqlite is

   use ADO.Statements;

   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;

   function String_To_Type (Value : in String) return Column_Type is
      Pos : Natural;
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "datetime" then
         return T_DATE_TIME;
      elsif Value = "int" or Value = "integer" then
         return T_INTEGER;
      elsif Value = "bigint" then
         return T_LONG_INTEGER;
      elsif Value = "tinyint" then
         return T_TINYINT;
      elsif Value = "smallint" then
         return T_SMALLINT;
      elsif Value = "blob" then
         return T_BLOB;
      end if;
      Pos := Ada.Strings.Fixed.Index (Value, "(");
      if Pos > 0 then
         declare
            Name : constant String := Value (Value'First .. Pos - 1);
         begin
            if Name = "varchar" then
               return T_VARCHAR;
            elsif Name = "real" or Name = "float" or Name = "double" then
               return T_FLOAT;
            elsif Name = "int" then
               return T_INTEGER;
            elsif Name = "bigint" then
               return T_LONG_INTEGER;
            else
               return T_UNKNOWN;
            end if;
         end;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition) is
      Name : constant String := Get_Name (Table);
      Stmt : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("pragma table_info('" & Name & "')"));
      Last : Column_Definition := null;
      Col  : Column_Definition;
      Value : Unbounded_String;
   begin
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (1);
         Col.Collation := Stmt.Get_Unbounded_String (2);
         Col.Default   := Stmt.Get_Unbounded_String (5);
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (2);
         Col.Col_Type
           := String_To_Type (Util.Strings.Transforms.To_Lower_Case (To_String (Value)));

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "0";

         Value := Stmt.Get_Unbounded_String (5);
         Col.Is_Primary := Value = "1";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C      : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema : out Schema_Definition) is
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("SELECT NAME FROM sqlite_master"));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Sqlite;

-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 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 ADO.Statements;
with ADO.Statements.Create;
with Ada.Strings.Fixed;
with Util.Strings.Transforms;
package body ADO.Schemas.Sqlite is

   use ADO.Statements;

   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;
   function String_To_Length (Value : in String) return Natural;

   function String_To_Type (Value : in String) return Column_Type is
      Pos : Natural;
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "datetime" then
         return T_DATE_TIME;
      elsif Value = "int" or Value = "integer" then
         return T_INTEGER;
      elsif Value = "bigint" then
         return T_LONG_INTEGER;
      elsif Value = "tinyint" then
         return T_TINYINT;
      elsif Value = "smallint" then
         return T_SMALLINT;
      elsif Value = "blob" then
         return T_BLOB;
      end if;
      Pos := Ada.Strings.Fixed.Index (Value, "(");
      if Pos > 0 then
         declare
            Name : constant String := Value (Value'First .. Pos - 1);
         begin
            if Name = "varchar" then
               return T_VARCHAR;
            elsif Name = "real" or Name = "float" or Name = "double" then
               return T_FLOAT;
            elsif Name = "int" then
               return T_INTEGER;
            elsif Name = "bigint" then
               return T_LONG_INTEGER;
            else
               return T_UNKNOWN;
            end if;
         end;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   function String_To_Length (Value : in String) return Natural is
      First : Natural;
      Last  : Natural;
   begin
      First := Ada.Strings.Fixed.Index (Value, "(");
      if First < 0 then
         return 0;
      end if;
      Last := Ada.Strings.Fixed.Index (Value , ")");
      if Last < First then
         return 0;
      end if;
      return Natural'Value (Value (First + 1 .. Last - 1));

   exception
      when Constraint_Error =>
         return 0;
   end String_To_Length;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition) is
      Name : constant String := Get_Name (Table);
      Stmt : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("pragma table_info('" & Name & "')"));
      Last : Column_Definition := null;
      Col  : Column_Definition;
      Value : Unbounded_String;
   begin
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (1);
         Col.Collation := Stmt.Get_Unbounded_String (2);
         Col.Default   := Stmt.Get_Unbounded_String (5);
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (2);
         declare
            Type_Name : constant String
              := Util.Strings.Transforms.To_Lower_Case (To_String (Value));
         begin
            Col.Col_Type := String_To_Type (Type_Name);
            Col.Size := String_To_Length (Type_Name);
         end;

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "0";

         Value := Stmt.Get_Unbounded_String (5);
         Col.Is_Primary := Value = "1";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C      : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema : out Schema_Definition) is
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("SELECT NAME FROM sqlite_master"));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Sqlite;

Declare and implement String_To_Length and use it to get the column size


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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.

package Orka.Integrators is
   pragma Pure;

   generic
      type Value      is private;
      type Derivative is private;

      type Duration_Type is digits <>;

      with function "*" (Left : Duration_Type; Right : Derivative) return Derivative is <>;
      with function "+" (Left : Value;         Right : Derivative) return Value      is <>;
      with function "+" (Left : Derivative;    Right : Derivative) return Derivative is <>;
   function RK4
     (Y  : Value;
      DT : Duration_Type;
      F  : not null access function (Y : Value; DT : Duration_Type) return Derivative)
   return Derivative;
   --  Return the change to Y for the given DT time step using
   --  the Runge-Kutta 4th order method
   --
   --  If F represent a time-variant system, that is, F depends on a time T,
   --  then you must compute the derivative at time T + DT. In this case you
   --  must keep track of T yourself and add it to the given DT.
   --
   --  The returned value must be added to Y to perform the numerical integration.
   --
   --  For example, to numerically integrate a position 10 times per second:
   --
   --     X := X + RK4 (X, 0.1, DX'Access);

end Orka.Integrators;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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.

package Orka.Integrators is
   pragma Preelaborate;

   generic
      type Value      is private;
      type Derivative is private;

      type Duration_Type is digits <>;

      with function "*" (Left : Duration_Type; Right : Derivative) return Derivative is <>;
      with function "+" (Left : Value;         Right : Derivative) return Value      is <>;
      with function "+" (Left : Derivative;    Right : Derivative) return Derivative is <>;
   function RK4
     (Y  : Value;
      DT : Duration_Type;
      F  : not null access function (Y : Value; DT : Duration_Type) return Derivative)
   return Derivative;
   --  Return the change to Y for the given DT time step using
   --  the Runge-Kutta 4th order method
   --
   --  If F represent a time-variant system, that is, F depends on a time T,
   --  then you must compute the derivative at time T + DT. In this case you
   --  must keep track of T yourself and add it to the given DT.
   --
   --  The returned value must be added to Y to perform the numerical integration.
   --
   --  For example, to numerically integrate a position 10 times per second:
   --
   --     X := X + RK4 (X, 0.1, DX'Access);

end Orka.Integrators;

numerics: Make package Orka.Integrators Preelaborate instead of Pure

It might happen that the compiler caches results if the package is Pure,
even when the function F returns different values when it represents a
time-variant system.

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  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.Types;
with MAT.Memory;
package body MAT.Expressions is

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node    : in Node_Type;
                         Context : in Context_Type) return Boolean is
      use type MAT.Types.Target_Size;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Context);

         when N_AND =>
            return Is_Selected (Node.Left.all, Context)
              and then Is_Selected (Node.Right.all, Context);

         when N_OR =>
            return Is_Selected (Node.Left.all, Context)
              or else Is_Selected (Node.Right.all, Context);

         when N_RANGE_SIZE =>
            return Context.Allocation.Size >= Node.Min_Size
              and Context.Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Context.Addr >= Node.Min_Addr
              and Context.Addr <= Node.Max_Addr;

         when others =>
            return False;

      end case;
      end Is_Selected;

end MAT.Expressions;

-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  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.Types;
with MAT.Memory;
package body MAT.Expressions is

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node    : in Expression_Type;
                         Context : in Context_Type) return Boolean is
   begin
      if Node.Node = null then
         return False;
      else
         return Is_Selected (Node.Node.all, Context);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node    : in Node_Type;
                         Context : in Context_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Context);

         when N_AND =>
            return Is_Selected (Node.Left.all, Context)
              and then Is_Selected (Node.Right.all, Context);

         when N_OR =>
            return Is_Selected (Node.Left.all, Context)
              or else Is_Selected (Node.Right.all, Context);

         when N_RANGE_SIZE =>
            return Context.Allocation.Size >= Node.Min_Size
              and Context.Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Context.Addr >= Node.Min_Addr
              and Context.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Context.Allocation.Time >= Node.Min_Time
              and Context.Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

end MAT.Expressions;

Implement the Is_Selected operation on Expression_Type


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

with EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is private;
   type Return_Type (<>) is private;
package EL.Methods.Func_1 is

   use Util.Beans.Methods;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   function F (Obj : <Bean>; Param : Param1_Type) return Return_Type;
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   function Execute (Method  : in EL.Expressions.Method_Expression'Class;
                     Param   : in Param1_Type;
                     Context : in EL.Contexts.ELContext'Class) return Return_Type;

   --  Function access to the proxy.
   type Proxy_Access is
     access function (O : in Util.Beans.Basic.Readonly_Bean'Class;
                      P : in Param1_Type) return Return_Type;

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with function Method (O  : in Bean;
                            P1 : in Param1_Type) return Return_Type;
   package Bind is

      --  Method that Execute will invoke.
      function Method_Access (O  : in Util.Beans.Basic.Readonly_Bean'Class;
                              P1 : in Param1_Type) return Return_Type;

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Func_1;

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

with EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
   type Return_Type (<>) is private;
package EL.Methods.Func_1 is

   use Util.Beans.Methods;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   function F (Obj : <Bean>; Param : Param1_Type) return Return_Type;
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   function Execute (Method  : in EL.Expressions.Method_Expression'Class;
                     Param   : in Param1_Type;
                     Context : in EL.Contexts.ELContext'Class) return Return_Type;

   --  Function access to the proxy.
   type Proxy_Access is
     access function (O : in Util.Beans.Basic.Readonly_Bean'Class;
                      P : in Param1_Type) return Return_Type;

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with function Method (O  : in Bean;
                            P1 : in Param1_Type) return Return_Type;
   package Bind is

      --  Method that Execute will invoke.
      function Method_Access (O  : in Util.Beans.Basic.Readonly_Bean'Class;
                              P1 : in Param1_Type) return Return_Type;

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Func_1;

Change the function parameter to a limited parameter allowing to pass limited types


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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   function Get_Last_Error return Integer;
   pragma Import (Stdcall, Get_Last_Error, "GetLastError");

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD;
   pragma Import (Stdcall, Wait_For_Single_Object, "WaitForSingleObject");

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Boolean;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := -10;
   STD_OUTPUT_HANDLE : constant DWORD := -11;
   STD_ERROR_HANDLE  : constant DWORD := -12;

   function Get_Std_Handle (Kind : in DWORD) return File_Type;
   pragma Import (Stdcall, Get_Std_Handle, "GetStdHandle");

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL;
   pragma Import (Stdcall, Close_Handle, "CloseHandle");

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL;
   pragma Import  (Stdcall, Duplicate_Handle, "DuplicateHandle");

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL;
   pragma Import (Stdcall, Read_File, "ReadFile");

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL;
   pragma Import (Stdcall, Write_File, "WriteFile");

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL;
   pragma Import (Stdcall, Create_Pipe, "CreatePipe");

--     type Size_T is mod 2 ** Standard'Address_Size;

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
--   pragma Pack (Startup_Info);
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE;
   pragma Import (Stdcall, Get_Current_Process, "GetCurrentProcess");

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL;
   pragma Import (Stdcall, Get_Exit_Code_Process, "GetExitCodeProcess");

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handlers   : in Boolean;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access) return Integer;
   pragma Import (Stdcall, Create_Process, "CreateProcessW");

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer;
   pragma Import (Stdcall, Terminate_Process, "TerminateProcess");

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Stat, "_stat64");

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Fstat, "_fstat64");

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE;
   pragma Import (Stdcall, Create_File, "CreateFileW");

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   function Get_Last_Error return Integer;
   pragma Import (Stdcall, Get_Last_Error, "GetLastError");

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD;
   pragma Import (Stdcall, Wait_For_Single_Object, "WaitForSingleObject");

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Boolean;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := -10;
   STD_OUTPUT_HANDLE : constant DWORD := -11;
   STD_ERROR_HANDLE  : constant DWORD := -12;

   function Get_Std_Handle (Kind : in DWORD) return File_Type;
   pragma Import (Stdcall, Get_Std_Handle, "GetStdHandle");

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL;
   pragma Import (Stdcall, Close_Handle, "CloseHandle");

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL;
   pragma Import  (Stdcall, Duplicate_Handle, "DuplicateHandle");

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL;
   pragma Import (Stdcall, Read_File, "ReadFile");

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL;
   pragma Import (Stdcall, Write_File, "WriteFile");

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL;
   pragma Import (Stdcall, Create_Pipe, "CreatePipe");

--     type Size_T is mod 2 ** Standard'Address_Size;

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
--   pragma Pack (Startup_Info);
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE;
   pragma Import (Stdcall, Get_Current_Process, "GetCurrentProcess");

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL;
   pragma Import (Stdcall, Get_Exit_Code_Process, "GetExitCodeProcess");

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handlers   : in Boolean;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access) return Integer;
   pragma Import (Stdcall, Create_Process, "CreateProcessW");

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer;
   pragma Import (Stdcall, Terminate_Process, "TerminateProcess");

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Stat, "_stat64");

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Fstat, "_fstat64");

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t
     with Import => True, Convention => C, Link_Name => "_lseek";

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE;
   pragma Import (Stdcall, Create_File, "CreateFileW");

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

Declare the Sys_Lseek procedure

Declare the Sys_Lseek procedure


-----------------------------------------------------------------------
--  mat-readers-marshaller -- Marshalling of data in communication buffer
--  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 Interfaces;
with System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
package body MAT.Readers.Marshaller is

   use type System.Storage_Elements.Storage_Offset;
   use type Interfaces.Unsigned_32;
   use type Interfaces.Unsigned_64;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + System.Storage_Elements.Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   --  ------------------------------
   --  Get a 16-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;
      use type Interfaces.Unsigned_16;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + System.Storage_Elements.Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + System.Storage_Elements.Storage_Offset (1));
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + System.Storage_Elements.Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   --  ------------------------------
   --  Get a 32-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   --  ------------------------------
   --  Get a 64-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Low : MAT.Types.Uint32;
      High : MAT.Types.Uint32;
   begin
      if Buffer.Endian = LITTLE_ENDIAN then
         Low := Get_Uint32 (Buffer);
         High := Get_Uint32 (Buffer);
      else
         High := Get_Uint32 (Buffer);
         Low  := Get_Uint32 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint64 (High), 32) + MAT.Types.Uint64 (Low);
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Message_Type;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg.Buffer));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg.Buffer));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg.Buffer));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg.Buffer));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Message_Type) return String is
      Len    : constant MAT.Types.Uint16 := Get_Uint16 (Buffer.Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer.Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Message_Type) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Message_Type;
                   Size   : in Natural) is
   begin
      Buffer.Buffer.Size := Buffer.Buffer.Size - Size;
      Buffer.Buffer.Current := Buffer.Buffer.Current + System.Storage_Elements.Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Message_Type;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Uint32);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

   function Get_Target_Process_Ref (Msg  : in Message_Type;
                                    Kind : in MAT.Events.Attribute_Type)
                                    return MAT.Types.Target_Process_Ref is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Process_Ref);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Process_Ref;

end MAT.Readers.Marshaller;

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

   use type System.Storage_Elements.Storage_Offset;
   use type Interfaces.Unsigned_32;
   use type Interfaces.Unsigned_64;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + System.Storage_Elements.Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   --  ------------------------------
   --  Get a 16-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;
      use type Interfaces.Unsigned_16;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + System.Storage_Elements.Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + System.Storage_Elements.Storage_Offset (1));
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + System.Storage_Elements.Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   --  ------------------------------
   --  Get a 32-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   --  ------------------------------
   --  Get a 64-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Low : MAT.Types.Uint32;
      High : MAT.Types.Uint32;
   begin
      if Buffer.Endian = LITTLE_ENDIAN then
         Low := Get_Uint32 (Buffer);
         High := Get_Uint32 (Buffer);
      else
         High := Get_Uint32 (Buffer);
         Low  := Get_Uint32 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint64 (High), 32) + MAT.Types.Uint64 (Low);
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Message_Type;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg.Buffer));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg.Buffer));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg.Buffer));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg.Buffer));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Message_Type) return String is
      Len    : constant MAT.Types.Uint16 := Get_Uint16 (Buffer.Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer.Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Message_Type) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Message_Type;
                   Size   : in Natural) is
      use System.Storage_Elements;
   begin
      Buffer.Buffer.Size := Buffer.Buffer.Size - Size;
      Buffer.Buffer.Current := Buffer.Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Message_Type;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Uint32);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

   function Get_Target_Process_Ref (Msg  : in Message_Type;
                                    Kind : in MAT.Events.Attribute_Type)
                                    return MAT.Types.Target_Process_Ref is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Process_Ref);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Process_Ref;

end MAT.Readers.Marshaller;

Fix compilation warning with GNAT 2018

Fix compilation warning with GNAT 2018