-----------------------------------------------------------------------
--  awa-storages-servlets -- Serve files saved in the storage service
--  Copyright (C) 2012, 2016, 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 Util.Log.Loggers;

with ADO.Objects;

with Servlet.Routes;
with ASF.Streams;

with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Storages.Servlets is

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

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Storage_Servlet;
                         Context : in Servlet.Core.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Storage_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      type Get_Type is (DEFAULT, AS_CONTENT_DISPOSITION, INVALID);

      function Get_Format return Get_Type;

      function Get_Format return Get_Type is
         Format : constant String := Request.Get_Path_Parameter (2);
      begin
         if Format = "view" then
            return DEFAULT;
         elsif Format = "download" then
            return AS_CONTENT_DISPOSITION;
         else
            return INVALID;
         end if;
      end Get_Format;

      URI     : constant String := Request.Get_Request_URI;
      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
      Format  : Get_Type;
   begin
      Format := Get_Format;
      if Format = INVALID then
         Log.Info ("GET: {0}: invalid format", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      Storage_Servlet'Class (Server).Load (Request, Name, Mime, Date, Data);
      if Data.Is_Null then
         Log.Info ("GET: {0}: storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      Log.Info ("GET: {0}", URI);

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      if Format = AS_CONTENT_DISPOSITION and Ada.Strings.Unbounded.Length (Name) > 0 then
         Response.Add_Header ("Content-Disposition",
                              "attachment; filename=" & Ada.Strings.Unbounded.To_String (Name));
      end if;
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when Servlet.Routes.No_Parameter =>
         Log.Info ("GET: {0}: Invalid servlet-mapping, a path parameter is missing", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;

      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("GET: {0}: Storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   procedure Load (Server   : in Storage_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
      pragma Unreferenced (Server);

      Store   : constant String := Request.Get_Path_Parameter (1);
      Manager : constant Services.Storage_Service_Access := Storages.Modules.Get_Storage_Manager;
      Id      : ADO.Identifier;
   begin
      if Store'Length = 0 then
         Log.Info ("Invalid storage URI: {0}", Store);
         return;
      end if;

      --  Extract the storage identifier from the URI.
      Id := ADO.Identifier'Value (Store);

      Log.Info ("GET storage file {0}", Store);
      Manager.Load (From => Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
   end Load;

end AWA.Storages.Servlets;

-----------------------------------------------------------------------
--  awa-storages-servlets -- Serve files saved in the storage service
--  Copyright (C) 2012, 2016, 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 Util.Log.Loggers;

with ADO.Objects;

with Servlet.Routes;
with ASF.Streams;

with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Storages.Servlets is

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

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Storage_Servlet;
                         Context : in Servlet.Core.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Storage_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      URI     : constant String := Request.Get_Request_URI;
      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
      Format  : Get_Type;
   begin
      Format := Storage_Servlet'Class (Server).Get_Format (Request);
      if Format = INVALID then
         Log.Info ("GET: {0}: invalid format", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      Storage_Servlet'Class (Server).Load (Request, Name, Mime, Date, Data);
      if Data.Is_Null then
         Log.Info ("GET: {0}: storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      Log.Info ("GET: {0}", URI);

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      if Format = AS_CONTENT_DISPOSITION and Ada.Strings.Unbounded.Length (Name) > 0 then
         Response.Add_Header ("Content-Disposition",
                              "attachment; filename=" & Ada.Strings.Unbounded.To_String (Name));
      end if;
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when Servlet.Routes.No_Parameter =>
         Log.Info ("GET: {0}: Invalid servlet-mapping, a path parameter is missing", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;

      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("GET: {0}: Storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   procedure Load (Server   : in Storage_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
      pragma Unreferenced (Server);

      Store   : constant String := Request.Get_Path_Parameter (1);
      Manager : constant Services.Storage_Service_Access := Storages.Modules.Get_Storage_Manager;
      Id      : ADO.Identifier;
   begin
      if Store'Length = 0 then
         Log.Info ("Invalid storage URI: {0}", Store);
         return;
      end if;

      --  Extract the storage identifier from the URI.
      Id := ADO.Identifier'Value (Store);

      Log.Info ("GET storage file {0}", Store);
      Manager.Load (From => Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
   end Load;

   --  ------------------------------
   --  Get the expected return mode (content disposition for download or inline).
   --  ------------------------------
   function Get_Format (Server   : in Storage_Servlet;
                        Request  : in ASF.Requests.Request'Class) return Get_Type is
      pragma Unreferenced (Server);

      Format : constant String := Request.Get_Path_Parameter (2);
   begin
      if Format = "view" then
         return DEFAULT;
      elsif Format = "download" then
         return AS_CONTENT_DISPOSITION;
      else
         return INVALID;
      end if;
   end Get_Format;

end AWA.Storages.Servlets;

Move the internal Get_Format function a visible and overridable function of Storage_Servlet


-----------------------------------------------------------------------
--  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 Util.Strings;
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 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;

Fix compilation warning

Fix compilation warning


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

with Ada.Strings.Unbounded;

with Util.Strings;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Objects;
with EL.Expressions;
with EL.Contexts.Default;
with EL.Contexts.Properties;
package body EL.Utils is

   use Util.Log;
   use Ada.Strings.Unbounded;
   use Util.Beans.Objects;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("EL.Utils");

   --  ------------------------------
   --  Expand the properties stored in Source by evaluating the EL expressions
   --  used in the property values.  The EL context passed in Context can be used
   --  to specify the EL functions or some pre-defined beans that could be used.
   --  The EL context will integrate the source properties as well as properties stored
   --  in Into (only the Source properties will be evaluated).
   --  ------------------------------
   procedure Expand (Source  : in Util.Properties.Manager'Class;
                     Into    : in out Util.Properties.Manager'Class;
                     Context : in EL.Contexts.ELContext'Class) is

      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object;

      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      procedure Process (Name, Item : in Util.Properties.Value);

      type Local_Resolver is new EL.Contexts.Properties.Property_Resolver with null record;

      --  Get the value associated with a base object and a given property.
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object is
         pragma Unreferenced (Resolver);
      begin
         if Base /= null then
            return Base.Get_Value (To_String (Name));

         elsif Into.Exists (Name) then
            return Util.Beans.Objects.To_Object (String '(Into.Get (Name)));

         elsif Source.Exists (Name) then
            declare
               Value  : constant String := Source.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end Get_Value;

      Recursion : Natural := 10;

      --  ------------------------------
      --  Expand (recursively) the EL expression defined in Value by using
      --  the context.  The recursion is provided by the above context resolver which
      --  invokes Expand if it detects that a value is a possible EL expression.
      --  ------------------------------
      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object is
         Expr   : EL.Expressions.Expression;
         Result : Util.Beans.Objects.Object;
      begin
         if Recursion = 0 then
            Log.Error ("Too many level of recursion when evaluating expression: {0}", Value);
            return Util.Beans.Objects.Null_Object;
         end if;

         Recursion := Recursion - 1;
         Expr := EL.Expressions.Create_Expression (Value, Context);
         Result := Expr.Get_Value (Context);
         Recursion := Recursion + 1;
         return Result;

         --  Ignore any exception and copy the value verbatim.
      exception
         when others =>
            Recursion := Recursion + 1;
            return Util.Beans.Objects.To_Object (Value);
      end Expand;

      Resolver       : aliased Local_Resolver;
      Local_Context  : aliased EL.Contexts.Default.Default_Context;

      --  ------------------------------
      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      --  ------------------------------
      procedure Process (Name, Item : in Util.Properties.Value) is
         use Ada.Strings;
      begin
         if Unbounded.Index (Item, "{") = 0 or Unbounded.Index (Item, "{") = 0 then
            Log.Debug ("Adding config {0} = {1}", Name, Item);

            Into.Set (Name, Item);
         else
            declare
               Value : constant Object := Expand (To_String (Item), Local_Context);
               Val   : Unbounded_String;
            begin
               if not Util.Beans.Objects.Is_Null (Value) then
                  Val := Util.Beans.Objects.To_Unbounded_String (Value);
               end if;
               Log.Debug ("Adding config {0} = {1}", Name, Val);
               Into.Set (Name, Val);
            end;
         end if;
      end Process;

   begin
      Resolver.Set_Properties (Source);
      Local_Context.Set_Function_Mapper (Context.Get_Function_Mapper);
      Local_Context.Set_Resolver (Resolver'Unchecked_Access);

      Source.Iterate (Process'Access);
   end Expand;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return the
   --  string that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return String is
      Expr   : EL.Expressions.Expression;
      Result : Util.Beans.Objects.Object;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      Result := Expr.Get_Value (Context);
      return Util.Beans.Objects.To_String (Result);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
      Expr   : EL.Expressions.Expression;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      return Expr.Get_Value (Context);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Util.Beans.Objects.To_Object (Value);
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in Util.Beans.Objects.Object;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when Util.Beans.Objects.TYPE_STRING | Util.Beans.Objects.TYPE_WIDE_STRING =>
            declare
               S    : constant String := Util.Beans.Objects.To_String (Value);
               Expr : EL.Expressions.Expression;
            begin
               Expr := EL.Expressions.Create_Expression (S, Context);
               return Expr.Get_Value (Context);
            end;

         when others =>
            return Value;
      end case;

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

end EL.Utils;

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

with Ada.Strings.Unbounded;

with Util.Strings;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Objects;
with EL.Expressions;
with EL.Contexts.Default;
with EL.Contexts.Properties;
package body EL.Utils is

   use Util.Log;
   use Ada.Strings.Unbounded;
   use Util.Beans.Objects;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("EL.Utils");

   --  ------------------------------
   --  Expand the properties stored in Source by evaluating the EL expressions
   --  used in the property values.  The EL context passed in Context can be used
   --  to specify the EL functions or some pre-defined beans that could be used.
   --  The EL context will integrate the source properties as well as properties stored
   --  in Into (only the Source properties will be evaluated).
   --  ------------------------------
   procedure Expand (Source  : in Util.Properties.Manager'Class;
                     Into    : in out Util.Properties.Manager'Class;
                     Context : in EL.Contexts.ELContext'Class) is

      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object;

      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      procedure Process (Name, Item : in Util.Properties.Value);

      type Local_Resolver is new EL.Contexts.Properties.Property_Resolver with null record;

      --  Get the value associated with a base object and a given property.
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : in Local_Resolver;
                          Context  : in EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : in Unbounded_String) return EL.Objects.Object is
         pragma Unreferenced (Resolver);
      begin
         if Base /= null then
            return Base.Get_Value (To_String (Name));

         elsif Into.Exists (Name) then
            declare
               Value  : constant String := Into.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         elsif Source.Exists (Name) then
            declare
               Value  : constant String := Source.Get (Name);
            begin
               if Util.Strings.Index (Value, '{') = 0 or Util.Strings.Index (Value, '}') = 0 then
                  return Util.Beans.Objects.To_Object (Value);
               end if;

               return Expand (Value, Context);
            end;

         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end Get_Value;

      Recursion : Natural := 10;

      --  ------------------------------
      --  Expand (recursively) the EL expression defined in Value by using
      --  the context.  The recursion is provided by the above context resolver which
      --  invokes Expand if it detects that a value is a possible EL expression.
      --  ------------------------------
      function Expand (Value   : in String;
                       Context : in EL.Contexts.ELContext'Class) return EL.Objects.Object is
         Expr   : EL.Expressions.Expression;
         Result : Util.Beans.Objects.Object;
      begin
         if Recursion = 0 then
            Log.Error ("Too many level of recursion when evaluating expression: {0}", Value);
            return Util.Beans.Objects.Null_Object;
         end if;

         Recursion := Recursion - 1;
         Expr := EL.Expressions.Create_Expression (Value, Context);
         Result := Expr.Get_Value (Context);
         Recursion := Recursion + 1;
         return Result;

         --  Ignore any exception and copy the value verbatim.
      exception
         when others =>
            Recursion := Recursion + 1;
            return Util.Beans.Objects.To_Object (Value);
      end Expand;

      Resolver       : aliased Local_Resolver;
      Local_Context  : aliased EL.Contexts.Default.Default_Context;

      --  ------------------------------
      --  Copy the property identified by Name into the application config properties.
      --  The value passed in Item is expanded if it contains an EL expression.
      --  ------------------------------
      procedure Process (Name, Item : in Util.Properties.Value) is
         use Ada.Strings;
      begin
         if Unbounded.Index (Item, "{") = 0 or Unbounded.Index (Item, "{") = 0 then
            Log.Debug ("Adding config {0} = {1}", Name, Item);

            Into.Set (Name, Item);
         else
            declare
               Value : constant Object := Expand (To_String (Item), Local_Context);
               Val   : Unbounded_String;
            begin
               if not Util.Beans.Objects.Is_Null (Value) then
                  Val := Util.Beans.Objects.To_Unbounded_String (Value);
               end if;
               Log.Debug ("Adding config {0} = {1}", Name, Val);
               Into.Set (Name, Val);
            end;
         end if;
      end Process;

   begin
      Resolver.Set_Properties (Source);
      Local_Context.Set_Function_Mapper (Context.Get_Function_Mapper);
      Local_Context.Set_Resolver (Resolver'Unchecked_Access);

      Source.Iterate (Process'Access);
   end Expand;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return the
   --  string that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return String is
      Expr   : EL.Expressions.Expression;
      Result : Util.Beans.Objects.Object;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      Result := Expr.Get_Value (Context);
      return Util.Beans.Objects.To_String (Result);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in String;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
      Expr   : EL.Expressions.Expression;
   begin
      Expr := EL.Expressions.Create_Expression (Value, Context);
      return Expr.Get_Value (Context);

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Util.Beans.Objects.To_Object (Value);
   end Eval;

   --  ------------------------------
   --  Evaluate the possible EL expressions used in Value and return an
   --  object that correspond to that evaluation.
   --  ------------------------------
   function Eval (Value   : in Util.Beans.Objects.Object;
                  Context : in EL.Contexts.ELContext'Class) return Util.Beans.Objects.Object is
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when Util.Beans.Objects.TYPE_STRING | Util.Beans.Objects.TYPE_WIDE_STRING =>
            declare
               S    : constant String := Util.Beans.Objects.To_String (Value);
               Expr : EL.Expressions.Expression;
            begin
               Expr := EL.Expressions.Create_Expression (S, Context);
               return Expr.Get_Value (Context);
            end;

         when others =>
            return Value;
      end case;

      --  Ignore any exception and copy the value verbatim.
   exception
      when others =>
         return Value;
   end Eval;

end EL.Utils;

Fix evaluation of properties when Source and Into are the same sets If the value from Into is a possible EL expression, perform a recursive expand of that value.


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

with Gtk.Main;
package body MAT.Callbacks is

   --  ------------------------------
   --  Callback executed when the "quit" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_Quit (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end On_Menu_Quit;

end MAT.Callbacks;

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

with Gtk.Main;
with Gtk.Widget;
package body MAT.Callbacks is

   --  ------------------------------
   --  Callback executed when the "quit" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_Quit (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end On_Menu_Quit;

   --  ------------------------------
   --  Callback executed when the "about" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_About (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
      About : constant Gtk.Widget.Gtk_Widget :=
        Gtk.Widget.Gtk_Widget (Object.Get_Object ("about"));
   begin
      About.Show;
   end On_Menu_About;

end MAT.Callbacks;

Implement the On_Menu_About procedure

Implement the On_Menu_About procedure


-----------------------------------------------------------------------
--  util-beans-objects-record_tests -- Unit tests for objects.records package
--  Copyright (C) 2011, 2017, 2021 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.Strings;
with Util.Beans.Basic;
with Util.Beans.Objects.Vectors;
with Util.Beans.Objects.Records;
package body Util.Beans.Objects.Record_Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Beans.Records");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Records",
                       Test_Record'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Basic",
                       Test_Bean'Access);
   end Add_Tests;

   type Data is record
      Name  : Unbounded_String;
      Value : Util.Beans.Objects.Object;
   end record;

   package Data_Bean is new Util.Beans.Objects.Records (Data);
   use type Data_Bean.Element_Type_Access;
   subtype Data_Access is Data_Bean.Element_Type_Access;

   procedure Test_Record (T : in out Test) is
      D : Data;
   begin
      D.Name  := To_Unbounded_String ("testing");
      D.Value := To_Object (Integer (23));

      declare
         V  : Object := Data_Bean.To_Object (D);
         P  : constant Data_Access := Data_Bean.To_Element_Access (V);
         V2 : constant Object := V;
      begin
         T.Assert (not Is_Empty (V), "Object with data record should not be empty");
         T.Assert (not Is_Null (V), "Object with data record should not be null");
         T.Assert (P /= null, "To_Element_Access returned null");
         Assert_Equals (T, "testing", To_String (P.Name), "Data name is not the same");
         Assert_Equals (T, 23, To_Integer (P.Value), "Data value is not the same");

         V := Data_Bean.Create;

         declare
            D2 : constant Data_Access := Data_Bean.To_Element_Access (V);
         begin
            T.Assert (D2 /= null, "Null element");
            D2.Name  := To_Unbounded_String ("second test");
            D2.Value := V2;
         end;

         V := Data_Bean.To_Object (D);
      end;
   end Test_Record;

   type Bean_Type is new Util.Beans.Basic.Readonly_Bean with record
      Name : Unbounded_String;
   end record;
   type Bean_Type_Access is access all Bean_Type'Class;

   overriding
   function Get_Value (Bean : in Bean_Type;
                       Name : in String) return Util.Beans.Objects.Object;

   overriding
   function Get_Value (Bean : in Bean_Type;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      elsif Name = "length" then
         return Util.Beans.Objects.To_Object (Length (Bean.Name));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   procedure Test_Bean (T : in out Test) is
      use Basic;
      Static : aliased Bean_Type;
   begin
      Static.Name := To_Unbounded_String ("Static");

      --  Allocate dynamically several Bean_Type objects and drop the list.
      --  The memory held by internal proxy as well as the Bean_Type must be freed.
      --  The static bean should never be freed!
      for I in 1 .. 10 loop
         declare
            List  : Util.Beans.Objects.Vectors.Vector;
            Value : Util.Beans.Objects.Object;
            Bean  : Bean_Type_Access;
            P     : access Readonly_Bean'Class;
         begin
            for J in 1 .. 1_000 loop
               if I = J then
                  Value := To_Object (Static'Unchecked_Access, Objects.STATIC);
                  List.Append (Value);
               end if;
               Bean := new Bean_Type;
               Bean.Name := To_Unbounded_String ("B" & Util.Strings.Image (J));
               Value := To_Object (Bean);
               List.Append (Value);
            end loop;

            --  Verify each bean of the list
            for J in 1 .. 1_000 + 1 loop
               Value := List.Element (J);

               --  Check some common status.
               T.Assert (not Is_Null (Value), "The value should hold a bean");
               T.Assert (Get_Type (Value) = TYPE_BEAN, "The value should hold a bean");
               T.Assert (not Is_Empty (Value), "The value should not be empty");

               --  Check the bean access.
               P := To_Bean (Value);
               T.Assert (P /= null, "To_Bean returned null");
               Bean := Bean_Type'Class (P.all)'Unchecked_Access;

               --  Check we have the good bean object.
               if I = J then
                  Assert_Equals (T, "Static", To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               elsif J > I then
                  Assert_Equals (T, "B" & Util.Strings.Image (J - 1), To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               else
                  Assert_Equals (T, "B" & Util.Strings.Image (J), To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               end if;
            end loop;
         end;
      end loop;
   end Test_Bean;

end Util.Beans.Objects.Record_Tests;

-----------------------------------------------------------------------
--  util-beans-objects-record_tests -- Unit tests for objects.records package
--  Copyright (C) 2011, 2017, 2021, 2022 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.Strings;
with Util.Beans.Basic;
with Util.Beans.Objects.Vectors;
with Util.Beans.Objects.Records;
package body Util.Beans.Objects.Record_Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Beans.Records");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Records",
                       Test_Record'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Basic",
                       Test_Bean'Access);
   end Add_Tests;

   type Data is record
      Name  : Unbounded_String;
      Value : Util.Beans.Objects.Object;
   end record;

   package Data_Bean is new Util.Beans.Objects.Records (Data);
   use type Data_Bean.Element_Type_Access;
   subtype Data_Access is Data_Bean.Element_Type_Access;

   procedure Test_Record (T : in out Test) is
      D : Data;
   begin
      D.Name  := To_Unbounded_String ("testing");
      D.Value := To_Object (Integer (23));

      declare
         V  : Object := Data_Bean.To_Object (D);
         P  : constant Data_Access := Data_Bean.To_Element_Access (V);
         V2 : constant Object := V;
      begin
         T.Assert (not Is_Empty (V), "Object with data record should not be empty");
         T.Assert (not Is_Null (V), "Object with data record should not be null");
         T.Assert (P /= null, "To_Element_Access returned null");
         Assert_Equals (T, "testing", To_String (P.Name), "Data name is not the same");
         Assert_Equals (T, 23, To_Integer (P.Value), "Data value is not the same");

         V := Data_Bean.Create;

         declare
            D2 : constant Data_Access := Data_Bean.To_Element_Access (V);
         begin
            T.Assert (D2 /= null, "Null element");
            D2.Name  := To_Unbounded_String ("second test");
            D2.Value := V2;
         end;

         V := Data_Bean.To_Object (D);
         Assert_Equals (T, "<UTIL.BEANS.OBJECTS.RECORD_TESTS.DATA_BEAN.ELEMENT_PROXY>",
                        To_String (V), "Data name is not the same");
      end;
   end Test_Record;

   type Bean_Type is new Util.Beans.Basic.Readonly_Bean with record
      Name : Unbounded_String;
   end record;
   type Bean_Type_Access is access all Bean_Type'Class;

   overriding
   function Get_Value (Bean : in Bean_Type;
                       Name : in String) return Util.Beans.Objects.Object;

   overriding
   function Get_Value (Bean : in Bean_Type;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      elsif Name = "length" then
         return Util.Beans.Objects.To_Object (Length (Bean.Name));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   procedure Test_Bean (T : in out Test) is
      use Basic;
      Static : aliased Bean_Type;
   begin
      Static.Name := To_Unbounded_String ("Static");

      --  Allocate dynamically several Bean_Type objects and drop the list.
      --  The memory held by internal proxy as well as the Bean_Type must be freed.
      --  The static bean should never be freed!
      for I in 1 .. 10 loop
         declare
            List  : Util.Beans.Objects.Vectors.Vector;
            Value : Util.Beans.Objects.Object;
            Bean  : Bean_Type_Access;
            P     : access Readonly_Bean'Class;
         begin
            for J in 1 .. 1_000 loop
               if I = J then
                  Value := To_Object (Static'Unchecked_Access, Objects.STATIC);
                  List.Append (Value);
               end if;
               Bean := new Bean_Type;
               Bean.Name := To_Unbounded_String ("B" & Util.Strings.Image (J));
               Value := To_Object (Bean);
               List.Append (Value);
            end loop;

            --  Verify each bean of the list
            for J in 1 .. 1_000 + 1 loop
               Value := List.Element (J);

               --  Check some common status.
               T.Assert (not Is_Null (Value), "The value should hold a bean");
               T.Assert (Get_Type (Value) = TYPE_BEAN, "The value should hold a bean");
               T.Assert (not Is_Empty (Value), "The value should not be empty");

               --  Check the bean access.
               P := To_Bean (Value);
               T.Assert (P /= null, "To_Bean returned null");
               Bean := Bean_Type'Class (P.all)'Unchecked_Access;

               --  Check we have the good bean object.
               if I = J then
                  Assert_Equals (T, "Static", To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               elsif J > I then
                  Assert_Equals (T, "B" & Util.Strings.Image (J - 1), To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               else
                  Assert_Equals (T, "B" & Util.Strings.Image (J), To_String (Bean.Name),
                                 "Bean at" & Integer'Image (J) & " is invalid");
               end if;
            end loop;
         end;
      end loop;
   end Test_Bean;

end Util.Beans.Objects.Record_Tests;

Add a new test for To_String on the record object


-----------------------------------------------------------------------
--  asf_volume_server -- The volume_server application with Ada Server Faces
--  Copyright (C) 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 ASF.Server.Web;
with ASF.Servlets;
with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Filters.Dump;
with ASF.Applications;
with ASF.Applications.Main;
with EL.Objects;

with Volume;
procedure Asf_Volume_Server is

   CONTEXT_PATH : constant String := "/volume";

   Factory : ASF.Applications.Main.Application_Factory;
   App     : aliased ASF.Applications.Main.Application;
   Faces   : aliased ASF.Servlets.Faces.Faces_Servlet;
   Files   : aliased ASF.Servlets.Files.File_Servlet;
   Dump    : aliased ASF.Filters.Dump.Dump_Filter;
   Bean    : aliased Volume.Compute_Bean;
   Conv    : constant access Volume.Float_Converter := new Volume.Float_Converter;
   WS      : ASF.Server.Web.AWS_Container;
   C       : ASF.Applications.Config;
begin
   Bean.Radius := 1.2;
   Bean.Height := 2.0;
   C.Set (ASF.Applications.VIEW_EXT, ".html");
   C.Set (ASF.Applications.VIEW_DIR, "samples/web");
   C.Set ("web.dir", "samples/web");

   App.Initialize (C, Factory);
   App.Set_Global ("contextPath", CONTEXT_PATH);
   App.Set_Global ("compute", EL.Objects.To_Object (Bean'Unchecked_Access));

   --  Register the servlets and filters
   App.Add_Servlet (Name => "compute", Server => Faces'Unchecked_Access);
   App.Add_Servlet (Name => "files", Server => Files'Unchecked_Access);
   App.Add_Filter (Name => "dump", Filter => Dump'Unchecked_Access);

   --  Define servlet mappings
   App.Add_Mapping (Name => "compute", Pattern => "*.html");
   App.Add_Mapping (Name => "files", Pattern => "*.css");
   App.Add_Filter_Mapping (Name => "dump", Pattern => "*.html");

   App.Add_Converter (Name => "float", Converter => Conv.all'Unchecked_Access);

   WS.Register_Application (CONTEXT_PATH, App'Unchecked_Access);

   WS.Start;

   delay 600.0;

end Asf_Volume_Server;

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

with ASF.Server.Web;
with ASF.Servlets;
with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Filters.Dump;
with ASF.Applications;
with ASF.Applications.Main;
with Util.Beans.Objects;

with Volume;
procedure Asf_Volume_Server is

   CONTEXT_PATH : constant String := "/volume";

   Factory : ASF.Applications.Main.Application_Factory;
   App     : aliased ASF.Applications.Main.Application;
   Faces   : aliased ASF.Servlets.Faces.Faces_Servlet;
   Files   : aliased ASF.Servlets.Files.File_Servlet;
   Dump    : aliased ASF.Filters.Dump.Dump_Filter;
   Bean    : aliased Volume.Compute_Bean;
   Conv    : constant access Volume.Float_Converter := new Volume.Float_Converter;
   WS      : ASF.Server.Web.AWS_Container;
   C       : ASF.Applications.Config;
begin
   Bean.Radius := 1.2;
   Bean.Height := 2.0;
   C.Set (ASF.Applications.VIEW_EXT, ".html");
   C.Set (ASF.Applications.VIEW_DIR, "samples/web");
   C.Set ("web.dir", "samples/web");

   App.Initialize (C, Factory);
   App.Set_Global ("contextPath", CONTEXT_PATH);
   App.Set_Global ("faces", Util.Beans.Objects.To_Object (Bean'Unchecked_Access));

   --  Register the servlets and filters
   App.Add_Servlet (Name => "faces", Server => Faces'Unchecked_Access);
   App.Add_Servlet (Name => "files", Server => Files'Unchecked_Access);
   App.Add_Filter (Name => "dump", Filter => Dump'Unchecked_Access);

   --  Define servlet mappings
   App.Add_Mapping (Name => "faces", Pattern => "*.html");
   App.Add_Mapping (Name => "files", Pattern => "*.css");
   App.Add_Filter_Mapping (Name => "dump", Pattern => "*.html");

   App.Add_Converter (Name => "float", Converter => Conv.all'Unchecked_Access);

   WS.Register_Application (CONTEXT_PATH, App'Unchecked_Access);

   WS.Start;

   delay 600.0;

end Asf_Volume_Server;

Rename servlet and cleanup

Rename servlet and cleanup


-----------------------------------------------------------------------
--  wget -- A simple wget command to fetch a page
--  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.Text_IO;
with Ada.Command_Line;
with Util.Strings;
with Util.Strings.Tokenizers;
with Util.Http.Clients;
with Util.Http.Clients.Curl;
procedure Wget is

   procedure Print_Token (Token : in String;
                          Done  : out Boolean) is
   begin
      Ada.Text_IO.Put_Line (Token);
      Done := False;
   end Print_Token;

   Count : constant Natural := Ada.Command_Line.Argument_Count;
begin
   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: wget url ...");
      Ada.Text_IO.Put_Line ("Example: wget http://www.adacore.com");
      return;
   end if;
   Util.Http.Clients.Curl.Register;
   for I in 1 .. Count loop
      declare
         Http     : Util.Http.Clients.Client;
         URI      : constant String := Ada.Command_Line.Argument (1);
         Response : Util.Http.Clients.Response;
      begin
         Http.Add_Header ("X-Requested-By", "wget");
         Http.Get (URI, Response);
         Ada.Text_IO.Put_Line ("Code: " & Natural'Image (Response.Get_Status));
         Ada.Text_IO.Put_Line (Response.Get_Body);
      end;
   end loop;
end Wget;

-----------------------------------------------------------------------
--  wget -- A simple wget command to fetch a page
--  Copyright (C) 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Command_Line;
with Util.Http.Clients;
with Util.Http.Clients.Curl;
procedure Wget is
   Count : constant Natural := Ada.Command_Line.Argument_Count;
begin
   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: wget url ...");
      Ada.Text_IO.Put_Line ("Example: wget http://www.adacore.com");
      return;
   end if;
   Util.Http.Clients.Curl.Register;
   for I in 1 .. Count loop
      declare
         Http     : Util.Http.Clients.Client;
         URI      : constant String := Ada.Command_Line.Argument (1);
         Response : Util.Http.Clients.Response;
      begin
         Http.Add_Header ("X-Requested-By", "wget");
         Http.Get (URI, Response);
         Ada.Text_IO.Put_Line ("Code: " & Natural'Image (Response.Get_Status));
         Ada.Text_IO.Put_Line (Response.Get_Body);
      end;
   end loop;
end Wget;

Remove unused Print_Token operation

Remove unused Print_Token operation


-----------------------------------------------------------------------
--  awa-events-queues -- AWA Event Queues
--  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.Unchecked_Deallocation;

with Util.Serialize.Mappers;

with AWA.Events.Queues.Fifos;
with AWA.Events.Queues.Persistents;
package body AWA.Events.Queues is

   --  ------------------------------
   --  Queue the event.
   --  ------------------------------
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class) is
      Q : constant Queue_Info_Access := Into.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Enqueue (Event);
   end Enqueue;

   --  ------------------------------
   --  Dequeue an event and process it with the Process procedure.
   --  ------------------------------
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Q : constant Queue_Info_Access := From.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Dequeue (Process);
   end Dequeue;

   --  ------------------------------
   --  Returns true if the reference does not contain any element.
   --  ------------------------------
   function Is_Null (Queue : in Queue_Ref'Class) return Boolean is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      return Q = null or else Q.Queue = null;
   end Is_Null;

   --  ------------------------------
   --  Returns the queue name.
   --  ------------------------------
   function Get_Name (Queue : in Queue_Ref'Class) return String is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null then
         return "";
      else
         return Q.Name;
      end if;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null or else Q.Queue = null then
         return AWA.Events.Models.Null_Queue;
      else
         return Q.Queue.Get_Queue;
      end if;
   end Get_Queue;

   FIFO_QUEUE_TYPE       : constant String := "fifo";
   PERSISTENT_QUEUE_TYPE : constant String := "persist";

   --  ------------------------------
   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref is
      Result : Queue_Ref;
      Q      : constant Queue_Info_Access := new Queue_Info '(Util.Refs.Ref_Entity with
                                                              Length => Name'Length,
                                                              Name   => Name,
                                                              others => <>);
   begin
      Queue_Refs.Ref (Result) := Queue_Refs.Create (Q);
      if Kind = FIFO_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Fifos.Create_Queue (Name, Props, Context);
      elsif Name = PERSISTENT_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Persistents.Create_Queue (Name, Props, Context);
      else
         raise Util.Serialize.Mappers.Field_Error with "Invalid queue type: " & Name;
      end if;
      return Result;
   end Create_Queue;

   function Null_Queue return Queue_Ref is
      Result : Queue_Ref;
   begin
      return Result;
   end Null_Queue;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Queue_Info) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Queue'Class,
                                         Name   => Queue_Access);
   begin
      if Object.Queue /= null then
         Object.Queue.Finalize;
         Free (Object.Queue);
      end if;
   end Finalize;

end AWA.Events.Queues;

-----------------------------------------------------------------------
--  awa-events-queues -- AWA Event Queues
--  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.Unchecked_Deallocation;

with Util.Serialize.Mappers;

with AWA.Events.Queues.Fifos;
with AWA.Events.Queues.Persistents;
package body AWA.Events.Queues is

   --  ------------------------------
   --  Queue the event.
   --  ------------------------------
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class) is
      Q : constant Queue_Info_Access := Into.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Enqueue (Event);
   end Enqueue;

   --  ------------------------------
   --  Dequeue an event and process it with the Process procedure.
   --  ------------------------------
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Q : constant Queue_Info_Access := From.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Dequeue (Process);
   end Dequeue;

   --  ------------------------------
   --  Returns true if the reference does not contain any element.
   --  ------------------------------
   function Is_Null (Queue : in Queue_Ref'Class) return Boolean is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      return Q = null or else Q.Queue = null;
   end Is_Null;

   --  ------------------------------
   --  Returns the queue name.
   --  ------------------------------
   function Get_Name (Queue : in Queue_Ref'Class) return String is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null then
         return "";
      else
         return Q.Name;
      end if;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null or else Q.Queue = null then
         return AWA.Events.Models.Null_Queue;
      else
         return Q.Queue.Get_Queue;
      end if;
   end Get_Queue;

   FIFO_QUEUE_TYPE       : constant String := "fifo";
   PERSISTENT_QUEUE_TYPE : constant String := "persist";

   --  ------------------------------
   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref is
      Result : Queue_Ref;
      Q      : constant Queue_Info_Access := new Queue_Info '(Util.Refs.Ref_Entity with
                                                              Length => Name'Length,
                                                              Name   => Name,
                                                              others => <>);
   begin
      Queue_Refs.Ref (Result) := Queue_Refs.Create (Q);
      if Kind = FIFO_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Fifos.Create_Queue (Name, Props, Context);
      elsif Kind = PERSISTENT_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Persistents.Create_Queue (Name, Props, Context);
      else
         raise Util.Serialize.Mappers.Field_Error with "Invalid queue type: " & Kind;
      end if;
      return Result;
   end Create_Queue;

   function Null_Queue return Queue_Ref is
      Result : Queue_Ref;
   begin
      return Result;
   end Null_Queue;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Queue_Info) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Queue'Class,
                                         Name   => Queue_Access);
   begin
      if Object.Queue /= null then
         Object.Queue.Finalize;
         Free (Object.Queue);
      end if;
   end Finalize;

end AWA.Events.Queues;

Fix creation of event queue

Fix creation of event queue


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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.Openid.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

Fix compilation warning

Fix compilation warning


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

with Util.Encoders.AES;
with Util.Streams.Buffered.Encoders;

--  == AES Encoding Streams ==
--  The `Util.Streams.AES` package define the `Encoding_Stream` and `Decoding_Stream` types to
--  encrypt and decrypt using the AES cipher.  Before using these streams, you must use
--  the `Set_Key` procedure to setup the encryption or decryption key and define the AES
--  encryption mode to be used.  The following encryption modes are supported:
--
--  * AES-ECB
--  * AES-CBC
--  * AES-PCBC
--  * AES-CFB
--  * AES-OFB
--  * AES-CTR
--
--  The encryption and decryption keys are represented by the `Util.Encoders.Secret_Key` limited
--  type.  The key cannot be copied, has its content protected and will erase the memory once
--  the instance is deleted.  The size of the encryption key defines the AES encryption level
--  to be used:
--
--  * Use 16 bytes, or `Util.Encoders.AES.AES_128_Length` for AES-128,
--  * Use 24 bytes, or `Util.Encoders.AES.AES_192_Length` for AES-192,
--  * Use 32 bytes, or `Util.Encoders.AES.AES_256_Length` for AES-256.
--
--  Other key sizes will raise a pre-condition or constraint error exception.
--  The recommended key size is 32 bytes to use AES-256.  The key could be declared as follows:
--
--    Key : Util.Encoders.Secret_Key
--              (Length => Util.Encoders.AES.AES_256_Length);
--
--  The encryption and decryption key are initialized by using the `Util.Encoders.Create`
--  operations or by using one of the key derivative functions provided by the
--  `Util.Encoders.KDF` package.  A simple string password is created by using:
--
--    Password_Key : constant Util.Encoders.Secret_Key
--              := Util.Encoders.Create ("mysecret");
--
--  Using a password key like this is not the good practice and it may be useful to generate
--  a stronger key by using one of the key derivative function.  We will use the
--  PBKDF2 HMAC-SHA256 with 20000 loops (see RFC 8018):
--
--    Util.Encoders.KDF.PBKDF2_HMAC_SHA256 (Password => Password_Key,
--                                          Salt     => Password_Key,
--                                          Counter  => 20000,
--                                          Result   => Key);
--
--  To write a text, encrypt the content and save the file, we can chain several stream objects
--  together.  Because they are chained, the last stream object in the chain must be declared
--  first and the first element of the chain will be declared last.  The following declaration
--  is used:
--
--      Out_Stream   : aliased Util.Streams.Files.File_Stream;
--      Cipher       : aliased Util.Streams.AES.Encoding_Stream;
--      Printer      : Util.Streams.Texts.Print_Stream;
--
--  The stream objects are chained together by using their `Initialize` procedure.
--  The `Out_Stream` is configured to write on the `encrypted.aes` file.
--  The `Cipher` is configured to write in the `Out_Stream` with a 32Kb buffer.
--  The `Printer` is configured to write in the `Cipher` with a 4Kb buffer.
--
--      Out_Stream.Initialize (Mode => Ada.Streams.Stream_IO.In_File,
--                             Name => "encrypted.aes");
--      Cipher.Initialize (Output => Out_Stream'Access,
--                         Size   => 32768);
--      Printer.Initialize (Output => Cipher'Access,
--                          Size   => 4096);
--
--  The last step before using the cipher is to configure the encryption key and modes:
--
--      Cipher.Set_Key (Secret => Key, Mode => Util.Encoders.AES.ECB);
--
--  It is now possible to write the text by using the `Printer` object:
--
--    Printer.Write ("Hello world!");
--
--
package Util.Streams.AES is

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

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

   type Encoding_Stream is new Encoding.Encoder_Stream with null record;

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

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

   type Decoding_Stream is new Decoding.Encoder_Stream with null record;

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

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

end Util.Streams.AES;

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

with Util.Encoders.AES;
with Util.Streams.Buffered.Encoders;

--  == AES Encoding Streams ==
--  The `Util.Streams.AES` package define the `Encoding_Stream` and `Decoding_Stream` types to
--  encrypt and decrypt using the AES cipher.  Before using these streams, you must use
--  the `Set_Key` procedure to setup the encryption or decryption key and define the AES
--  encryption mode to be used.  The following encryption modes are supported:
--
--  * AES-ECB
--  * AES-CBC
--  * AES-PCBC
--  * AES-CFB
--  * AES-OFB
--  * AES-CTR
--
--  The encryption and decryption keys are represented by the `Util.Encoders.Secret_Key` limited
--  type.  The key cannot be copied, has its content protected and will erase the memory once
--  the instance is deleted.  The size of the encryption key defines the AES encryption level
--  to be used:
--
--  * Use 16 bytes, or `Util.Encoders.AES.AES_128_Length` for AES-128,
--  * Use 24 bytes, or `Util.Encoders.AES.AES_192_Length` for AES-192,
--  * Use 32 bytes, or `Util.Encoders.AES.AES_256_Length` for AES-256.
--
--  Other key sizes will raise a pre-condition or constraint error exception.
--  The recommended key size is 32 bytes to use AES-256.  The key could be declared as follows:
--
--    Key : Util.Encoders.Secret_Key
--              (Length => Util.Encoders.AES.AES_256_Length);
--
--  The encryption and decryption key are initialized by using the `Util.Encoders.Create`
--  operations or by using one of the key derivative functions provided by the
--  `Util.Encoders.KDF` package.  A simple string password is created by using:
--
--    Password_Key : constant Util.Encoders.Secret_Key
--              := Util.Encoders.Create ("mysecret");
--
--  Using a password key like this is not the good practice and it may be useful to generate
--  a stronger key by using one of the key derivative function.  We will use the
--  PBKDF2 HMAC-SHA256 with 20000 loops (see RFC 8018):
--
--    Util.Encoders.KDF.PBKDF2_HMAC_SHA256 (Password => Password_Key,
--                                          Salt     => Password_Key,
--                                          Counter  => 20000,
--                                          Result   => Key);
--
--  To write a text, encrypt the content and save the file, we can chain several stream objects
--  together.  Because they are chained, the last stream object in the chain must be declared
--  first and the first element of the chain will be declared last.  The following declaration
--  is used:
--
--      Out_Stream   : aliased Util.Streams.Files.File_Stream;
--      Cipher       : aliased Util.Streams.AES.Encoding_Stream;
--      Printer      : Util.Streams.Texts.Print_Stream;
--
--  The stream objects are chained together by using their `Initialize` procedure.
--  The `Out_Stream` is configured to write on the `encrypted.aes` file.
--  The `Cipher` is configured to write in the `Out_Stream` with a 32Kb buffer.
--  The `Printer` is configured to write in the `Cipher` with a 4Kb buffer.
--
--      Out_Stream.Initialize (Mode => Ada.Streams.Stream_IO.In_File,
--                             Name => "encrypted.aes");
--      Cipher.Initialize (Output => Out_Stream'Unchecked_Access,
--                         Size   => 32768);
--      Printer.Initialize (Output => Cipher'Unchecked_Access,
--                          Size   => 4096);
--
--  The last step before using the cipher is to configure the encryption key and modes:
--
--      Cipher.Set_Key (Secret => Key, Mode => Util.Encoders.AES.ECB);
--
--  It is now possible to write the text by using the `Printer` object:
--
--    Printer.Write ("Hello world!");
--
--
package Util.Streams.AES is

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

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

   type Encoding_Stream is new Encoding.Encoder_Stream with null record;

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

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

   type Decoding_Stream is new Decoding.Encoder_Stream with null record;

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

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

end Util.Streams.AES;

Fix documentation example

Fix documentation example