-----------------------------------------------------------------------
--  util-http-clients-web -- HTTP Clients with AWS implementation
--  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 AWS.Headers.Set;
with AWS.Client;
with AWS.Messages;
package body Util.Http.Clients.Web is

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers);
   end Do_Get;

   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data, Headers => Req.Headers);
   end Do_Post;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
   begin
      return "";
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

-----------------------------------------------------------------------
--  util-http-clients-web -- HTTP Clients with AWS implementation
--  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 AWS.Headers.Set;
with AWS.Client;
with AWS.Messages;
with Util.Log.Loggers;
package body Util.Http.Clients.Web is

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Web");

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Get {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers);
   end Do_Get;

   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Post {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data, Headers => Req.Headers);
   end Do_Post;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
   begin
      return "";
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

Add some log to help solving web issues

Add some log to help solving web issues


--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Long_Long_Integer;
   subtype ino_t is Interfaces.C.unsigned;
   subtype off_t is Interfaces.C.int;
   subtype blksize_t is Interfaces.C.int;
   subtype blkcnt_t is Interfaces.C.int;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Interfaces.C.unsigned;
   subtype mode_t is Interfaces.C.unsigned;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Interfaces.C.unsigned;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Interfaces.C.int;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   STAT_NAME  : constant String := "stat";
   FSTAT_NAME : constant String := "fstat";
   type Stat_Type is record
      st_dev     : dev_t;
      pad1       : Interfaces.C.unsigned_short;
      st_ino     : ino_t;
      st_mode    : mode_t;
      st_nlink   : nlink_t;
      st_uid     : uid_t;
      st_gid     : gid_t;
      st_rdev    : dev_t;
      pad2       : Interfaces.C.unsigned_short;
      st_size    : off_t;
      st_blksize : blksize_t;
      st_blocks  : blkcnt_t;
      pad3_1     : Interfaces.C.unsigned_long;
      st_atim    : Timespec;
      st_mtim    : Timespec;
      st_ctim    : Timespec;
      pad3       : Interfaces.C.unsigned_long;
      pad4       : Interfaces.C.unsigned_long;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Long_Long_Integer;
   subtype ino_t is Interfaces.C.unsigned;
   subtype off_t is Interfaces.C.int;
   subtype blksize_t is Interfaces.C.int;
   subtype blkcnt_t is Interfaces.C.int;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Interfaces.C.unsigned;
   subtype mode_t is Interfaces.C.unsigned;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Interfaces.C.unsigned;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Interfaces.C.int;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   STAT_NAME  : constant String := "stat";
   FSTAT_NAME : constant String := "fstat";
   LSTAT_NAME : constant String := "lstat";
   type Stat_Type is record
      st_dev     : dev_t;
      pad1       : Interfaces.C.unsigned_short;
      st_ino     : ino_t;
      st_mode    : mode_t;
      st_nlink   : nlink_t;
      st_uid     : uid_t;
      st_gid     : gid_t;
      st_rdev    : dev_t;
      pad2       : Interfaces.C.unsigned_short;
      st_size    : off_t;
      st_blksize : blksize_t;
      st_blocks  : blkcnt_t;
      pad3_1     : Interfaces.C.unsigned_long;
      st_atim    : Timespec;
      st_mtim    : Timespec;
      st_ctim    : Timespec;
      pad3       : Interfaces.C.unsigned_long;
      pad4       : Interfaces.C.unsigned_long;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

Declare the LSTAT_NAME

Declare the LSTAT_NAME


-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2015, 2016, 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;
with Util.Streams.Buffered;
with Ada.Calendar;
with GNAT.Calendar.Time_IO;

--  == Texts ==
--  The `Util.Streams.Texts` package implements text oriented input and output streams.
--  The `Print_Stream` type extends the `Output_Buffer_Stream` to allow writing
--  text content.
--
--  The `Reader_Stream` type extends the `Input_Buffer_Stream` and allows to
--  read text content.
package Util.Streams.Texts is

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The Print_Stream is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is new Buffered.Output_Buffer_Stream with private;
   type Print_Stream_Access is access all Print_Stream'Class;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : access Output_Stream'Class);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Print_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer);

   --  Write a date on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date);

   --  Get the output stream content as a string.
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String;

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character);

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character);

   --  -----------------------
   --  Reader stream
   --  -----------------------
   --  The Reader_Stream is an input stream which provides helper methods
   --  for reading text streams.
   type Reader_Stream is new Buffered.Input_Buffer_Stream with private;
   type Reader_Stream_Access is access all Reader_Stream'Class;

   --  Initialize the reader to read the input from the input stream given in From.
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : access Input_Stream'Class);

   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False);

private

   type Print_Stream is new Buffered.Output_Buffer_Stream with null record;

   type Reader_Stream is new Buffered.Input_Buffer_Stream with null record;

end Util.Streams.Texts;

-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2015, 2016, 2017, 2018, 2019, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;
with Util.Streams.Buffered;
with Ada.Calendar;
with GNAT.Calendar.Time_IO;

--  == Texts ==
--  The `Util.Streams.Texts` package implements text oriented input and output streams.
--  The `Print_Stream` type extends the `Output_Buffer_Stream` to allow writing
--  text content.
--
--  The `Reader_Stream` type extends the `Input_Buffer_Stream` and allows to
--  read text content.
package Util.Streams.Texts is

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The Print_Stream is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is new Buffered.Output_Buffer_Stream with private;
   type Print_Stream_Access is access all Print_Stream'Class;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : access Output_Stream'Class);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer);

   --  Write a date on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date);

   --  Get the output stream content as a string.
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String;

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character);

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character);

   --  -----------------------
   --  Reader stream
   --  -----------------------
   --  The Reader_Stream is an input stream which provides helper methods
   --  for reading text streams.
   type Reader_Stream is new Buffered.Input_Buffer_Stream with private;
   type Reader_Stream_Access is access all Reader_Stream'Class;

   --  Initialize the reader to read the input from the input stream given in From.
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : access Input_Stream'Class);

   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False);

private

   type Print_Stream is new Buffered.Output_Buffer_Stream with null record;

   type Reader_Stream is new Buffered.Input_Buffer_Stream with null record;

end Util.Streams.Texts;

Remove Write and Write_Wide procedures because they are now provided by a parent package


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

with Wiki.Strings;
with Wiki.Attributes;
with Wiki.Nodes.Lists;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.  The <tt>Document</tt> holds two distinct parts:
--
--  * A main document body that represents the Wiki content that was parsed.
--  * A table of contents part that was built while Wiki sections are collected.
--
--  Most of the operations provided by the <tt>Wiki.Documents</tt> package are intended to
--  be used by the wiki parser and filters to build the document.  The document is made of
--  nodes whose knowledge is required by the renderer.
--
--  A document instance must be declared before parsing a text:
--
--     Doc    : Wiki.Documents.Document;
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Returns True if the current node is the root document node.
   function Is_Root_Node (Doc : in Document) return Boolean;

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Returns True if the document is empty.
   function Is_Empty (Doc : in Document) return Boolean;

   --  Returns True if the document displays the table of contents by itself.
   function Is_Using_TOC (Doc : in Document) return Boolean;

   --  Returns True if the table of contents is visible and must be rendered.
   function Is_Visible_TOC (Doc : in Document) return Boolean;

   --  Hide the table of contents.
   procedure Hide_TOC (Doc : in out Document);

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Lists.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Lists.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes       : Wiki.Nodes.Lists.Node_List_Ref;
      TOC         : Wiki.Nodes.Lists.Node_List_Ref;
      Current     : Wiki.Nodes.Node_Type_Access;
      Using_TOC   : Boolean := False;
      Visible_TOC : Boolean := True;
   end record;

end Wiki.Documents;

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

with Wiki.Strings;
with Wiki.Attributes;
with Wiki.Nodes.Lists;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.  The <tt>Document</tt> holds two distinct parts:
--
--  * A main document body that represents the Wiki content that was parsed.
--  * A table of contents part that was built while Wiki sections are collected.
--
--  Most of the operations provided by the <tt>Wiki.Documents</tt> package are intended to
--  be used by the wiki parser and filters to build the document.  The document is made of
--  nodes whose knowledge is required by the renderer.
--
--  A document instance must be declared before parsing a text:
--
--     Doc    : Wiki.Documents.Document;
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Returns True if the current node is the root document node.
   function Is_Root_Node (Doc : in Document) return Boolean;

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Add a new row to the current table.
   procedure Add_Row (Into : in out Document);

   --  Add a column to the current table row.  The column is configured with the
   --  given attributes.  The column content is provided through calls to Append.
   procedure Add_Column (Into : in out Document;
                         Attributes : in out Wiki.Attributes.Attribute_List);

   --  Finish the creation of the table.
   procedure Finish_Table (Into : in out Document);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Returns True if the document is empty.
   function Is_Empty (Doc : in Document) return Boolean;

   --  Returns True if the document displays the table of contents by itself.
   function Is_Using_TOC (Doc : in Document) return Boolean;

   --  Returns True if the table of contents is visible and must be rendered.
   function Is_Visible_TOC (Doc : in Document) return Boolean;

   --  Hide the table of contents.
   procedure Hide_TOC (Doc : in out Document);

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Lists.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Lists.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes       : Wiki.Nodes.Lists.Node_List_Ref;
      TOC         : Wiki.Nodes.Lists.Node_List_Ref;
      Current     : Wiki.Nodes.Node_Type_Access;
      Using_TOC   : Boolean := False;
      Visible_TOC : Boolean := True;
   end record;

end Wiki.Documents;

Add support for wiki tables - declare Add_Row, Add_Column and Finish_Table


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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Streams.Files;

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#20AC#) & -- Euro sign
        Wide_Wide_Character'Val (16#2acbf#);
      T : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19, 23, 0, 0);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Entity ("date", T);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Stream.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Streams.Files;

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#20AC#) & -- Euro sign
        Wide_Wide_Character'Val (16#2acbf#);
      T : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19, 23, 0, 0);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Entity ("date", T);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Buffer : aliased Util.Streams.Texts.Print_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Buffer.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Stream.Initialize (Output => Buffer'Unchecked_Access);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

Update Test_Output procedure to configure the text buffer for the JSON output stream


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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Rename Set_Reader_Config into Prepare_Config


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

with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use Sequence_Maps;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : access ADO.Sessions.Factory.Session_Factory'Class)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : out Identifier) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id := Gen.Next_Id;
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      loop
         --  Allocate a new sequence within a transaction.
         declare
            Params : Parameter_List;
            Found  : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Params.Set_Filter ("name = ?");
            Params.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Database => DB, Parameters => Params, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying");
                  DB.Rollback;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

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

with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;
with ADO.SQL;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use Sequence_Maps;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : access ADO.Sessions.Factory.Session_Factory'Class)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : out Identifier) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id := Gen.Next_Id;
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      loop
         --  Allocate a new sequence within a transaction.
         declare
            Query : ADO.SQL.Query;
            Found : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Query.Set_Filter ("name = ?");
            Query.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Session => DB, Query => Query, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying");
                  DB.Rollback;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

Update query parameters for the new model


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

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

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

package body ADO.Connections is

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

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

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

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

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

   end Create_Connection;

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

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

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

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

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

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

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

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

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

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

   end Load_Driver;

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

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

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

end ADO.Connections;

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

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

with System;
with Ada.Exceptions;

package body ADO.Connections is

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

   type Driver_Array_Access is array (Driver_Index) of Driver_Access;

   Driver_List : Driver_Array_Access;

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

   --  ------------------------------
   --  Get the driver index that corresponds to the driver for this database connection string.
   --  ------------------------------
   function Get_Driver (Config : in Configuration) return Driver_Index is
      Name    : constant String := Config.Get_Driver;
      Driver  : constant Driver_Access := Get_Driver (Name);
   begin
      if Driver = null then
         raise ADO.Configs.Connection_Error with "Database driver '" & Name & "' not found";
      else
         return Driver.Get_Driver_Index;
      end if;
   end Get_Driver;

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

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

   end Create_Connection;

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

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

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

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

      for I in Driver_List'Range loop
         if Driver_List (I) = Driver then
            return;
         end if;
         if Driver_List (I) = null then
            Driver_List (I) := Driver;
            Driver.Index := I;
            return;
         end if;
      end loop;

      Log.Error ("The ADO driver table is full: increase ADO.Configs.MAX_DRIVER");
   end Register;

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

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

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

   end Load_Driver;

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

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

      for Retry in 0 .. 1 loop
         if Retry = 1 then
            Load_Driver (Name);
         end if;
         for D of Driver_List loop
            exit when D = null;

            if Name = D.Name.all then
               return D;
            end if;

         end loop;
      end loop;
      return null;
   end Get_Driver;

end ADO.Connections;

Refactor the driver management to use a fixed statically allocated table of drivers - Define Driver_Array_Access type and use the Driver_Index range - Allocate static instance Driver_List - In Register, fill the Driver_List table - In Get_Driver, look at the Driver_List table for entries


-----------------------------------------------------------------------
--  EL.Methods.Proc_2 -- Procedure Binding with 2 arguments
--  Copyright (C) 2010, 2011, 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 EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
   type Param2_Type (<>) is limited private;
package EL.Methods.Proc_2 is

   use Util.Beans.Methods;

   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean;

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

   --  Function access to the proxy.
   type Proxy_Access is
     access procedure (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                       P1 : in Param1_Type;
                       P2 : in Param2_Type);

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

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

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

      --  The bean method to invoke
      with procedure Method (O  : in out Bean;
                             P1 : in Param1_Type;
                             P2 : in Param2_Type);
   package Bind is

      --  Method that Execute will invoke.
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in Param1_Type;
                               P2 : in Param2_Type);

      F_NAME : aliased constant String := Name;

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

end EL.Methods.Proc_2;

-----------------------------------------------------------------------
--  EL.Methods.Proc_2 -- Procedure Binding with 2 arguments
--  Copyright (C) 2010, 2011, 2012, 2013, 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 EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
   type Param2_Type (<>) is limited private;
package EL.Methods.Proc_2 is

   use Util.Beans.Methods;

   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean;

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

   --  Function access to the proxy.
   type Proxy_Access is
     access procedure (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                       P1 : in Param1_Type;
                       P2 : in Param2_Type);

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

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

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

      --  The bean method to invoke
      with procedure Method (O  : in out Bean;
                             P1 : in Param1_Type;
                             P2 : in Param2_Type);
   package Bind is

      --  Method that Execute will invoke.
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in Param1_Type;
                               P2 : in Param2_Type);

      F_NAME : aliased constant String := Name;

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

end EL.Methods.Proc_2;

Change the Bean generic parameter to a limited type