-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for storage service
--  Copyright (C) 2013 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.Streams;
with Ada.Strings.Unbounded;

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Questions.Beans;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Services.Save_Question",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Queries question-list",
                       Test_List_Questions'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

   --  ------------------------------
   --  Test list of questions.
   --  ------------------------------
   procedure Test_List_Questions (T : in out Test) is
      use AWA.Questions.Models;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
      Module    : AWA.Questions.Modules.Question_Module_Access;
      List      : Util.Beans.Basic.Readonly_Bean_Access;
      Bean      : Util.Beans.Objects.Object;
      Count     : Natural;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);
      Module := AWA.Questions.Modules.Get_Question_Module;
      List := AWA.Questions.Beans.Create_Question_List_Bean (Module);
      T.Assert (List /= null, "The Create_Question_List_Bean returned null");

      Bean := Util.Beans.Objects.To_Object (List);
      T.Assert (not Util.Beans.Objects.Is_Null (Bean), "The list bean should not be null");
      Count := Questions.Models.Question_Info_List_Bean'Class (List.all).Get_Count;

      T.Assert (Count > 0, "The list of question is empty");
   end Test_List_Questions;

end AWA.Questions.Services.Tests;

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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with Security.Contexts;

with ASF.Contexts.Faces;
with ASF.Contexts.Faces.Mockup;

with AWA.Permissions;
with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Questions.Beans;
with AWA.Votes.Beans;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Services.Save_Question",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Queries question-list",
                       Test_List_Questions'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean",
                       Test_Question_Vote'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean (anonymous user)",
                       Test_Question_Vote'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

   --  ------------------------------
   --  Test list of questions.
   --  ------------------------------
   procedure Test_List_Questions (T : in out Test) is
      use AWA.Questions.Models;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Module    : AWA.Questions.Modules.Question_Module_Access;
      List      : Util.Beans.Basic.Readonly_Bean_Access;
      Bean      : Util.Beans.Objects.Object;
      Count     : Natural;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);
      Module := AWA.Questions.Modules.Get_Question_Module;
      List := AWA.Questions.Beans.Create_Question_List_Bean (Module);
      T.Assert (List /= null, "The Create_Question_List_Bean returned null");

      Bean := Util.Beans.Objects.To_Object (List);
      T.Assert (not Util.Beans.Objects.Is_Null (Bean), "The list bean should not be null");
      Count := Questions.Models.Question_Info_List_Bean'Class (List.all).Get_Count;

      T.Assert (Count > 0, "The list of question is empty");
   end Test_List_Questions;

   --  ------------------------------
   --  Do a vote on a question through the question vote bean.
   --  ------------------------------
   procedure Do_Vote (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Context : ASF.Contexts.Faces.Mockup.Mockup_Faces_Context;
      Outcome : Ada.Strings.Unbounded.Unbounded_String;
      Bean    : Util.Beans.Basic.Readonly_Bean_Access;
      Vote    : AWA.Votes.Beans.Vote_Bean_Access;
   begin
      Bean := Context.Get_Bean ("questionVote");
      T.Assert (Bean /= null, "The questionVote bean was not created");

      T.Assert (Bean.all in AWA.Votes.Beans.Vote_Bean'Class,
                "The questionVote is not a Vote_Bean");

      Vote := AWA.Votes.Beans.Vote_Bean (Bean.all)'Access;
      Vote.Rating    := 1;
      Vote.Entity_Id := 1;
      Vote.Vote_Up (Outcome);
   end Do_Vote;

   --  ------------------------------
   --  Test anonymous user voting for a question.
   --  ------------------------------
   procedure Test_Question_Vote_Anonymous (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);

      Do_Vote (T);
      T.Fail ("Anonymous users should not be allowed to vote");

   exception
      when AWA.Permissions.NO_PERMISSION =>
         null;
   end Test_Question_Vote_Anonymous;

   --  ------------------------------
   --  Test voting for a question.
   --  ------------------------------
   procedure Test_Question_Vote (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-voter@test.com");

      Do_Vote (T);
   end Test_Question_Vote;

end AWA.Questions.Services.Tests;

Add unit tests for the questionVote bean


-----------------------------------------------------------------------
--  security -- Security
--  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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies.  The framework defines a simple role based security policy and an URL security
--  policy intended to provide security in web applications.  The security policy manager reads
--  some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components (yellow) are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance.  Additional security policy context can be added depending on
--  the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies.  The framework defines a simple role based security policy and an URL security
--  policy intended to provide security in web applications.  The security policy manager reads
--  some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components (yellow) are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance.  Additional security policy context can be added depending on
--  the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

Make the OAuth and OpenID a separate wiki page


--  bkp-files -- File and directories
-----------------------------------------------------------------------
--  Copyright (C) 2014 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Streams.Stream_IO;
with Util.Log.Loggers;
with Util.Files;
with Interfaces.C;
package body Babel.Files is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bkp.Files");

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

end Babel.Files;

--  bkp-files -- File and directories
-----------------------------------------------------------------------
--  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 Util.Log.Loggers;
with Util.Files;
package body Babel.Files is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bkp.Files");

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

end Babel.Files;

Remove unused with clauses

Remove unused with clauses


-----------------------------------------------------------------------
--  gen-model-enums -- Enum definitions
--  Copyright (C) 2011, 2012, 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 Gen.Model.Enums is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Value_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "value" then
         return Util.Beans.Objects.To_Object (From.Number);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Enum_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "values" then
         return From.Values_Bean;
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Type_Name);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (True);
      elsif Name = "sqlType" then
         return Util.Beans.Objects.To_Object (From.Sql_Type);
      else
         return Mappings.Mapping_Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Compare two enum literals.
   --  ------------------------------
   function "<" (Left, Right : in Value_Definition_Access) return Boolean is
   begin
      return Left.Number < Right.Number;
   end "<";

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Enum_Definition) is
      procedure Sort is new Value_List.Sort_On ("<");
   begin
      O.Target := O.Type_Name;
      Sort (O.Values);
   end Prepare;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Enum_Definition) is
   begin
      O.Values_Bean := Util.Beans.Objects.To_Object (O.Values'Unchecked_Access,
                                                     Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Add an enum value to this enum definition and return the new value.
   --  ------------------------------
   procedure Add_Value (Enum  : in out Enum_Definition;
                        Name  : in String;
                        Value : out Value_Definition_Access) is
   begin
      Value := new Value_Definition;
      Value.Set_Name (Name);
      Value.Number := Enum.Values.Get_Count;
      Enum.Values.Append (Value);
   end Add_Value;

   --  ------------------------------
   --  Create an enum with the given name.
   --  ------------------------------
   function Create_Enum (Name : in Unbounded_String) return Enum_Definition_Access is
      Enum : constant Enum_Definition_Access := new Enum_Definition;
   begin
      Enum.Set_Name (Name);
      declare
         Pos : constant Natural := Index (Enum.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Enum.Pkg_Name := Unbounded_Slice (Enum.Name, 1, Pos - 1);
            Enum.Type_Name := Unbounded_Slice (Enum.Name, Pos + 1, Length (Enum.Name));
         else
            Enum.Pkg_Name := To_Unbounded_String ("ADO");
            Enum.Type_Name := Enum.Name;
         end if;
      end;
      return Enum;
   end Create_Enum;

end Gen.Model.Enums;

-----------------------------------------------------------------------
--  gen-model-enums -- Enum definitions
--  Copyright (C) 2011, 2012, 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 Gen.Model.Enums is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Value_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "value" then
         return Util.Beans.Objects.To_Object (From.Number);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : Enum_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "values" then
         return From.Values_Bean;
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Type_Name);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (True);
      elsif Name = "sqlType" then
         return Util.Beans.Objects.To_Object (Mappings.Get_Type_Name (From.Sql_Type));
      else
         return Mappings.Mapping_Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Compare two enum literals.
   --  ------------------------------
   function "<" (Left, Right : in Value_Definition_Access) return Boolean is
   begin
      return Left.Number < Right.Number;
   end "<";

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Enum_Definition) is
      procedure Sort is new Value_List.Sort_On ("<");
   begin
      O.Target := O.Type_Name;
      Sort (O.Values);
   end Prepare;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Enum_Definition) is
   begin
      O.Values_Bean := Util.Beans.Objects.To_Object (O.Values'Unchecked_Access,
                                                     Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Add an enum value to this enum definition and return the new value.
   --  ------------------------------
   procedure Add_Value (Enum  : in out Enum_Definition;
                        Name  : in String;
                        Value : out Value_Definition_Access) is
   begin
      Value := new Value_Definition;
      Value.Set_Name (Name);
      Value.Number := Enum.Values.Get_Count;
      Enum.Values.Append (Value);
   end Add_Value;

   --  ------------------------------
   --  Create an enum with the given name.
   --  ------------------------------
   function Create_Enum (Name : in Unbounded_String) return Enum_Definition_Access is
      Enum : constant Enum_Definition_Access := new Enum_Definition;
   begin
      Enum.Set_Name (Name);
      declare
         Pos : constant Natural := Index (Enum.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Enum.Pkg_Name := Unbounded_Slice (Enum.Name, 1, Pos - 1);
            Enum.Type_Name := Unbounded_Slice (Enum.Name, Pos + 1, Length (Enum.Name));
         else
            Enum.Pkg_Name := To_Unbounded_String ("ADO");
            Enum.Type_Name := Enum.Name;
         end if;
      end;
      return Enum;
   end Create_Enum;

end Gen.Model.Enums;

Use the Get_Type_Mapping function to convert the Sql_Type into a target SQL type (the SQL type can be different for Postgresql/MySQL/SQLite)


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 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.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Get the driver index that corresponds to the driver for this database connection string.
   --  ------------------------------
   function Get_Driver (Config : in Configuration) return Driver_Index is
      Driver  : constant Driver_Access := Get_Driver (Config.Get_Driver);
   begin
      if Driver = null then
         return Driver_Index'First;
      else
         return Driver.Get_Driver_Index;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      Driver  : Driver_Access;
      Log_URI : constant String := Config.Get_Log_URI;
   begin
      Driver := Get_Driver (Config.Get_Driver);
      if Driver = null then
         Log.Error ("No driver found for connection {0}", Log_URI);
         raise ADO.Configs.Connection_Error with
           "Data source is not initialized: driver '" & Config.Get_Driver & "' not found";
      end if;
      Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Log_URI, Result.Value.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Log_URI);
         raise;

   end Create_Connection;

   --  ------------------------------
   --  Get the database driver index.
   --  ------------------------------
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index is
      Driver : constant ADO.Drivers.Connections.Driver_Access
         := Database_Connection'Class (Database).Get_Driver;
   begin
      return Driver.Get_Driver_Index;
   end Get_Driver_Index;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;
      Dynamic_Load : constant String := Get_Config (ADO.Configs.DYNAMIC_DRIVER_LOAD);
   begin
      if Dynamic_Load /= "1" and Dynamic_Load /= "true" then
         Log.Warn ("Dynamic loading of driver '{0}' is disabled", Name);
         return;
      end if;
      Log.Debug ("Loading driver '{0}' from {1}", Name, Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Log.Info ("Initialising driver {0}", Lib);
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Debug ("Get driver {0}", Name);

      if Name'Length = 0 then
         return null;
      end if;

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 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.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Get the driver index that corresponds to the driver for this database connection string.
   --  ------------------------------
   function Get_Driver (Config : in Configuration) return Driver_Index is
      Driver  : constant Driver_Access := Get_Driver (Config.Get_Driver);
   begin
      if Driver = null then
         return Driver_Index'First;
      else
         return Driver.Get_Driver_Index;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      Driver  : Driver_Access;
      Log_URI : constant String := Config.Get_Log_URI;
   begin
      Driver := Get_Driver (Config.Get_Driver);
      if Driver = null then
         Log.Error ("No driver found for connection {0}", Log_URI);
         raise ADO.Configs.Connection_Error with
           "Data source is not initialized: driver '" & Config.Get_Driver & "' not found";
      end if;
      Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Log_URI, Result.Value.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Log_URI);
         raise;

   end Create_Connection;

   --  ------------------------------
   --  Get the database driver index.
   --  ------------------------------
   function Get_Driver_Index (Database : in Database_Connection) return Driver_Index is
      Driver : constant ADO.Drivers.Connections.Driver_Access
         := Database_Connection'Class (Database).Get_Driver;
   begin
      return Driver.Get_Driver_Index;
   end Get_Driver_Index;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;
   begin
      if Is_On (ADO.Configs.DYNAMIC_DRIVER_LOAD) then
         Log.Warn ("Dynamic loading of driver '{0}' is disabled", Name);
         return;
      end if;
      Log.Debug ("Loading driver '{0}' from {1}", Name, Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Log.Info ("Initialising driver {0}", Lib);
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Debug ("Get driver {0}", Name);

      if Name'Length = 0 then
         return null;
      end if;

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

Use the Is_On function to check if we can use dynamic load


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

with ASF.Applications;

with AWA.Modules;
package AWA.Counters.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "counters";

   --  Default age limit to flush counters: 5 minutes.
   DEFAULT_AGE_LIMIT : constant Duration := 5 * 60.0;

   --  Default maximum number of different counters to keep before flushing.
   DEFAULT_COUNTER_LIMIT : constant Natural := 1_000;

   PARAM_AGE_LIMIT       : constant String := "counter_age_limit";

   PARAM_COUNTER_LIMIT   : constant String := "counter_limit";

   --  ------------------------------
   --  Module counters
   --  ------------------------------
   type Counter_Module is new AWA.Modules.Module with private;
   type Counter_Module_Access is access all Counter_Module'Class;

   --  Initialize the counters module.
   overriding
   procedure Initialize (Plugin : in out Counter_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Counter_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the counters module.
   function Get_Counter_Module return Counter_Module_Access;

   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class);

   --  Increment the counter identified by <tt>Counter</tt>.
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type);

   --  Get the current counter value.
   procedure Get_Counter (Plugin  : in out Counter_Module;
                          Counter : in AWA.Counters.Counter_Index_Type;
                          Object  : in ADO.Objects.Object_Ref'Class;
                          Result  : out Natural);

   --  Flush the existing counters and update all the database records refered to them.
   procedure Flush (Plugin : in out Counter_Module);

private

   type Definition_Array_Type is array (Counter_Index_Type range <>) of Natural;
   type Definition_Array_Type_Access is access all Definition_Array_Type;

   --  The counter map tracks a counter associated with a database object.
   --  All the database objects refer to the same counter.
   package Counter_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => ADO.Objects.Object_Key,
                                                Element_Type    => Positive,
                                                Hash            => ADO.Objects.Hash,
                                                Equivalent_Keys => ADO.Objects."=");

   --  The <tt>Counter_Map_Array</tt> associate a counter map to each counter definition.
   type Counter_Map_Array is array (Counter_Index_Type range <>) of Counter_Maps.Map;
   type Counter_Map_Array_Access is access all Counter_Map_Array;

   --  Counters are kept temporarily in the <tt>Counter_Table</tt> protected type to avoid
   --  having to update the database each time a counter is incremented.  Counters are flushed
   --  when the table reaches some limit, or, when the table is oldest than some limit.
   --  Counters are associated with a day so that it becomes possible to gather per-day counters.
   --
   --  The <tt>Flush</tt> operation on the <tt>Counter_Module</tt> can be used to flush
   --  the pending counters.  For each counter that was updated, it either inserts or
   --  updates a row in the counters database table.  Because such operation is slow, it is not
   --  implemented in the protected type.  Instead, we steal the counter table and replace it
   --  with a new/empty table.  This is done by <tt>Steal_Counters</tt> protected operation.
   --  While doing the flush, other tasks can increment counters without being blocked by the
   --  <tt>Flush</tt> operation.
   protected type Counter_Table is

      --  Increment the counter identified by <tt>Counter</tt> and associated with the
      --  database object <tt>Key</tt>.
      procedure Increment (Counter : in Counter_Index_Type;
                           Key     : in ADO.Objects.Object_Key);

      --  Get the counters that have been collected with the date and prepare to collect
      --  new counters.
      procedure Steal_Counters (Result : out Counter_Map_Array_Access;
                                Date   : out Ada.Calendar.Time);

      --  Check if we must flush the counters.
      function Need_Flush (Limit   : in Natural;
                           Seconds : in Duration) return Boolean;

      --  Get the definition ID associated with the counter.
      procedure Get_Definition (Counter : in Counter_Index_Type;
                                Result  : out Natural);

   private
      Day         : Ada.Calendar.Time;
      Day_End     : Ada.Calendar.Time;
      Counters    : Counter_Map_Array_Access;
      Definitions : Definition_Array_Type_Access;
      Nb_Counters : Natural := 0;
   end Counter_Table;

   type Counter_Module is new AWA.Modules.Module with record
      Counters      : Counter_Table;

      Counter_Limit : Natural  := DEFAULT_COUNTER_LIMIT;
      Age_Limit     : Duration := DEFAULT_AGE_LIMIT;
   end record;

end AWA.Counters.Modules;

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

with ASF.Applications;

with AWA.Modules;
package AWA.Counters.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "counters";

   --  Default age limit to flush counters: 5 minutes.
   DEFAULT_AGE_LIMIT : constant Duration := 5 * 60.0;

   --  Default maximum number of different counters to keep before flushing.
   DEFAULT_COUNTER_LIMIT : constant Natural := 1_000;

   PARAM_AGE_LIMIT       : constant String := "counter_age_limit";

   PARAM_COUNTER_LIMIT   : constant String := "counter_limit";

   --  ------------------------------
   --  Module counters
   --  ------------------------------
   type Counter_Module is new AWA.Modules.Module with private;
   type Counter_Module_Access is access all Counter_Module'Class;

   --  Initialize the counters module.
   overriding
   procedure Initialize (Plugin : in out Counter_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Counter_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the counters module.
   function Get_Counter_Module return Counter_Module_Access;

   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class);

   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object key <tt>Key</tt>.
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type;
                        Key     : in ADO.Objects.Object_Key);

   --  Increment the counter identified by <tt>Counter</tt>.
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type);

   --  Get the current counter value.
   procedure Get_Counter (Plugin  : in out Counter_Module;
                          Counter : in AWA.Counters.Counter_Index_Type;
                          Object  : in ADO.Objects.Object_Ref'Class;
                          Result  : out Natural);

   --  Flush the existing counters and update all the database records refered to them.
   procedure Flush (Plugin : in out Counter_Module);

private

   type Definition_Array_Type is array (Counter_Index_Type range <>) of Natural;
   type Definition_Array_Type_Access is access all Definition_Array_Type;

   --  The counter map tracks a counter associated with a database object.
   --  All the database objects refer to the same counter.
   package Counter_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => ADO.Objects.Object_Key,
                                                Element_Type    => Positive,
                                                Hash            => ADO.Objects.Hash,
                                                Equivalent_Keys => ADO.Objects."=");

   --  The <tt>Counter_Map_Array</tt> associate a counter map to each counter definition.
   type Counter_Map_Array is array (Counter_Index_Type range <>) of Counter_Maps.Map;
   type Counter_Map_Array_Access is access all Counter_Map_Array;

   --  Counters are kept temporarily in the <tt>Counter_Table</tt> protected type to avoid
   --  having to update the database each time a counter is incremented.  Counters are flushed
   --  when the table reaches some limit, or, when the table is oldest than some limit.
   --  Counters are associated with a day so that it becomes possible to gather per-day counters.
   --
   --  The <tt>Flush</tt> operation on the <tt>Counter_Module</tt> can be used to flush
   --  the pending counters.  For each counter that was updated, it either inserts or
   --  updates a row in the counters database table.  Because such operation is slow, it is not
   --  implemented in the protected type.  Instead, we steal the counter table and replace it
   --  with a new/empty table.  This is done by <tt>Steal_Counters</tt> protected operation.
   --  While doing the flush, other tasks can increment counters without being blocked by the
   --  <tt>Flush</tt> operation.
   protected type Counter_Table is

      --  Increment the counter identified by <tt>Counter</tt> and associated with the
      --  database object <tt>Key</tt>.
      procedure Increment (Counter : in Counter_Index_Type;
                           Key     : in ADO.Objects.Object_Key);

      --  Get the counters that have been collected with the date and prepare to collect
      --  new counters.
      procedure Steal_Counters (Result : out Counter_Map_Array_Access;
                                Date   : out Ada.Calendar.Time);

      --  Check if we must flush the counters.
      function Need_Flush (Limit   : in Natural;
                           Seconds : in Duration) return Boolean;

      --  Get the definition ID associated with the counter.
      procedure Get_Definition (Counter : in Counter_Index_Type;
                                Result  : out Natural);

   private
      Day         : Ada.Calendar.Time;
      Day_End     : Ada.Calendar.Time;
      Counters    : Counter_Map_Array_Access;
      Definitions : Definition_Array_Type_Access;
      Nb_Counters : Natural := 0;
   end Counter_Table;

   type Counter_Module is new AWA.Modules.Module with record
      Counters      : Counter_Table;

      Counter_Limit : Natural  := DEFAULT_COUNTER_LIMIT;
      Age_Limit     : Duration := DEFAULT_AGE_LIMIT;
   end record;

end AWA.Counters.Modules;

Declare the Increment procedure with Object_Key type


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled with private;
   type Manager_Access is access Manager'Class;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   function Get_Names (Self : in Manager) return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "");

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean is abstract;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value is abstract;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value) is abstract;

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value) is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      procedure Delete (Self : in Manager; Obj : in out Manager_Access)
        is abstract;

      function Get_Names (Self : in Manager) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   procedure Adjust   (Object : in out Manager);
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled with private;
   type Manager_Access is access all Manager'Class;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   function Get_Names (Self : in Manager) return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "");

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean is abstract;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value is abstract;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value) is abstract;

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value) is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      procedure Delete (Self : in Manager; Obj : in out Manager_Access)
        is abstract;

      function Get_Names (Self : in Manager) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   procedure Adjust   (Object : in out Manager);
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Update the Manager_Access to be class-wide access type


-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Command_Line;
with System.Address_To_Access_Conversions;

with Lumen.Events.Animate;
with Lumen.Image;
with Lumen.Window;

with GL;
with GLU;

procedure Texture is

   ---------------------------------------------------------------------------

   -- Rotation wraps around at this point, in degrees
   Max_Rotation : constant := 359;

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

   ---------------------------------------------------------------------------

   Win      : Lumen.Window.Handle;
   Direct   : Boolean := True;  -- want direct rendering by default
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;

   Attrs    : Lumen.Window.Context_Attributes :=
      (
       (Lumen.Window.Attr_Red_Size,     8),
       (Lumen.Window.Attr_Green_Size,   8),
       (Lumen.Window.Attr_Blue_Size,    8),
       (Lumen.Window.Attr_Alpha_Size,   8),
       (Lumen.Window.Attr_Depth_Size,  24),
       (Lumen.Window.Attr_Stencil_Size, 8)
      );

   ---------------------------------------------------------------------------

   Program_Error : exception;
   Program_Exit  : exception;

   ---------------------------------------------------------------------------

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values.all'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

   ---------------------------------------------------------------------------

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

   ---------------------------------------------------------------------------

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a light grey background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

      -- Now show it
      Lumen.Window.Swap (Win);

   end Draw;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for keypresses and close-window events
   procedure Quit_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_Exit;
   end Quit_Handler;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

   ---------------------------------------------------------------------------

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotation >= Max_Rotation then
         Rotation := 0;
      else
         Rotation := Rotation + 1;
      end if;

      Draw;
   end New_Frame;

   ---------------------------------------------------------------------------

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Error with "You did not supply an image file pathname on the command line";
   end if;

   -- If other command-line arguments were given then process them
   for Index in 2 .. Ada.Command_Line.Argument_Count loop

      declare
         use Lumen.Window;
         Arg : String := Ada.Command_Line.Argument (Index);
      begin
         case Arg (Arg'First) is

            when 'a' =>
               Attrs (4) := (Attr_Alpha_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'c' =>
               Attrs (1) := (Attr_Red_Size,   Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (2) := (Attr_Blue_Size,  Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (3) := (Attr_Green_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'd' =>
               Attrs (5) := (Attr_Depth_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'n' =>
               Direct := False;

            when others =>
               null;

         end case;
      end;

   end loop;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Lumen.Window.Create (Win,
                        Name       => "Spinning Picture Demo",
                        Width      => Wide,
                        Height     => High,
                        Direct     => Direct,
                        Attributes => Attrs,
                        Events     => (Lumen.Window.Want_Key_Press => True,
                                       Lumen.Window.Want_Exposure  => True,
                                       others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

exception
   when Program_Exit =>
      null;  -- just exit this block, which terminates the app

end Texture;

-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Command_Line;
with System.Address_To_Access_Conversions;

with Lumen.Events.Animate;
with Lumen.Image;
with Lumen.Window;

with GL;
with GLU;

procedure Texture is

   ---------------------------------------------------------------------------

   -- Rotation wraps around at this point, in degrees
   Max_Rotation : constant := 359;

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

   ---------------------------------------------------------------------------

   Win      : Lumen.Window.Handle;
   Direct   : Boolean := True;  -- want direct rendering by default
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;

   Attrs    : Lumen.Window.Context_Attributes :=
      (
       (Lumen.Window.Attr_Red_Size,     8),
       (Lumen.Window.Attr_Green_Size,   8),
       (Lumen.Window.Attr_Blue_Size,    8),
       (Lumen.Window.Attr_Alpha_Size,   8),
       (Lumen.Window.Attr_Depth_Size,  24),
       (Lumen.Window.Attr_Stencil_Size, 8)
      );

   ---------------------------------------------------------------------------

   Program_Error : exception;

   ---------------------------------------------------------------------------

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values.all'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

   ---------------------------------------------------------------------------

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

   ---------------------------------------------------------------------------

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a light grey background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

      -- Now show it
      Lumen.Window.Swap (Win);

   end Draw;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for keypresses and close-window events
   procedure Quit_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Quit_Handler
      Lumen.Events.End_Events (Win);
   end Quit_Handler;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

   ---------------------------------------------------------------------------

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

   ---------------------------------------------------------------------------

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotation >= Max_Rotation then
         Rotation := 0;
      else
         Rotation := Rotation + 1;
      end if;

      Draw;
   end New_Frame;

   ---------------------------------------------------------------------------

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Error with "You did not supply an image file pathname on the command line";
   end if;

   -- If other command-line arguments were given then process them
   for Index in 2 .. Ada.Command_Line.Argument_Count loop

      declare
         use Lumen.Window;
         Arg : String := Ada.Command_Line.Argument (Index);
      begin
         case Arg (Arg'First) is

            when 'a' =>
               Attrs (4) := (Attr_Alpha_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'c' =>
               Attrs (1) := (Attr_Red_Size,   Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (2) := (Attr_Blue_Size,  Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));
               Attrs (3) := (Attr_Green_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'd' =>
               Attrs (5) := (Attr_Depth_Size, Integer'Value (Arg (Arg'First + 1 .. Arg'Last)));

            when 'n' =>
               Direct := False;

            when others =>
               null;

         end case;
      end;

   end loop;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Lumen.Window.Create (Win,
                        Name       => "Spinning Picture Demo",
                        Width      => Wide,
                        Height     => High,
                        Direct     => Direct,
                        Attributes => Attrs,
                        Events     => (Lumen.Window.Want_Key_Press => True,
                                       Lumen.Window.Want_Exposure  => True,
                                       others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop, which will terminate when the Quit_Handler calls End_Events
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

   -- Try these just to make sure they work
   Lumen.Window.Destroy_Context (Win);
   Lumen.Window.Destroy (Win);

end Texture;

Adjust this demo to use alternate method of ending an app, by calling End_Events