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

   overriding
   procedure Bind (Mapper : in out Default_Variable_Mapper;
                   Name   : in String;
                   Value  : in EL.Objects.Object) is
      Expr : constant EL.Expressions.Value_Expression
        := EL.Expressions.Create_ValueExpression (Value);
   begin
      Mapper.Map.Include (Key      => To_Unbounded_String (Name),
                          New_Item => EL.Expressions.Expression (Expr));
   end Bind;

   overriding
   function Get_Variable (Mapper : Default_Variable_Mapper;
                          Name   : Unbounded_String)
                          return EL.Expressions.Expression is
      C : constant Variable_Maps.Cursor := Mapper.Map.Find (Name);
   begin
      if not Variable_Maps.Has_Element (C) then
         if Mapper.Next_Mapper /= null then
            return Mapper.Next_Mapper.Get_Variable (Name);
         end if;
         --  Avoid raising an exception if we can't resolve a variable.
         --  Instead, return a null expression.  This speeds up the resolution and
         --  creation of Ada bean in ASF framework (cost of exception is high compared to this).
         return E : EL.Expressions.Expression;
      end if;
      return Variable_Maps.Element (C);
   end Get_Variable;

   overriding
   procedure Set_Variable (Mapper : in out Default_Variable_Mapper;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Expression) is
   begin
      Mapper.Map.Include (Key      => Name,
                          New_Item => Value);
   end Set_Variable;

   --  ------------------------------
   --  Set the next variable mapper that will be used to resolve a variable if
   --  the current variable mapper does not find a variable.
   --  ------------------------------
   procedure Set_Next_Variable_Mapper (Mapper      : in out Default_Variable_Mapper;
                                       Next_Mapper : in Variable_Mapper_Access) is
   begin
      Mapper.Next_Mapper := Next_Mapper;
   end Set_Next_Variable_Mapper;

end EL.Variables.Default;

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

   overriding
   procedure Bind (Mapper : in out Default_Variable_Mapper;
                   Name   : in String;
                   Value  : in EL.Objects.Object) is
      Expr : constant EL.Expressions.Value_Expression
        := EL.Expressions.Create_ValueExpression (Value);
   begin
      Mapper.Map.Include (Key      => To_Unbounded_String (Name),
                          New_Item => EL.Expressions.Expression (Expr));
   end Bind;

   overriding
   function Get_Variable (Mapper : Default_Variable_Mapper;
                          Name   : Unbounded_String)
                          return EL.Expressions.Expression is
      C : constant Variable_Maps.Cursor := Mapper.Map.Find (Name);
   begin
      if not Variable_Maps.Has_Element (C) then
         if Mapper.Next_Mapper /= null then
            return Mapper.Next_Mapper.all.Get_Variable (Name);
         end if;
         --  Avoid raising an exception if we can't resolve a variable.
         --  Instead, return a null expression.  This speeds up the resolution and
         --  creation of Ada bean in ASF framework (cost of exception is high compared to this).
         return E : EL.Expressions.Expression;
      end if;
      return Variable_Maps.Element (C);
   end Get_Variable;

   overriding
   procedure Set_Variable (Mapper : in out Default_Variable_Mapper;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Expression) is
   begin
      Mapper.Map.Include (Key      => Name,
                          New_Item => Value);
   end Set_Variable;

   --  ------------------------------
   --  Set the next variable mapper that will be used to resolve a variable if
   --  the current variable mapper does not find a variable.
   --  ------------------------------
   procedure Set_Next_Variable_Mapper (Mapper      : in out Default_Variable_Mapper;
                                       Next_Mapper : in Variable_Mapper_Access) is
   begin
      Mapper.Next_Mapper := Next_Mapper;
   end Set_Next_Variable_Mapper;

end EL.Variables.Default;

Fix Issue 1:build failed with gcc 4.7

Fix Issue 1:build failed with gcc 4.7


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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Permissions.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Access_Token;
                      Role : in Permissions.Role_Type) return Boolean;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is tagged private;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App     : in Application;
                                 Token   : in String;
                                 Expires : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Permissions.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is tagged private;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App     : in Application;
                                 Token   : in String;
                                 Expires : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Remove the Has_Role operation

Remove the Has_Role operation


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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with ADO.Parameters;
with ADO.Drivers.Dialects;

--  Utilities for creating SQL queries and statements.
package ADO.SQL is

   use Ada.Strings.Unbounded;

   --  --------------------
   --  Buffer
   --  --------------------
   --  The Buffer type allows to build easily an SQL statement.
   --
   type Buffer is private;
   type Buffer_Access is access all Buffer;

   --  Clear the SQL buffer.
   procedure Clear (Target : in out Buffer);

   --  Append an SQL extract into the buffer.
   procedure Append (Target : in out Buffer;
                     SQL    : in String);

   --  Append a name in the buffer and escape that
   --  name if this is a reserved keyword.
   procedure Append_Name (Target : in out Buffer;
                          Name   : in String);

   --  Append a string value in the buffer and
   --  escape any special character if necessary.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in String);

   --  Append a string value in the buffer and
   --  escape any special character if necessary.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Unbounded_String);

   --  Append the integer value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Long_Integer);

   --  Append the integer value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Integer);

   --  Append the identifier value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Identifier);

   --  Get the SQL string that was accumulated in the buffer.
   function To_String (From : in Buffer) return String;

   --  --------------------
   --  Query
   --  --------------------
   --  The Query type contains the elements for building and
   --  executing the request.  This includes:
   --

   --
The SQL request (full request or a fragment)

   --
The SQL request parameters

   --
An SQL filter condition

   --

   --
   type Query is new ADO.Parameters.List with record
      SQL    : Buffer;
      Filter : Buffer;
      Join   : Buffer;
   end record;
   type Query_Access is access all Query'Class;

   --  Clear the query object.
   overriding
   procedure Clear (Target : in out Query);

   --  Set the SQL dialect description object.
   procedure Set_Dialect (Target : in out Query;
                          D      : in ADO.Drivers.Dialects.Dialect_Access);

   procedure Set_Filter (Target : in out Query;
                         Filter : in String);

   function Has_Filter (Source : in Query) return Boolean;

   function Get_Filter (Source : in Query) return String;

   --  Set the join condition.
   procedure Set_Join (Target : in out Query;
                       Join   : in String);

   --  Returns true if there is a join condition
   function Has_Join (Source : in Query) return Boolean;

   --  Get the join condition
   function Get_Join (Source : in Query) return String;

   --  Set the parameters from another parameter list.
   --  If the parameter list is a query object, also copy the filter part.
   procedure Set_Parameters (Params : in out Query;
                             From   : in ADO.Parameters.Abstract_List'Class);

   --  Expand the parameters into the query and return the expanded SQL query.
   function Expand (Source : in Query) return String;

   --  --------------------
   --  Update Query
   --  --------------------
   --  The Update_Query provides additional helper functions to construct
   --  and insert or an update statement.
   type Update_Query is new Query with private;
   type Update_Query_Access is access all Update_Query'Class;

   --  Set the SQL dialect description object.
   procedure Set_Dialect (Target : in out Update_Query;
                          D      : in ADO.Drivers.Dialects.Dialect_Access);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Boolean);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Integer);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Long_Long_Integer);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Identifier);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Entity_Type);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Ada.Calendar.Time);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in String);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Unbounded_String);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in ADO.Blob_Ref);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to NULL.
   procedure Save_Null_Field (Update : in out Update_Query;
                              Name   : in String);

   --  Check if the update/insert query has some fields to update.
   function Has_Save_Fields (Update : in Update_Query) return Boolean;

   procedure Set_Insert_Mode (Update : in out Update_Query);

   procedure Append_Fields (Update : in out Update_Query;
                            Mode   : in Boolean := False);

private

   type Buffer is new ADO.Parameters.List with record
      Buf     : Unbounded_String;
   end record;

   type Update_Query is new Query with record
      Pos            : Natural := 0;
      Set_Fields     : Buffer;
      Fields         : Buffer;
      Is_Update_Stmt : Boolean := True;
   end record;

   procedure Add_Field (Update : in out Update_Query'Class;
                        Name   : in String);

end ADO.SQL;

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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with ADO.Parameters;
with ADO.Drivers.Dialects;

--  Utilities for creating SQL queries and statements.
package ADO.SQL is

   use Ada.Strings.Unbounded;

   --  --------------------
   --  Buffer
   --  --------------------
   --  The Buffer type allows to build easily an SQL statement.
   --
   type Buffer is private;
   type Buffer_Access is access all Buffer;

   --  Clear the SQL buffer.
   procedure Clear (Target : in out Buffer);

   --  Append an SQL extract into the buffer.
   procedure Append (Target : in out Buffer;
                     SQL    : in String);

   --  Append a name in the buffer and escape that
   --  name if this is a reserved keyword.
   procedure Append_Name (Target : in out Buffer;
                          Name   : in String);

   --  Append a string value in the buffer and
   --  escape any special character if necessary.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in String);

   --  Append a string value in the buffer and
   --  escape any special character if necessary.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Unbounded_String);

   --  Append the integer value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Long_Integer);

   --  Append the integer value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Integer);

   --  Append the identifier value in the buffer.
   procedure Append_Value (Target : in out Buffer;
                           Value  : in Identifier);

   --  Get the SQL string that was accumulated in the buffer.
   function To_String (From : in Buffer) return String;

   --  --------------------
   --  Query
   --  --------------------
   --  The Query type contains the elements for building and
   --  executing the request.  This includes:
   --

   --
The SQL request (full request or a fragment)

   --
The SQL request parameters

   --
An SQL filter condition

   --

   --
   type Query is new ADO.Parameters.List with record
      SQL    : Buffer;
      Filter : Buffer;
      Join   : Buffer;
   end record;
   type Query_Access is access all Query'Class;

   --  Clear the query object.
   overriding
   procedure Clear (Target : in out Query);

   --  Set the SQL dialect description object.
   procedure Set_Dialect (Target : in out Query;
                          D      : in ADO.Drivers.Dialects.Dialect_Access);

   procedure Set_Filter (Target : in out Query;
                         Filter : in String);

   function Has_Filter (Source : in Query) return Boolean;

   function Get_Filter (Source : in Query) return String;

   --  Set the join condition.
   procedure Set_Join (Target : in out Query;
                       Join   : in String);

   --  Returns true if there is a join condition
   function Has_Join (Source : in Query) return Boolean;

   --  Get the join condition
   function Get_Join (Source : in Query) return String;

   --  Set the parameters from another parameter list.
   --  If the parameter list is a query object, also copy the filter part.
   procedure Set_Parameters (Params : in out Query;
                             From   : in ADO.Parameters.Abstract_List'Class);

   --  Expand the parameters into the query and return the expanded SQL query.
   function Expand (Source : in Query) return String;

   --  --------------------
   --  Update Query
   --  --------------------
   --  The Update_Query provides additional helper functions to construct
   --  and insert or an update statement.
   type Update_Query is new Query with private;
   type Update_Query_Access is access all Update_Query'Class;

   --  Set the SQL dialect description object.
   procedure Set_Dialect (Target : in out Update_Query;
                          D      : in ADO.Drivers.Dialects.Dialect_Access);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Boolean);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Integer);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Long_Long_Integer);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Long_Float);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Identifier);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Entity_Type);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Ada.Calendar.Time);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in String);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in Unbounded_String);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to the Value.
   procedure Save_Field (Update : in out Update_Query;
                         Name   : in String;
                         Value  : in ADO.Blob_Ref);

   --  Prepare the update/insert query to save the table field
   --  identified by Name and set it to NULL.
   procedure Save_Null_Field (Update : in out Update_Query;
                              Name   : in String);

   --  Check if the update/insert query has some fields to update.
   function Has_Save_Fields (Update : in Update_Query) return Boolean;

   procedure Set_Insert_Mode (Update : in out Update_Query);

   procedure Append_Fields (Update : in out Update_Query;
                            Mode   : in Boolean := False);

private

   type Buffer is new ADO.Parameters.List with record
      Buf     : Unbounded_String;
   end record;

   type Update_Query is new Query with record
      Pos            : Natural := 0;
      Set_Fields     : Buffer;
      Fields         : Buffer;
      Is_Update_Stmt : Boolean := True;
   end record;

   procedure Add_Field (Update : in out Update_Query'Class;
                        Name   : in String);

end ADO.SQL;

Declare a Save_Field procedure with a Long_Float type


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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");
         Util.Tests.Assert_Equals (T, T1,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date 3");

         T.Assert (T2 >= S1.Get_Start_Date.Value, "Start date is invalid 1");
         T.Assert (T1 <= S1.Get_Start_Date.Value + 1.0, "Start date is invalid 2");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");
         T.Assert (S1.Get_Start_Date.Value >= T1, "Start date is invalid 1");

         T.Assert (S1.Get_Start_Date.Value >= T2, "Start date is invalid 2");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

Fix test check on dates

Fix test check on dates


-----------------------------------------------------------------------
--  EL.Beans -- Interface Definition with Getter and Setters
--  Copyright (C) 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 EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is interface and Readonly_Bean;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Set the current row index.  Valid row indexes start at 1.
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is abstract;

   --  Get the element at the current row index.
   function Get_Row (From  : List_Bean) return EL.Objects.Object is abstract;

end EL.Beans;

-----------------------------------------------------------------------
--  EL.Beans -- Interface Definition with Getter and Setters
--  Copyright (C) 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 EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is limited interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is limited interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is limited interface and Readonly_Bean;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Set the current row index.  Valid row indexes start at 1.
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is abstract;

   --  Get the element at the current row index.
   function Get_Row (From  : List_Bean) return EL.Objects.Object is abstract;

end EL.Beans;

Make the interface limited to allow limited types to implement the bean interfaces.


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

with ASF.Server.Tests;

with Util.Log.Loggers;

with ASF.Tests;

with AWA.Applications.Factory;
with AWA.Tests.Helpers.Users;
package body AWA.Tests is

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

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   --  ------------------------------
   --  Cleanup after the test execution.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      pragma Unreferenced (T);
   begin
      AWA.Tests.Helpers.Users.Tear_Down;
   end Tear_Down;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Application.Close;
         Free (Application);
      end if;
      ASF.Tests.Finish (Status);
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      pragma Unreferenced (Add_Modules);
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new Test_Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name => "files", Server => App.Files'Unchecked_Access);
      App.Add_Servlet (Name => "ajax", Server => App.Ajax'Unchecked_Access);
      App.Add_Servlet (Name => "measures", Server => App.Measures'Unchecked_Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Dump'Unchecked_Access);
      App.Add_Filter (Name => "measures", Filter => App.Measures'Unchecked_Access);
      App.Add_Filter (Name => "service", Filter => App.Service_Filter'Unchecked_Access);
   end Initialize_Filters;

end AWA.Tests;

-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 2011, 2012, 2013, 2014, 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 Ada.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with ASF.Tests;

with Servlet.Tests;
with AWA.Applications.Factory;
with AWA.Tests.Helpers.Users;
package body AWA.Tests is

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

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Servlet.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   --  ------------------------------
   --  Cleanup after the test execution.
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      pragma Unreferenced (T);
   begin
      AWA.Tests.Helpers.Users.Tear_Down;
   end Tear_Down;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Application.Close;
         Free (Application);
      end if;
      ASF.Tests.Finish (Status);
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      pragma Unreferenced (Add_Modules);
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new Test_Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      Servlet.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name => "files", Server => App.Files'Unchecked_Access);
      App.Add_Servlet (Name => "ajax", Server => App.Ajax'Unchecked_Access);
      App.Add_Servlet (Name => "measures", Server => App.Measures'Unchecked_Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Test_Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Dump'Unchecked_Access);
      App.Add_Filter (Name => "measures", Filter => App.Measures'Unchecked_Access);
      App.Add_Filter (Name => "service", Filter => App.Service_Filter'Unchecked_Access);
   end Initialize_Filters;

end AWA.Tests;

Update to use the Servlet package instead of ASF.Servlet


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

with System.Multiprocessors.Dispatching_Domains;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;

with Orka.Futures;
with Orka.Loggers;
with Orka.Logging;
with Orka.Simulation_Jobs;

package body Orka.Loops is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Game_Loop);

   procedure Free is new Ada.Unchecked_Deallocation
     (Behaviors.Behavior_Array, Behaviors.Behavior_Array_Access);

   function "<" (Left, Right : Behaviors.Behavior_Ptr) return Boolean is
      function Convert is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Long_Integer);
   begin
      return Convert (Left.all'Address) < Convert (Right.all'Address);
   end "<";

   protected body Handler is
      procedure Stop is
      begin
         Stop_Flag := True;
      end Stop;

      procedure Set_Frame_Limit (Value : Time_Span) is
      begin
         Limit := Value;
      end Set_Frame_Limit;

      function Frame_Limit return Time_Span is (Limit);

      procedure Enable_Limit (Enable : Boolean) is
      begin
         Limit_Flag := Enable;
      end Enable_Limit;

      function Limit_Enabled return Boolean is (Limit_Flag);

      function Should_Stop return Boolean is (Stop_Flag);
   end Handler;

   protected body Scene is
      procedure Add (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Insert (Object);
         Modified_Flag := True;
      end Add;

      procedure Remove (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Delete (Object);
         Modified_Flag := True;
      end Remove;

      procedure Replace_Array (Target : in out Behaviors.Behavior_Array_Access) is
         pragma Assert (Modified);

         Index : Positive := 1;
         Count : constant Positive := Positive (Behaviors_Set.Length);
      begin
         Free (Target);
         Target := new Behaviors.Behavior_Array'(1 .. Count => Behaviors.Null_Behavior);

         --  Copy the elements from the set to the array
         --  for faster iteration by the game loop
         for Element of Behaviors_Set loop
            Target (Index) := Element;
            Index := Index + 1;
         end loop;

         Modified_Flag := False;
      end Replace_Array;

      function Modified return Boolean is
        (Modified_Flag);

      procedure Set_Camera (Camera : Cameras.Camera_Ptr) is
      begin
         Scene_Camera := Camera;
      end Set_Camera;

      function Camera return Cameras.Camera_Ptr is
        (Scene_Camera);
   end Scene;

   package SJ renames Simulation_Jobs;

   procedure Stop_Loop is
   begin
      Handler.Stop;
   end Stop_Loop;

   procedure Run_Game_Loop (Fence : not null access SJ.Fences.Buffer_Fence) is
      Previous_Time : Time := Clock;
      Next_Time     : Time := Previous_Time;

      Lag : Time_Span := Time_Span_Zero;

      Scene_Array : not null Behaviors.Behavior_Array_Access := Behaviors.Empty_Behavior_Array;
      Batch_Length : constant := 10;

      One_Second  : constant Time_Span := Seconds (1);

      Frame_Counter          : Natural := 0;
      Exceeded_Frame_Counter : Natural := 0;
      Clock_FPS_Start : Time := Clock;

      Stat_Sum : Time_Span := Time_Span_Zero;
      Stat_Min : Duration  := To_Duration (One_Second);
      Stat_Max : Duration  := To_Duration (-One_Second);
   begin
      Scene.Replace_Array (Scene_Array);

      Messages.Log (Debug, "Simulation tick resolution: " & Trim (Image (Tick)));

      --  Based on http://gameprogrammingpatterns.com/game-loop.html
      loop
         declare
            Current_Time : constant Time := Clock;
            Elapsed : constant Time_Span := Current_Time - Previous_Time;
         begin
            Previous_Time := Current_Time;
            Lag := Lag + Elapsed;

            exit when Handler.Should_Stop;

            declare
               Iterations : constant Natural := Lag / Time_Step;
            begin
               Lag := Lag - Iterations * Time_Step;
               Scene.Camera.Update (To_Duration (Lag));

               declare
                  Fixed_Update_Job : constant Jobs.Job_Ptr
                    := Jobs.Parallelize (SJ.Create_Fixed_Update_Job
                         (Scene_Array, Time_Step, Iterations),
                         SJ.Clone_Fixed_Update_Job'Access,
                         Scene_Array'Length, Batch_Length);

                  Finished_Job : constant Jobs.Job_Ptr := SJ.Create_Finished_Job
                    (Scene_Array, Time_Step, Scene.Camera.View_Position, Batch_Length);

                  Render_Scene_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Scene_Render_Job (Render, Scene_Array, Scene.Camera);

                  Render_Start_Job  : constant Jobs.Job_Ptr
                    := SJ.Create_Start_Render_Job (Fence, Window);
                  Render_Finish_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Finish_Render_Job (Fence, Window,
                      Stop_Loop'Unrestricted_Access);

                  Handle : Futures.Pointers.Mutable_Pointer;
                  Status : Futures.Status;
               begin
                  Orka.Jobs.Chain
                    ((Render_Start_Job, Fixed_Update_Job, Finished_Job,
                      Render_Scene_Job, Render_Finish_Job));

                  Job_Manager.Queue.Enqueue (Render_Start_Job, Handle);

                  declare
                     Frame_Future : constant Orka.Futures.Future_Access := Handle.Get.Value;
                  begin
                     select
                        Frame_Future.Wait_Until_Done (Status);
                     or
                        delay until Current_Time + Maximum_Frame_Time;
                        raise Program_Error with
                          "Maximum frame time of " & Trim (Image (Maximum_Frame_Time)) &
                          " exceeded";
                     end select;
                  end;
               end;
            end;

            if Scene.Modified then
               Scene.Replace_Array (Scene_Array);
            end if;

            declare
               Total_Elapsed  : constant Time_Span := Clock - Clock_FPS_Start;
               Limit_Exceeded : constant Time_Span := Elapsed - Handler.Frame_Limit;
            begin
               Frame_Counter := Frame_Counter + 1;

               if Limit_Exceeded > Time_Span_Zero then
                  Stat_Sum := Stat_Sum + Limit_Exceeded;
                  Stat_Min := Duration'Min (Stat_Min, To_Duration (Limit_Exceeded));
                  Stat_Max := Duration'Max (Stat_Max, To_Duration (Limit_Exceeded));
                  Exceeded_Frame_Counter := Exceeded_Frame_Counter + 1;
               end if;

               if Total_Elapsed > One_Second then
                  declare
                     FPS : constant Duration
                       := Duration (Frame_Counter) / To_Duration (Total_Elapsed);
                  begin
                     Messages.Log (Debug, "FPS: " & Trim (FPS'Image));
                  end;

                  if Exceeded_Frame_Counter > 0 then
                     declare
                        Avg : constant Time_Span := Stat_Sum / Exceeded_Frame_Counter;
                     begin
                        Messages.Log (Debug, "Frame time limit (" &
                          Trim (Image (Handler.Frame_Limit)) & ") exceeded " &
                          Trim (Exceeded_Frame_Counter'Image) & " times by:");
                        Messages.Log (Debug, "  avg: " & Image (Avg));
                        Messages.Log (Debug, "  min: " & Image (To_Time_Span (Stat_Min)));
                        Messages.Log (Debug, "  max: " & Image (To_Time_Span (Stat_Max)));
                     end;
                  end if;

                  Clock_FPS_Start := Clock;
                  Frame_Counter          := 0;
                  Exceeded_Frame_Counter := 0;

                  Stat_Sum := Time_Span_Zero;
                  Stat_Min := To_Duration (One_Second);
                  Stat_Max := To_Duration (Time_Span_Zero);
               end if;
            end;

            if Handler.Limit_Enabled then
               --  Do not sleep if Next_Time fell behind more than one frame
               --  due to high workload (FPS dropping below limit), otherwise
               --  the FPS will be exceeded during a subsequent low workload
               --  until Next_Time has catched up
               if Next_Time < Current_Time - Handler.Frame_Limit then
                  Next_Time := Current_Time;
               else
                  Next_Time := Next_Time + Handler.Frame_Limit;
                  delay until Next_Time;
               end if;
            end if;
         end;
      end loop;

      Job_Manager.Shutdown;
   exception
      when others =>
         Job_Manager.Shutdown;
         raise;
   end Run_Game_Loop;

   procedure Run_Loop is
      Fence : aliased SJ.Fences.Buffer_Fence := SJ.Fences.Create_Buffer_Fence;
   begin
      declare
         --  Create a separate task for the game loop. The current task
         --  will be used to dequeue and execute GPU jobs.
         task Simulation;

         use Ada.Exceptions;

         task body Simulation is
         begin
            System.Multiprocessors.Dispatching_Domains.Set_CPU (1);
            Run_Game_Loop (Fence'Unchecked_Access);
         exception
            when Error : others =>
               Messages.Log (Loggers.Error, Exception_Information (Error));
         end Simulation;
      begin
         System.Multiprocessors.Dispatching_Domains.Set_CPU (1);

         --  Execute GPU jobs in the current task
         Job_Manager.Execute_GPU_Jobs;
      end;
   end Run_Loop;

end Orka.Loops;

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

with System.Multiprocessors.Dispatching_Domains;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;

with Orka.Futures;
with Orka.Loggers;
with Orka.Logging;
with Orka.Simulation_Jobs;

package body Orka.Loops is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Game_Loop);

   procedure Free is new Ada.Unchecked_Deallocation
     (Behaviors.Behavior_Array, Behaviors.Behavior_Array_Access);

   function "<" (Left, Right : Behaviors.Behavior_Ptr) return Boolean is
      function Convert is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Long_Integer);
   begin
      return Convert (Left.all'Address) < Convert (Right.all'Address);
   end "<";

   protected body Handler is
      procedure Stop is
      begin
         Stop_Flag := True;
      end Stop;

      procedure Set_Frame_Limit (Value : Time_Span) is
      begin
         Limit := Value;
      end Set_Frame_Limit;

      function Frame_Limit return Time_Span is (Limit);

      procedure Enable_Limit (Enable : Boolean) is
      begin
         Limit_Flag := Enable;
      end Enable_Limit;

      function Limit_Enabled return Boolean is (Limit_Flag);

      function Should_Stop return Boolean is (Stop_Flag);
   end Handler;

   protected body Scene is
      procedure Add (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Insert (Object);
         Modified_Flag := True;
      end Add;

      procedure Remove (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Delete (Object);
         Modified_Flag := True;
      end Remove;

      procedure Replace_Array (Target : in out Behaviors.Behavior_Array_Access) is
         pragma Assert (Modified);

         Index : Positive := 1;
         Count : constant Positive := Positive (Behaviors_Set.Length);
      begin
         Free (Target);
         Target := new Behaviors.Behavior_Array'(1 .. Count => Behaviors.Null_Behavior);

         --  Copy the elements from the set to the array
         --  for faster iteration by the game loop
         for Element of Behaviors_Set loop
            Target (Index) := Element;
            Index := Index + 1;
         end loop;

         Modified_Flag := False;
      end Replace_Array;

      function Modified return Boolean is
        (Modified_Flag);

      procedure Set_Camera (Camera : Cameras.Camera_Ptr) is
      begin
         Scene_Camera := Camera;
      end Set_Camera;

      function Camera return Cameras.Camera_Ptr is
        (Scene_Camera);
   end Scene;

   package SJ renames Simulation_Jobs;

   procedure Stop_Loop is
   begin
      Handler.Stop;
   end Stop_Loop;

   procedure Run_Game_Loop (Fence : not null access SJ.Fences.Buffer_Fence) is
      Previous_Time : Time := Clock;
      Next_Time     : Time := Previous_Time;

      Lag : Time_Span := Time_Span_Zero;

      Scene_Array : not null Behaviors.Behavior_Array_Access := Behaviors.Empty_Behavior_Array;
      Batch_Length : constant := 10;

      One_Second  : constant Time_Span := Seconds (1);

      Frame_Counter          : Natural := 0;
      Exceeded_Frame_Counter : Natural := 0;
      Clock_FPS_Start : Time := Clock;

      Stat_Sum : Time_Span := Time_Span_Zero;
      Stat_Min : Duration  := To_Duration (One_Second);
      Stat_Max : Duration  := To_Duration (-One_Second);
   begin
      Scene.Replace_Array (Scene_Array);

      Messages.Log (Debug, "Simulation tick resolution: " & Trim (Image (Tick)));

      --  Based on http://gameprogrammingpatterns.com/game-loop.html
      loop
         declare
            Current_Time : constant Time := Clock;
            Elapsed : constant Time_Span := Current_Time - Previous_Time;
         begin
            Previous_Time := Current_Time;
            Lag := Lag + Elapsed;

            exit when Handler.Should_Stop;

            declare
               Iterations : constant Natural := Lag / Time_Step;
            begin
               Lag := Lag - Iterations * Time_Step;
               Scene.Camera.Update (To_Duration (Lag));

               declare
                  Fixed_Update_Job : constant Jobs.Job_Ptr
                    := Jobs.Parallelize (SJ.Create_Fixed_Update_Job
                         (Scene_Array, Time_Step, Iterations),
                         SJ.Clone_Fixed_Update_Job'Access,
                         Scene_Array'Length, Batch_Length);

                  Finished_Job : constant Jobs.Job_Ptr := SJ.Create_Finished_Job
                    (Scene_Array, Time_Step, Scene.Camera.View_Position, Batch_Length);

                  Render_Scene_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Scene_Render_Job (Render, Scene_Array, Scene.Camera);

                  Render_Start_Job  : constant Jobs.Job_Ptr
                    := SJ.Create_Start_Render_Job (Fence, Window);
                  Render_Finish_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Finish_Render_Job (Fence, Window,
                      Stop_Loop'Unrestricted_Access);

                  Handle : Futures.Pointers.Mutable_Pointer;
                  Status : Futures.Status;
               begin
                  Orka.Jobs.Chain
                    ((Render_Start_Job, Fixed_Update_Job, Finished_Job,
                      Render_Scene_Job, Render_Finish_Job));

                  Job_Manager.Queue.Enqueue (Render_Start_Job, Handle);

                  declare
                     Frame_Future : constant Orka.Futures.Future_Access := Handle.Get.Value;
                  begin
                     select
                        Frame_Future.Wait_Until_Done (Status);
                     or
                        delay until Current_Time + Maximum_Frame_Time;
                        raise Program_Error with
                          "Maximum frame time of " & Trim (Image (Maximum_Frame_Time)) &
                          " exceeded";
                     end select;
                  end;
               end;
            end;

            if Scene.Modified then
               Scene.Replace_Array (Scene_Array);
            end if;

            declare
               Total_Elapsed  : constant Time_Span := Clock - Clock_FPS_Start;
               Limit_Exceeded : constant Time_Span := Elapsed - Handler.Frame_Limit;
            begin
               Frame_Counter := Frame_Counter + 1;

               if Limit_Exceeded > Time_Span_Zero then
                  Stat_Sum := Stat_Sum + Limit_Exceeded;
                  Stat_Min := Duration'Min (Stat_Min, To_Duration (Limit_Exceeded));
                  Stat_Max := Duration'Max (Stat_Max, To_Duration (Limit_Exceeded));
                  Exceeded_Frame_Counter := Exceeded_Frame_Counter + 1;
               end if;

               if Total_Elapsed > One_Second then
                  declare
                     Frame_Time : constant Time_Span := Total_Elapsed / Frame_Counter;
                     FPS        : constant Integer   := Integer (1.0 / To_Duration (Frame_Time));
                  begin
                     Messages.Log (Debug, Trim (FPS'Image) & " FPS, frame time: " &
                       Trim (Image (Frame_Time)));
                  end;

                  if Exceeded_Frame_Counter > 0 then
                     declare
                        Stat_Avg : constant Time_Span := Stat_Sum / Exceeded_Frame_Counter;
                     begin
                        Messages.Log (Debug, "  deadline missed: " &
                          Trim (Exceeded_Frame_Counter'Image) & " (limit is " &
                          Trim (Image (Handler.Frame_Limit)) & ")");
                        Messages.Log (Debug, "    avg/min/max: " &
                          Image (Stat_Avg) &
                          Image (To_Time_Span (Stat_Min)) &
                          Image (To_Time_Span (Stat_Max)));
                     end;
                  end if;

                  Clock_FPS_Start := Clock;
                  Frame_Counter          := 0;
                  Exceeded_Frame_Counter := 0;

                  Stat_Sum := Time_Span_Zero;
                  Stat_Min := To_Duration (One_Second);
                  Stat_Max := To_Duration (Time_Span_Zero);
               end if;
            end;

            if Handler.Limit_Enabled then
               --  Do not sleep if Next_Time fell behind more than one frame
               --  due to high workload (FPS dropping below limit), otherwise
               --  the FPS will be exceeded during a subsequent low workload
               --  until Next_Time has catched up
               if Next_Time < Current_Time - Handler.Frame_Limit then
                  Next_Time := Current_Time;
               else
                  Next_Time := Next_Time + Handler.Frame_Limit;
                  delay until Next_Time;
               end if;
            end if;
         end;
      end loop;

      Job_Manager.Shutdown;
   exception
      when others =>
         Job_Manager.Shutdown;
         raise;
   end Run_Game_Loop;

   procedure Run_Loop is
      Fence : aliased SJ.Fences.Buffer_Fence := SJ.Fences.Create_Buffer_Fence;
   begin
      declare
         --  Create a separate task for the game loop. The current task
         --  will be used to dequeue and execute GPU jobs.
         task Simulation;

         use Ada.Exceptions;

         task body Simulation is
         begin
            System.Multiprocessors.Dispatching_Domains.Set_CPU (1);
            Run_Game_Loop (Fence'Unchecked_Access);
         exception
            when Error : others =>
               Messages.Log (Loggers.Error, Exception_Information (Error));
         end Simulation;
      begin
         System.Multiprocessors.Dispatching_Domains.Set_CPU (1);

         --  Execute GPU jobs in the current task
         Job_Manager.Execute_GPU_Jobs;
      end;
   end Run_Loop;

end Orka.Loops;

orka: Change formatting of FPS and frame time in log messages

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