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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
with Security.Permissions.Tests;
package body Security.Policies.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy (empty)",
                       Test_Read_Empty_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Add_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Get_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Get_Role_Policy",
                       Test_Get_Role_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the roles assigned to the user.
   --  ------------------------------
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map is
   begin
      return User.Roles;
   end Get_Roles;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
--        Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   procedure Configure_Policy (Manager : in out Security.Policies.Policy_Manager;
                               Name    : in String) is
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      R           : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Manager.Add_Policy (R.all'Access);
      Manager.Add_Policy (U.all'Access);
      Manager.Read_Policy (Util.Files.Compose (Path, Name));
   end Configure_Policy;

   --  ------------------------------
   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   --  ------------------------------
   procedure Test_Get_Role_Policy (T : in out Test) is
      use type Roles.Role_Policy_Access;

      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P = null, "Get_Policy succeeded");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R = null, "Get_Role_Policy succeeded");

      R := new Roles.Role_Policy;
      M.Add_Policy (R.all'Access);

      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P /= null, "Role policy not found");
      T.Assert (P.all in Roles.Role_Policy'Class, "Invalid role policy");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R /= null, "Get_Role_Policy should not return null");
   end Test_Get_Role_Policy;

   --  ------------------------------
   --  Test reading an empty policy file
   --  ------------------------------
   procedure Test_Read_Empty_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User        : aliased Test_Principal;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      Configure_Policy (M, "empty.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      declare
         Admin : Policies.Roles.Role_Type;
      begin
         Admin := R.Find_Role ("admin");
         T.Fail ("'admin' role was returned");

      exception
         when Security.Policies.Roles.Invalid_Name =>
            null;
      end;

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Admin.Permission),
                "Has_Permission (admin) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Create.Permission),
                "Has_Permission (create) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Update.Permission),
                "Has_Permission (update) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Delete.Permission),
                "Has_Permission (delete) failed for empty policy");

   end Test_Read_Empty_Policy;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      use Security.Permissions.Tests;

      M            : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User         : aliased Test_Principal;
      Admin        : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      Configure_Policy (M, "simple-policy.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin := R.Find_Role ("admin");

      T.Assert (not Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was granted but user has no role");

      User.Roles (Admin) := True;

      T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was not granted and user has admin role");

      declare

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
      end;
      declare
         use Security.Permissions.Tests;

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/list.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
      end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Configure_Policy (M, File);

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin_Perm := R.Find_Role (Role);

      declare
         P   : constant URLs.URI_Permission (URI'Length)
           := URLs.URI_Permission '(Len => URI'Length, URI => URI);
      begin
         --  A user without the role should not have the permission.
         T.Assert (not U.Has_Permission (Context    => Context'Unchecked_Access,
                                         Permission => P),
           "Permission was granted for user without role.  URI=" & URI);

         --  Set the role.
         User.Roles (Admin_Perm) := True;
         T.Assert (U.Has_Permission (Context    => Context'Unchecked_Access,
                                     Permission => P),
           "Permission was not granted for user with role.  URI=" & URI);
      end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
with Security.Permissions.Tests;
package body Security.Policies.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy (empty)",
                       Test_Read_Empty_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Add_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Get_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Get_Role_Policy",
                       Test_Get_Role_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the roles assigned to the user.
   --  ------------------------------
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map is
   begin
      return User.Roles;
   end Get_Roles;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
--        Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   procedure Configure_Policy (Manager : in out Security.Policies.Policy_Manager;
                               Name    : in String) is
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      R           : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Manager.Add_Policy (R.all'Access);
      Manager.Add_Policy (U.all'Access);
      Manager.Read_Policy (Util.Files.Compose (Path, Name));
   end Configure_Policy;

   --  ------------------------------
   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   --  ------------------------------
   procedure Test_Get_Role_Policy (T : in out Test) is
      use type Roles.Role_Policy_Access;

      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P = null, "Get_Policy succeeded");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R = null, "Get_Role_Policy succeeded");

      R := new Roles.Role_Policy;
      M.Add_Policy (R.all'Access);

      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P /= null, "Role policy not found");
      T.Assert (P.all in Roles.Role_Policy'Class, "Invalid role policy");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R /= null, "Get_Role_Policy should not return null");
   end Test_Get_Role_Policy;

   --  ------------------------------
   --  Test reading an empty policy file
   --  ------------------------------
   procedure Test_Read_Empty_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User        : aliased Test_Principal;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      Configure_Policy (M, "empty.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      declare
         Admin : Policies.Roles.Role_Type;
      begin
         Admin := R.Find_Role ("admin");
         T.Fail ("'admin' role was returned");

      exception
         when Security.Policies.Roles.Invalid_Name =>
            null;
      end;

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Admin.Permission),
                "Has_Permission (admin) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Create.Permission),
                "Has_Permission (create) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Update.Permission),
                "Has_Permission (update) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Delete.Permission),
                "Has_Permission (delete) failed for empty policy");

   end Test_Read_Empty_Policy;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      use Security.Permissions.Tests;

      M            : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User         : aliased Test_Principal;
      Admin        : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      Configure_Policy (M, "simple-policy.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin := R.Find_Role ("admin");

      T.Assert (not Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was granted but user has no role");

      User.Roles (Admin) := True;

      T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was not granted and user has admin role");

      declare

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
      end;
      declare
         use Security.Permissions.Tests;

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/list.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
      end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin       : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Configure_Policy (M, File);

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin := R.Find_Role (Role);

      declare
         P   : constant URLs.URI_Permission (URI'Length)
           := URLs.URI_Permission '(Len => URI'Length, URI => URI);
      begin
         --  A user without the role should not have the permission.
         T.Assert (not U.Has_Permission (Context    => Context'Unchecked_Access,
                                         Permission => P),
           "Permission was granted for user without role.  URI=" & URI);

         --  Set the role.
         User.Roles (Admin) := True;
         T.Assert (U.Has_Permission (Context    => Context'Unchecked_Access,
                                     Permission => P),
           "Permission was not granted for user with role.  URI=" & URI);
      end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

Rename the role Admin_Perm into Admin

Rename the role Admin_Perm into Admin


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

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;
      use Ada.Calendar.Formatting;

      Result : Date_Record;
      Pos    : Natural;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Hour       := 0;
      Result.Minute     := 0;
      Result.Second     := 0;
      Result.Sub_Second := 0.0;
      Result.Time_Zone  := 0;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

         --  ISO8601 date: YYYY-MM-DDTHH
         if Date'Length > 12 then
            if Date (Date'First + 10) /= 'T' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Hour := Hour_Number'Value (Date (Date'First + 11 .. Date'First + 12));
            Pos := Date'First + 13;
         end if;
         if Date'Length > 15 then
            if Date (Date'First + 13) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Minute := Minute_Number'Value (Date (Date'First + 14 .. Date'First + 15));
            Pos := Date'First + 16;
         end if;
         if Date'Length > 18 then
            if Date (Date'First + 16) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Second := Second_Number'Value (Date (Date'First + 17 .. Date'First + 18));
            Pos := Date'First + 19;
         end if;

         --  ISO8601 timezone: +hh:mm or -hh:mm
--           if Date'Length > Pos + 4 then
--              if Date (Pos) /= '+' and Date (Pos) /= '-' and Date (Pos + 2) /= ':' then
--                 raise Constraint_Error with "invalid date";
--              end if;
--           end if;
      else
         raise Constraint_Error with "invalid date";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Result.Year,
                                              Month       => Result.Month,
                                              Day         => Result.Month_Day,
                                              Hour        => Result.Hour,
                                              Minute      => Result.Minute,
                                              Second      => Result.Second,
                                              Sub_Second  => Result.Sub_Second,
                                              Time_Zone   => Result.Time_Zone);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D, Precision);
   end Image;

   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String is
      use type Ada.Calendar.Time_Zones.Time_Offset;

      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 29) := "0000-00-00T00:00:00.000-00:00";
      N,  Tz  : Natural;
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      if Precision = YEAR then
         return Result (1 .. 4);
      end if;
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      if Precision = MONTH then
         return Result (1 .. 7);
      end if;
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      if Precision = DAY then
         return Result (1 .. 10);
      end if;
      Result (12) := To_Char (Date.Hour / 10);
      Result (13) := To_Char (Date.Hour mod 10);
      if Precision = HOUR then
         return Result (1 .. 13);
      end if;
      Result (15) := To_Char (Date.Minute / 10);
      Result (16) := To_Char (Date.Minute mod 10);
      if Precision = MINUTE then
         return Result (1 .. 16);
      end if;
      Result (18) := To_Char (Date.Second / 10);
      Result (19) := To_Char (Date.Second mod 10);
      if Precision = SECOND then
         return Result (1 .. 19);
      end if;
      N := Natural (Date.Sub_Second * 1000.0);
      Result (21) := To_Char (N / 100);
      Result (22) := To_Char ((N mod 100) / 10);
      Result (23) := To_Char (N mod 10);
      if Date.Time_Zone < 0 then
         Tz := Natural (-Date.Time_Zone);
      else
         Result (24) := '+';
         Tz := Natural (Date.Time_Zone);
      end if;
      Result (25) := To_Char (Tz / 600);
      Result (26) := To_Char ((Tz / 60) mod 10);
      Tz := Tz mod 60;
      Result (28) := To_Char (Tz / 10);
      Result (29) := To_Char (Tz mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

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

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;
      use Ada.Calendar.Formatting;

      Result : Date_Record;
      Pos    : Natural;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Hour       := 0;
      Result.Minute     := 0;
      Result.Second     := 0;
      Result.Sub_Second := 0.0;
      Result.Time_Zone  := 0;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

         --  ISO8601 date: YYYY-MM-DDTHH
         if Date'Length > 12 then
            if Date (Date'First + 10) /= 'T' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Hour := Hour_Number'Value (Date (Date'First + 11 .. Date'First + 12));
            Pos := Date'First + 13;
         end if;
         if Date'Length > 15 then
            if Date (Date'First + 13) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Minute := Minute_Number'Value (Date (Date'First + 14 .. Date'First + 15));
            Pos := Date'First + 16;
         end if;
         if Date'Length > 18 then
            if Date (Date'First + 16) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Second := Second_Number'Value (Date (Date'First + 17 .. Date'First + 18));
            Pos := Date'First + 19;
         end if;

         --  ISO8601 timezone: +hh:mm or -hh:mm
--           if Date'Length > Pos + 4 then
--              if Date (Pos) /= '+' and Date (Pos) /= '-' and Date (Pos + 2) /= ':' then
--                 raise Constraint_Error with "invalid date";
--              end if;
--           end if;
      else
         raise Constraint_Error with "invalid date";
      end if;
      return Time_Of (Result);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D, Precision);
   end Image;

   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String is
      use type Ada.Calendar.Time_Zones.Time_Offset;

      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 29) := "0000-00-00T00:00:00.000-00:00";
      N,  Tz  : Natural;
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      if Precision = YEAR then
         return Result (1 .. 4);
      end if;
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      if Precision = MONTH then
         return Result (1 .. 7);
      end if;
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      if Precision = DAY then
         return Result (1 .. 10);
      end if;
      Result (12) := To_Char (Date.Hour / 10);
      Result (13) := To_Char (Date.Hour mod 10);
      if Precision = HOUR then
         return Result (1 .. 13);
      end if;
      Result (15) := To_Char (Date.Minute / 10);
      Result (16) := To_Char (Date.Minute mod 10);
      if Precision = MINUTE then
         return Result (1 .. 16);
      end if;
      Result (18) := To_Char (Date.Second / 10);
      Result (19) := To_Char (Date.Second mod 10);
      if Precision = SECOND then
         return Result (1 .. 19);
      end if;
      N := Natural (Date.Sub_Second * 1000.0);
      Result (21) := To_Char (N / 100);
      Result (22) := To_Char ((N mod 100) / 10);
      Result (23) := To_Char (N mod 10);
      if Date.Time_Zone < 0 then
         Tz := Natural (-Date.Time_Zone);
      else
         Result (24) := '+';
         Tz := Natural (Date.Time_Zone);
      end if;
      Result (25) := To_Char (Tz / 600);
      Result (26) := To_Char ((Tz / 60) mod 10);
      Tz := Tz mod 60;
      Result (28) := To_Char (Tz / 10);
      Result (29) := To_Char (Tz mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

Use the new Time_Of function

Use the new Time_Of function


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

   --  The argument list interface that gives access to command arguments.
   type Argument_List is limited interface;

   --  Get the number of arguments available.
   function Get_Count (List : in Argument_List) return Natural is abstract;

   --  Get the argument at the given position.
   function Get_Argument (List : in Argument_List;
                          Pos  : in Positive) return String is abstract;

   --  Get the command name.
   function Get_Command_Name (List : in Argument_List) return String is abstract;

   type Default_Argument_List (Offset : Natural) is new Argument_List with null record;

   --  Get the number of arguments available.
   overriding
   function Get_Count (List : in Default_Argument_List) return Natural;

   --  Get the argument at the given position.
   overriding
   function Get_Argument (List : in Default_Argument_List;
                          Pos  : in Positive) return String;

   --  Get the command name.
   function Get_Command_Name (List : in Default_Argument_List) return String;

end Util.Commands;

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

   --  The argument list interface that gives access to command arguments.
   type Argument_List is limited interface;

   --  Get the number of arguments available.
   function Get_Count (List : in Argument_List) return Natural is abstract;

   --  Get the argument at the given position.
   function Get_Argument (List : in Argument_List;
                          Pos  : in Positive) return String is abstract;

   --  Get the command name.
   function Get_Command_Name (List : in Argument_List) return String is abstract;

   type Default_Argument_List (Offset : Natural) is new Argument_List with null record;

   --  Get the number of arguments available.
   overriding
   function Get_Count (List : in Default_Argument_List) return Natural;

   --  Get the argument at the given position.
   overriding
   function Get_Argument (List : in Default_Argument_List;
                          Pos  : in Positive) return String;

   --  Get the command name.
   function Get_Command_Name (List : in Default_Argument_List) return String;

   type String_Argument_List (Max_Length : Positive;
                              Max_Args   : Positive) is new Argument_List with private;

   --  Set the argument list to the given string and split the arguments.
   procedure Initialize (List : in out String_Argument_List;
                         Line : in String);

   --  Get the number of arguments available.
   overriding
   function Get_Count (List : in String_Argument_List) return Natural;

   --  Get the argument at the given position.
   overriding
   function Get_Argument (List : in String_Argument_List;
                          Pos  : in Positive) return String;

   --  Get the command name.
   overriding
   function Get_Command_Name (List : in String_Argument_List) return String;

private

   type Argument_Pos is array (Natural range <>) of Natural;

   type String_Argument_List (Max_Length : Positive;
                              Max_Args   : Positive) is new Argument_List
     with record
      Count     : Natural := 0;
      Length    : Natural := 0;
      Line      : String (1 .. Max_Length);
      Start_Pos : Argument_Pos (0 .. Max_Args);
      End_Pos   : Argument_Pos (0 .. Max_Args);
   end record;

end Util.Commands;

Declare the String_Argument_List type with its operation to split a string into arguments and provide the Argument_List interface operations


-----------------------------------------------------------------------
--  util-refs -- Reference Counting
--  Copyright (C) 2010, 2011, 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 Ada.Unchecked_Deallocation;
package body Util.Refs is

   package body Indefinite_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create (Value : in Element_Access) return Ref is
      begin
         return Result : Ref do
            Result.Target := Value;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         return Element_Accessor '(Element => Object.Target);
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Element_Type,
                                        Name   => Element_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Obj.Target.Finalize;
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end Indefinite_References;

   package body References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return IR.Create (new Element_Type);
      end Create;
   end References;

   package body General_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return Result : Ref do
            Result.Target := new Ref_Data;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         return Element_Accessor '(Element => Object.Target.Data'Access);
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ref_Data,
                                        Name   => Ref_Data_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Finalize (Obj.Target.Data);
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end General_References;

end Util.Refs;

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

with Ada.Unchecked_Deallocation;
package body Util.Refs is

   package body Indefinite_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create (Value : in Element_Access) return Ref is
      begin
         return Result : Ref do
            Result.Target := Value;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         return Element_Accessor '(Element => Object.Target);
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Element_Type,
                                        Name   => Element_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Obj.Target.Finalize;
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end Indefinite_References;

   package body References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return IR.Create (new Element_Type);
      end Create;
   end References;

   package body General_References is

      --  ------------------------------
      --  Create an element and return a reference to that element.
      --  ------------------------------
      function Create return Ref is
      begin
         return Result : Ref do
            Result.Target := new Ref_Data;
            Util.Concurrent.Counters.Increment (Result.Target.Ref_Counter);
         end return;
      end Create;

      --  ------------------------------
      --  Get the element access value.
      --  ------------------------------
      function Value (Object : in Ref'Class) return Element_Accessor is
      begin
         --  GCC 10 requires the Unrestricted_Access while GCC < 10 allowed Access...
         --  It is safe because the Ref handles the copy and Element_Accessor is limited.
         return Element_Accessor '(Element => Object.Target.Data'Unrestricted_Access);
      end Value;

      --  ------------------------------
      --  Returns true if the reference does not contain any element.
      --  ------------------------------
      function Is_Null (Object : in Ref'Class) return Boolean is
      begin
         return Object.Target = null;
      end Is_Null;

      function "=" (Left, Right : in Ref'Class) return Boolean is
      begin
         return Left.Target = Right.Target;
      end "=";

      package body Atomic is
         protected body Atomic_Ref is
            --  ------------------------------
            --  Get the reference
            --  ------------------------------
            function Get return Ref is
            begin
               return Value;
            end Get;

            --  ------------------------------
            --  Change the reference
            --  ------------------------------
            procedure Set (Object : in Ref) is
            begin
               Value := Object;
            end Set;

         end Atomic_Ref;
      end Atomic;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Ref_Data,
                                        Name   => Ref_Data_Access);

      --  ------------------------------
      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      --  ------------------------------
      overriding
      procedure Finalize (Obj : in out Ref) is
         Release : Boolean;
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
            if Release then
               Finalize (Obj.Target.Data);
               Free (Obj.Target);
            else
               Obj.Target := null;
            end if;
         end if;
      end Finalize;

      --  ------------------------------
      --  Update the reference counter after an assignment.
      --  ------------------------------
      overriding
      procedure Adjust (Obj : in out Ref) is
      begin
         if Obj.Target /= null then
            Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
         end if;
      end Adjust;

   end General_References;

end Util.Refs;

Fix compilation with GNAT 10

Fix compilation with GNAT 10


--  Copyright (c) 2017 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.

with Glfw.Errors;
with Glfw.Windows.Context;
with Glfw.Windows.Hints;

with Orka.Inputs.GLFW;
with Orka.Logging;

package body Orka.Windows.GLFW is

   use Orka.Logging;
   package Messages is new Orka.Logging.Messages (Other);

   procedure Print_Error (Code : Standard.Glfw.Errors.Kind; Description : String) is
   begin
      Messages.Insert (Error, "GLFW " & Code'Image & ": " & Trim (Description));
   end Print_Error;

   function Initialize
     (Major, Minor : Natural;
      Debug : Boolean := False) return Active_GLFW'Class is
   begin
      --  Initialize GLFW
      Standard.Glfw.Errors.Set_Callback (Print_Error'Access);
      Standard.Glfw.Init;

      --  Initialize OpenGL context
      Standard.Glfw.Windows.Hints.Set_Minimum_OpenGL_Version (Major, Minor);
      Standard.Glfw.Windows.Hints.Set_Forward_Compat (True);
      Standard.Glfw.Windows.Hints.Set_Profile (Standard.Glfw.Windows.Context.Core_Profile);
      Standard.Glfw.Windows.Hints.Set_Debug_Context (Debug);

      return Active_GLFW'(Ada.Finalization.Limited_Controlled
        with Debug => Debug, Finalized => False);
   end Initialize;

   overriding
   procedure Finalize (Object : in out Active_GLFW) is
   begin
      if not Object.Finalized then
         if Object.Debug then
            Messages.Insert (Debug, "Shutting down GLFW");
         end if;
         Standard.Glfw.Shutdown;
         Object.Finalized := True;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out GLFW_Window) is
   begin
      if not Object.Finalized then
         Object.Destroy;
         Object.Finalized := True;
      end if;
   end Finalize;

   function Create_Window
     (Width, Height : Positive;
      Samples : Natural := 0;
      Visible, Resizable : Boolean := True) return Window'Class
   is
      package Windows renames Standard.Glfw.Windows;
   begin
      return Result : GLFW_Window := GLFW_Window'(Windows.Window
        with Input => Inputs.GLFW.Create_Pointer_Input, Finalized => False, others => <>)
      do
         declare
            Reference : constant Windows.Window_Reference := Windows.Window (Window'Class (Result))'Access;
         begin
            Windows.Hints.Set_Visible (Visible);
            Windows.Hints.Set_Resizable (Resizable);
            Windows.Hints.Set_Samples (Samples);

            Reference.Init (Standard.Glfw.Size (Width), Standard.Glfw.Size (Height), "");

            Inputs.GLFW.GLFW_Pointer_Input (Result.Input.all).Set_Window (Reference);

            declare
               Width, Height : Standard.Glfw.Size;
            begin
               Reference.Get_Framebuffer_Size (Width, Height);
               Result.Framebuffer_Size_Changed (Natural (Width), Natural (Height));
            end;

            --  Callbacks
            Reference.Enable_Callback (Windows.Callbacks.Close);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Button);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Position);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Scroll);
            Reference.Enable_Callback (Windows.Callbacks.Key);
            Reference.Enable_Callback (Windows.Callbacks.Framebuffer_Size);

            Windows.Context.Make_Current (Reference);
         end;
      end return;
   end Create_Window;

   overriding
   function Pointer_Input
     (Object : GLFW_Window) return Inputs.Pointer_Input_Ptr
   is (Object.Input);

   overriding
   function Width (Object : GLFW_Window) return Positive is
     (Object.Width);

   overriding
   function Height (Object : GLFW_Window) return Positive is
     (Object.Height);

   overriding
   procedure Set_Title (Object : in out GLFW_Window; Value : String) is
   begin
      Standard.Glfw.Windows.Window (Object)'Access.Set_Title (Value);
   end Set_Title;

   overriding
   procedure Close (Object : in out GLFW_Window) is
   begin
      Object.Set_Should_Close (True);
   end Close;

   overriding
   function Should_Close (Object : in out GLFW_Window) return Boolean is
   begin
      return Standard.Glfw.Windows.Window (Object)'Access.Should_Close;
   end Should_Close;

   overriding
   procedure Process_Input (Object : in out GLFW_Window) is
   begin
      Standard.Glfw.Input.Poll_Events;

      --  Update position of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Position
        (Object.Position_X, Object.Position_Y);

      --  Update scroll offset of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Scroll_Offset
        (Object.Scroll_X, Object.Scroll_Y);
   end Process_Input;

   overriding
   procedure Swap_Buffers (Object : in out GLFW_Window) is
   begin
      Standard.Glfw.Windows.Context.Swap_Buffers (Object'Access);
   end Swap_Buffers;

   overriding
   procedure Close_Requested (Object : not null access GLFW_Window) is
   begin
      --  TODO Call Object.Set_Should_Close (False); if certain conditions are not met
      null;
   end Close_Requested;

   overriding
   procedure Key_Changed
     (Object   : not null access GLFW_Window;
      Key      : Standard.Glfw.Input.Keys.Key;
      Scancode : Standard.Glfw.Input.Keys.Scancode;
      Action   : Standard.Glfw.Input.Keys.Action;
      Mods     : Standard.Glfw.Input.Keys.Modifiers)
   is
      use Standard.Glfw.Input.Keys;
   begin
      if Key = Escape and Action = Press then
         Object.Set_Should_Close (True);
      end if;
      --  TODO Add Button_Input object
   end Key_Changed;

   overriding
   procedure Mouse_Position_Changed
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Coordinate) is
   begin
      Object.Position_X := GL.Types.Double (X);
      Object.Position_Y := GL.Types.Double (Y);
   end Mouse_Position_Changed;

   overriding
   procedure Mouse_Scrolled
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Scroll_Offset)
   is
      use type GL.Types.Double;
   begin
      Object.Scroll_X := Object.Scroll_X + GL.Types.Double (X);
      Object.Scroll_Y := Object.Scroll_Y + GL.Types.Double (Y);
   end Mouse_Scrolled;

   overriding
   procedure Mouse_Button_Changed
     (Object  : not null access GLFW_Window;
      Button  : Standard.Glfw.Input.Mouse.Button;
      State   : Standard.Glfw.Input.Button_State;
      Mods    : Standard.Glfw.Input.Keys.Modifiers) is
   begin
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Button_State (Button, State);
   end Mouse_Button_Changed;

   overriding
   procedure Framebuffer_Size_Changed
     (Object : not null access GLFW_Window;
      Width, Height : Natural) is
   begin
      Object.Width  := Width;
      Object.Height := Height;
   end Framebuffer_Size_Changed;

end Orka.Windows.GLFW;

--  Copyright (c) 2017 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.

with Glfw.Errors;
with Glfw.Windows.Context;
with Glfw.Windows.Hints;

with Orka.Inputs.GLFW;
with Orka.Logging;

package body Orka.Windows.GLFW is

   use Orka.Logging;
   package Messages is new Orka.Logging.Messages (Other);

   procedure Print_Error (Code : Standard.Glfw.Errors.Kind; Description : String) is
   begin
      Messages.Insert (Error, "GLFW " & Code'Image & ": " & Trim (Description));
   end Print_Error;

   function Initialize
     (Major, Minor : Natural;
      Debug : Boolean := False) return Active_GLFW'Class is
   begin
      --  Initialize GLFW
      Standard.Glfw.Errors.Set_Callback (Print_Error'Access);
      Standard.Glfw.Init;

      --  Initialize OpenGL context
      Standard.Glfw.Windows.Hints.Set_Minimum_OpenGL_Version (Major, Minor);
      Standard.Glfw.Windows.Hints.Set_Forward_Compat (True);
      Standard.Glfw.Windows.Hints.Set_Client_API (Standard.Glfw.Windows.Context.OpenGL);
      Standard.Glfw.Windows.Hints.Set_Profile (Standard.Glfw.Windows.Context.Core_Profile);
      Standard.Glfw.Windows.Hints.Set_Debug_Context (Debug);

      return Active_GLFW'(Ada.Finalization.Limited_Controlled
        with Debug => Debug, Finalized => False);
   end Initialize;

   overriding
   procedure Finalize (Object : in out Active_GLFW) is
   begin
      if not Object.Finalized then
         if Object.Debug then
            Messages.Insert (Debug, "Shutting down GLFW");
         end if;
         Standard.Glfw.Shutdown;
         Object.Finalized := True;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out GLFW_Window) is
   begin
      if not Object.Finalized then
         Object.Destroy;
         Object.Finalized := True;
      end if;
   end Finalize;

   function Create_Window
     (Width, Height : Positive;
      Samples : Natural := 0;
      Visible, Resizable : Boolean := True) return Window'Class
   is
      package Windows renames Standard.Glfw.Windows;
   begin
      return Result : GLFW_Window := GLFW_Window'(Windows.Window
        with Input => Inputs.GLFW.Create_Pointer_Input, Finalized => False, others => <>)
      do
         declare
            Reference : constant Windows.Window_Reference
              := Windows.Window (Window'Class (Result))'Access;
         begin
            Windows.Hints.Set_Visible (Visible);
            Windows.Hints.Set_Resizable (Resizable);
            Windows.Hints.Set_Samples (Samples);

            Reference.Init (Standard.Glfw.Size (Width), Standard.Glfw.Size (Height), "");

            Inputs.GLFW.GLFW_Pointer_Input (Result.Input.all).Set_Window (Reference);

            declare
               Width, Height : Standard.Glfw.Size;
            begin
               Reference.Get_Framebuffer_Size (Width, Height);
               Result.Framebuffer_Size_Changed (Natural (Width), Natural (Height));
            end;

            --  Callbacks
            Reference.Enable_Callback (Windows.Callbacks.Close);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Button);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Position);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Scroll);
            Reference.Enable_Callback (Windows.Callbacks.Key);
            Reference.Enable_Callback (Windows.Callbacks.Framebuffer_Size);

            Windows.Context.Make_Current (Reference);
         end;
      end return;
   end Create_Window;

   overriding
   function Pointer_Input
     (Object : GLFW_Window) return Inputs.Pointer_Input_Ptr
   is (Object.Input);

   overriding
   function Width (Object : GLFW_Window) return Positive is
     (Object.Width);

   overriding
   function Height (Object : GLFW_Window) return Positive is
     (Object.Height);

   overriding
   procedure Set_Title (Object : in out GLFW_Window; Value : String) is
   begin
      Standard.Glfw.Windows.Window (Object)'Access.Set_Title (Value);
   end Set_Title;

   overriding
   procedure Close (Object : in out GLFW_Window) is
   begin
      Object.Set_Should_Close (True);
   end Close;

   overriding
   function Should_Close (Object : in out GLFW_Window) return Boolean is
   begin
      return Standard.Glfw.Windows.Window (Object)'Access.Should_Close;
   end Should_Close;

   overriding
   procedure Process_Input (Object : in out GLFW_Window) is
   begin
      Standard.Glfw.Input.Poll_Events;

      --  Update position of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Position
        (Object.Position_X, Object.Position_Y);

      --  Update scroll offset of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Scroll_Offset
        (Object.Scroll_X, Object.Scroll_Y);
   end Process_Input;

   overriding
   procedure Swap_Buffers (Object : in out GLFW_Window) is
   begin
      Standard.Glfw.Windows.Context.Swap_Buffers (Object'Access);
   end Swap_Buffers;

   overriding
   procedure Close_Requested (Object : not null access GLFW_Window) is
   begin
      --  TODO Call Object.Set_Should_Close (False); if certain conditions are not met
      null;
   end Close_Requested;

   overriding
   procedure Key_Changed
     (Object   : not null access GLFW_Window;
      Key      : Standard.Glfw.Input.Keys.Key;
      Scancode : Standard.Glfw.Input.Keys.Scancode;
      Action   : Standard.Glfw.Input.Keys.Action;
      Mods     : Standard.Glfw.Input.Keys.Modifiers)
   is
      use Standard.Glfw.Input.Keys;
   begin
      if Key = Escape and Action = Press then
         Object.Set_Should_Close (True);
      end if;
      --  TODO Add Button_Input object
   end Key_Changed;

   overriding
   procedure Mouse_Position_Changed
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Coordinate) is
   begin
      Object.Position_X := GL.Types.Double (X);
      Object.Position_Y := GL.Types.Double (Y);
   end Mouse_Position_Changed;

   overriding
   procedure Mouse_Scrolled
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Scroll_Offset)
   is
      use type GL.Types.Double;
   begin
      Object.Scroll_X := Object.Scroll_X + GL.Types.Double (X);
      Object.Scroll_Y := Object.Scroll_Y + GL.Types.Double (Y);
   end Mouse_Scrolled;

   overriding
   procedure Mouse_Button_Changed
     (Object  : not null access GLFW_Window;
      Button  : Standard.Glfw.Input.Mouse.Button;
      State   : Standard.Glfw.Input.Button_State;
      Mods    : Standard.Glfw.Input.Keys.Modifiers) is
   begin
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Button_State (Button, State);
   end Mouse_Button_Changed;

   overriding
   procedure Framebuffer_Size_Changed
     (Object : not null access GLFW_Window;
      Width, Height : Natural) is
   begin
      Object.Width  := Width;
      Object.Height := Height;
   end Framebuffer_Size_Changed;

end Orka.Windows.GLFW;

orka: Make sure to request an OpenGL, not OpenGL ES, context

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