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

with ADO.Statements;
with ADO.Queries;

with Util.Log.Loggers;

with GNAT.Command_Line;

procedure Userdb is

   use ADO;
   use Ada;
   use Ada.Strings.Unbounded;
   use Samples.User.Model;
   use ADO.Statements;
   use GNAT.Command_Line;

   Factory    : ADO.Sessions.Factory.Session_Factory;

   User  : User_Ref;
   Users : User_Vector;

   procedure List_Users (Filter : in String);
   procedure List_User_Info;
   procedure Initialize (File : in String);

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_Users (Filter : in String) is
      use User_Vectors;
      DB : ADO.Sessions.Session := Factory.Get_Session;
      Statement : ADO.Statements.Query_Statement := DB.Create_Statement (Filter);
      Query : ADO.SQL.Query;
   begin
      List (Object => Users, Session => DB, Query => Query);
      if Users.Is_Empty then
         Text_IO.Put_Line ("List is empty");
      else
         declare
            Iter : User_Vectors.Cursor := First (Users);
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Get_Id) & "     "
                                 & To_String (User.Get_Name)
                                 & "    " & To_String (User.Get_Email));
               User_Vectors.Next (Iter);
            end loop;
         end;
      end if;

      Statement := DB.Create_Statement ("select count(*) from user");
      Statement.Execute;
      if not Statement.Has_Elements then
         Text_IO.Put_Line ("Count query failed...");
      end if;
      declare
         Count : constant Integer := Statement.Get_Integer (0);
      begin
         Text_IO.Put_Line ("Count: " & Integer'Image (Count));
      end;
   end List_Users;

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_User_Info is
      use Samples.User.Model.User_Info_Vectors;
      DB      : ADO.Sessions.Session := Factory.Get_Session;
      Users   : Samples.User.Model.User_Info_Vector;
      Context : ADO.Queries.Context;
   begin
      Context.Set_Query (Samples.User.Model.Query_User_List);
      List (Object => Users, Session => DB, Context => Context);

      if Users.Is_Empty then
         Text_IO.Put_Line ("User info list is empty");
      else
         declare
            Iter : Cursor := First (Users);
            User : Samples.User.Model.User_Info;
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Id) & "     "
                                 & To_String (User.Name)
                                 & "    " & To_String (User.Email));
               Next (Iter);
            end loop;
         end;
      end if;
   end List_User_Info;

   procedure Initialize (File : in String) is
   begin
      Util.Log.Loggers.Initialize (File);
      ADO.Drivers.Initialize (File);
   end Initialize;

begin
   Initialize ("samples.properties");
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB    : ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      DB.Begin_Transaction;
      List_User_Info;

      List_Users (Filter => "");

      loop
         declare
            Name : constant String := Get_Argument;
         begin
            exit when Name = "";

            Query.Bind_Param (1, Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => DB, Query => Query, Found => Found);
            if User.Is_Null or not Found then
               User.Set_Name (Name);
               User.Set_Email (Name & "@gmail.com");
               User.Set_Description ("My friend " & Name);
               --  User.Set_Password ("my password");
               User.Set_Status (0);
               User.Save (DB);

               Text_IO.Put_Line ("User created: " & Identifier'Image (User.Get_Id));
            else
               Text_IO.Put_Line ("User " & Name & ": " & Identifier'Image (User.Get_Id));
            end if;
         end;
      end loop;
      DB.Rollback;

   exception
      when ADO.Sessions.NOT_FOUND =>
         Text_IO.Put_Line ("User 23 does not exist");
   end;
   Text_IO.Put_Line ("Exiting");
end Userdb;

-----------------------------------------------------------------------
--  userdb -- Example to find/create an object from the database
--  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 ADO;
with ADO.Drivers.Initializer;
with ADO.Sessions;
with ADO.SQL;
with ADO.Sessions.Factory;
with Samples.User.Model;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with ADO.Statements;
with ADO.Queries;

with Util.Log.Loggers;

with GNAT.Command_Line;

procedure Userdb is

   use ADO;
   use Ada;
   use Ada.Strings.Unbounded;
   use Samples.User.Model;
   use ADO.Statements;
   use GNAT.Command_Line;

   Factory    : ADO.Sessions.Factory.Session_Factory;

   User  : User_Ref;
   Users : User_Vector;

   procedure List_Users (Filter : in String);
   procedure List_User_Info;
   procedure Initialize (File : in String);

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_Users (Filter : in String) is
      use User_Vectors;
      DB : ADO.Sessions.Session := Factory.Get_Session;
      Statement : ADO.Statements.Query_Statement := DB.Create_Statement (Filter);
      Query : ADO.SQL.Query;
   begin
      List (Object => Users, Session => DB, Query => Query);
      if Users.Is_Empty then
         Text_IO.Put_Line ("List is empty");
      else
         declare
            Iter : User_Vectors.Cursor := First (Users);
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Get_Id) & "     "
                                 & To_String (User.Get_Name)
                                 & "    " & To_String (User.Get_Email));
               User_Vectors.Next (Iter);
            end loop;
         end;
      end if;

      Statement := DB.Create_Statement ("select count(*) from user");
      Statement.Execute;
      if not Statement.Has_Elements then
         Text_IO.Put_Line ("Count query failed...");
      end if;
      declare
         Count : constant Integer := Statement.Get_Integer (0);
      begin
         Text_IO.Put_Line ("Count: " & Integer'Image (Count));
      end;
   end List_Users;

   --  ------------------------------
   --  List users
   --  ------------------------------
   procedure List_User_Info is
      use Samples.User.Model.User_Info_Vectors;
      DB      : ADO.Sessions.Session := Factory.Get_Session;
      Users   : Samples.User.Model.User_Info_Vector;
      Context : ADO.Queries.Context;
   begin
      Context.Set_Query (Samples.User.Model.Query_User_List);
      List (Object => Users, Session => DB, Context => Context);

      if Users.Is_Empty then
         Text_IO.Put_Line ("User info list is empty");
      else
         declare
            Iter : Cursor := First (Users);
            User : Samples.User.Model.User_Info;
         begin
            while Has_Element (Iter) loop
               User := Element (Iter);
               Text_IO.Put_Line (Identifier'Image (User.Id) & "     "
                                 & To_String (User.Name)
                                 & "    " & To_String (User.Email));
               Next (Iter);
            end loop;
         end;
      end if;
   end List_User_Info;

   procedure Initialize (File : in String) is
      procedure Init is new ADO.Drivers.Initializer (String, ADO.Drivers.Initialize);
   begin
      Util.Log.Loggers.Initialize (File);
      Init (File);
   end Initialize;

begin
   Initialize ("samples.properties");
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB    : ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      DB.Begin_Transaction;
      List_User_Info;

      List_Users (Filter => "");

      loop
         declare
            Name : constant String := Get_Argument;
         begin
            exit when Name = "";

            Query.Bind_Param (1, Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => DB, Query => Query, Found => Found);
            if User.Is_Null or not Found then
               User.Set_Name (Name);
               User.Set_Email (Name & "@gmail.com");
               User.Set_Description ("My friend " & Name);
               --  User.Set_Password ("my password");
               User.Set_Status (0);
               User.Save (DB);

               Text_IO.Put_Line ("User created: " & Identifier'Image (User.Get_Id));
            else
               Text_IO.Put_Line ("User " & Name & ": " & Identifier'Image (User.Get_Id));
            end if;
         end;
      end loop;
      DB.Rollback;

   exception
      when ADO.Sessions.NOT_FOUND =>
         Text_IO.Put_Line ("User 23 does not exist");
   end;
   Text_IO.Put_Line ("Exiting");
end Userdb;

Update the driver initialization

Update the driver initialization


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

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Access,
--                             Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

--   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Buffer stream
   --  -----------------------
   --  The `Buffer_Stream` is the base type for the `Output_Buffer_Stream`
   --  and `Input_Buffer_Stream` types.  It holds the buffer and read/write positions.
   type Buffer_Stream is limited new Ada.Finalization.Limited_Controlled with private;

   --  Initialize the stream to read or write on the buffer.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Buffer_Stream;
                         Size    : in Positive);

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Buffer_Stream;
                         Content : in String);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Buffer_Stream) return Buffer_Access;

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Buffer_Stream) return Natural;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Buffer_Stream);

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The `Output_Buffer_Stream` is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call `Flush` to make sure the data
   --  is written to the target stream.  The `Flush` operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Buffer_Stream and Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of <b>Size</b> bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the `Into` array and return the index of the
   --  last element (inclusive) in `Last`.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream);

   type Input_Buffer_Stream is limited new Buffer_Stream and Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream from the buffer created for an output stream.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Buffer_Stream'Class);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Value  : out Ada.Streams.Stream_Element);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Wide_Wide_Character);

   --  Read into the buffer as many bytes as possible and return in
   --  `last` the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

   type Input_Output_Buffer_Stream is abstract limited new Buffer_Stream
     and Input_Stream and Output_Stream with private;

private

   use Ada.Streams;

   type Buffer_Stream is limited new Ada.Finalization.Limited_Controlled with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;
   end record;

   type Output_Buffer_Stream is limited new Buffer_Stream and Output_Stream with record
      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;
   end record;

   type Input_Buffer_Stream is limited new Buffer_Stream and Input_Stream with record
      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   type Input_Output_Buffer_Stream is abstract limited new Buffer_Stream
     and Input_Stream and Output_Stream with record
      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;

      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

end Util.Streams.Buffered;

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

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Unchecked_Access,
--                             Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Unchecked_Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Buffer stream
   --  -----------------------
   --  The `Buffer_Stream` is the base type for the `Output_Buffer_Stream`
   --  and `Input_Buffer_Stream` types.  It holds the buffer and read/write positions.
   type Buffer_Stream is limited new Ada.Finalization.Limited_Controlled with private;

   --  Initialize the stream to read or write on the buffer.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Buffer_Stream;
                         Size    : in Positive);

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Buffer_Stream;
                         Content : in String);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Buffer_Stream) return Buffer_Access;

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Buffer_Stream) return Natural;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Buffer_Stream);

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The `Output_Buffer_Stream` is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call `Flush` to make sure the data
   --  is written to the target stream.  The `Flush` operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Buffer_Stream and Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of <b>Size</b> bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the `Into` array and return the index of the
   --  last element (inclusive) in `Last`.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream);

   type Input_Buffer_Stream is limited new Buffer_Stream and Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream from the buffer created for an output stream.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Buffer_Stream'Class);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Value  : out Ada.Streams.Stream_Element);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Wide_Wide_Character);

   --  Read into the buffer as many bytes as possible and return in
   --  `last` the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

   type Input_Output_Buffer_Stream is abstract limited new Buffer_Stream
     and Input_Stream and Output_Stream with private;

private

   use Ada.Streams;

   type Buffer_Stream is limited new Ada.Finalization.Limited_Controlled with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;
   end record;

   type Output_Buffer_Stream is limited new Buffer_Stream and Output_Stream with record
      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;
   end record;

   type Input_Buffer_Stream is limited new Buffer_Stream and Input_Stream with record
      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   type Input_Output_Buffer_Stream is abstract limited new Buffer_Stream
     and Input_Stream and Output_Stream with record
      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;

      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

end Util.Streams.Buffered;

Fix documentation example

Fix documentation example


pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL).                                                     --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program is Free Software: You can redistribute it and/or modify    --
--  it under the terms of The GNU General Public License as published by    --
--    the Free Software Foundation: either version 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program is distributed in the hope that it will be useful,     --
--      but WITHOUT ANY WARRANTY; without even the implied warranty of      --
--      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the        --
--              GNU General Public License for more details.                --
--                                                                          --
--    You should have received a copy of the GNU General Public License     --
--   along with this program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
------------------------------------------------------------------------------
with System;

with Imago.Binary;
use Imago;

package Imago.IL is

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

                              ---------------
                              -- T Y P E S --
                              ---------------

  --------------------------------------------------------------------------
  -- New names for old types.
  subtype Bitfield  is Binary.Word;
  subtype Bool      is Binary.Byte;
  subtype Byte      is Binary.S_Byte;
  subtype ClampD    is Long_Float   range 0.0 .. 1.0;
  subtype ClampF    is Float        range 0.0 .. 1.0;
  subtype ClampH    is Short_Float  range 0.0 .. 1.0;
  subtype Double    is Long_Float;
  subtype Int       is Integer;
  subtype Short     is Short_Integer;
  subtype SizeI     is Integer;
  subtype UByte     is Binary.Byte;
  subtype UShort    is Binary.Short;
  subtype UInt      is Binary.Word;
  subtype Pointer   is System.Address;

  --------------------------------------------------------------------------
  -- Try to bring some touch of order to the ILenum mess.
  subtype Enum is Binary.Word;

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

                          -----------------------
                          -- C O N S T A N T S --
                          -----------------------

  --------------------------------------------------------------------------
  -- Useful values.
  Null_Pointer: constant Pointer := System.Null_Address;

  --------------------------------------------------------------------------
  -- "Enumeration" constants.
  IL_FALSE                                : constant Bool := 16#0#;
  IL_TRUE                                 : constant Bool := 16#1#;

  -- Data formats.
  IL_COLOUR_INDEX                         : constant Enum := 16#1900#;
  IL_COLOR_INDEX                          : constant Enum := 16#1900#;
  IL_ALPHA                                : constant Enum := 16#1906#;
  IL_RGB                                  : constant Enum := 16#1907#;
  IL_RGBA                                 : constant Enum := 16#1908#;
  IL_BGR                                  : constant Enum := 16#80E0#;
  IL_BGRA                                 : constant Enum := 16#80E1#;
  IL_LUMINANCE                            : constant Enum := 16#1909#;
  IL_LUMINANCE_ALPHA                      : constant Enum := 16#190A#;

  -- Types of data.
  IL_BYTE                                 : constant Enum := 16#1400#;
  IL_UNSIGNED_BYTE                        : constant Enum := 16#1401#;
  IL_SHORT                                : constant Enum := 16#1402#;
  IL_UNSIGNED_SHORT                       : constant Enum := 16#1403#;
  IL_INT                                  : constant Enum := 16#1404#;
  IL_UNSIGNED_INT                         : constant Enum := 16#1405#;
  IL_FLOAT                                : constant Enum := 16#1406#;
  IL_DOUBLE                               : constant Enum := 16#140A#;
  IL_HALF                                 : constant Enum := 16#140B#;

  -- IL specific defines.
  IL_VENDOR                               : constant Enum := 16#1F00#;
  IL_LOAD_EXT                             : constant Enum := 16#1F01#;
  IL_SAVE_EXT                             : constant Enum := 16#1F02#;

  IL_VERSION_1_7_8                        : constant Enum := 16#1#;
  IL_VERSION                              : constant Enum := 178;

  -- Attribute bits.
  IL_ORIGIN_BIT                           : constant Bitfield := 16#0000_0001#;
  IL_FILE_BIT                             : constant Bitfield := 16#0000_0002#;
  IL_PAL_BIT                              : constant Bitfield := 16#0000_0004#;
  IL_FORMAT_BIT                           : constant Bitfield := 16#0000_0008#;
  IL_TYPE_BIT                             : constant Bitfield := 16#0000_0010#;
  IL_COMPRESS_BIT                         : constant Bitfield := 16#0000_0020#;
  IL_LOADFAIL_BIT                         : constant Bitfield := 16#0000_0040#;
  IL_FORMAT_SPECIFIC_BIT                  : constant Bitfield := 16#0000_0080#;
  IL_ALL_ATTRIB_BITS                      : constant Bitfield := 16#000F_FFFF#;

  -- Types of palettes.
  IL_PAL_NONE                             : constant Enum := 16#0400#;
  IL_PAL_RGB24                            : constant Enum := 16#0401#;
  IL_PAL_RGB32                            : constant Enum := 16#0402#;
  IL_PAL_RGBA32                           : constant Enum := 16#0403#;
  IL_PAL_BGR24                            : constant Enum := 16#0404#;
  IL_PAL_BGR32                            : constant Enum := 16#0405#;
  IL_PAL_BGRA32                           : constant Enum := 16#0406#;

  -- Types of images.
  IL_TYPE_UNKNOWN                         : constant Enum := 16#0000#;
  IL_BMP                                  : constant Enum := 16#0420#;
  IL_CUT                                  : constant Enum := 16#0421#;
  IL_DOOM                                 : constant Enum := 16#0422#;
  IL_DOOM_FLAT                            : constant Enum := 16#0423#;
  IL_ICO                                  : constant Enum := 16#0424#;
  IL_JPG                                  : constant Enum := 16#0425#;
  IL_JFIF                                 : constant Enum := 16#0425#;
  IL_ILBM                                 : constant Enum := 16#0426#;
  IL_PCD                                  : constant Enum := 16#0427#;
  IL_PCX                                  : constant Enum := 16#0428#;
  IL_PIC                                  : constant Enum := 16#0429#;
  IL_PNG                                  : constant Enum := 16#042A#;
  IL_PNM                                  : constant Enum := 16#042B#;
  IL_SGI                                  : constant Enum := 16#042C#;
  IL_TGA                                  : constant Enum := 16#042D#;
  IL_TIF                                  : constant Enum := 16#042E#;
  IL_CHEAD                                : constant Enum := 16#042F#;
  IL_RAW                                  : constant Enum := 16#0430#;
  IL_MDL                                  : constant Enum := 16#0431#;
  IL_WAL                                  : constant Enum := 16#0432#;
  IL_LIF                                  : constant Enum := 16#0434#;
  IL_MNG                                  : constant Enum := 16#0435#;
  IL_JNG                                  : constant Enum := 16#0435#;
  IL_GIF                                  : constant Enum := 16#0436#;
  IL_DDS                                  : constant Enum := 16#0437#;
  IL_DCX                                  : constant Enum := 16#0438#;
  IL_PSD                                  : constant Enum := 16#0439#;
  IL_EXIF                                 : constant Enum := 16#043A#;
  IL_PSP                                  : constant Enum := 16#043B#;
  IL_PIX                                  : constant Enum := 16#043C#;
  IL_PXR                                  : constant Enum := 16#043D#;
  IL_XPM                                  : constant Enum := 16#043E#;
  IL_HDR                                  : constant Enum := 16#043F#;
  IL_ICNS                                 : constant Enum := 16#0440#;
  IL_JP2                                  : constant Enum := 16#0441#;
  IL_EXR                                  : constant Enum := 16#0442#;
  IL_WDP                                  : constant Enum := 16#0443#;
  IL_VTF                                  : constant Enum := 16#0444#;
  IL_WBMP                                 : constant Enum := 16#0445#;
  IL_SUN                                  : constant Enum := 16#0446#;
  IL_IFF                                  : constant Enum := 16#0447#;
  IL_TPL                                  : constant Enum := 16#0448#;
  IL_FITS                                 : constant Enum := 16#0449#;
  IL_DICOM                                : constant Enum := 16#044A#;
  IL_IWI                                  : constant Enum := 16#044B#;
  IL_BLP                                  : constant Enum := 16#044C#;
  IL_FTX                                  : constant Enum := 16#044D#;
  IL_ROT                                  : constant Enum := 16#044E#;
  IL_TEXTURE                              : constant Enum := 16#044F#;
  IL_DPX                                  : constant Enum := 16#0450#;
  IL_UTX                                  : constant Enum := 16#0451#;
  IL_MP3                                  : constant Enum := 16#0452#;

  IL_JASC_PAL                             : constant Enum := 16#0475#;

  -- Types of errors.
  IL_NO_ERROR                             : constant Enum := 16#0000#;
  IL_INVALID_ENUM                         : constant Enum := 16#0501#;
  IL_OUT_OF_MEMORY                        : constant Enum := 16#0502#;
  IL_FORMAT_NOT_SUPPORTED                 : constant Enum := 16#0503#;
  IL_INTERNAL_ERROR                       : constant Enum := 16#0504#;
  IL_INVALID_VALUE                        : constant Enum := 16#0505#;
  IL_ILLEGAL_OPERATION                    : constant Enum := 16#0506#;
  IL_ILLEGAL_FILE_VALUE                   : constant Enum := 16#0507#;
  IL_INVALID_FILE_HEADER                  : constant Enum := 16#0508#;
  IL_INVALID_PARAM                        : constant Enum := 16#0509#;
  IL_COULD_NOT_OPEN_FILE                  : constant Enum := 16#050A#;
  IL_INVALID_EXTENSION                    : constant Enum := 16#050B#;
  IL_FILE_ALREADY_EXISTS                  : constant Enum := 16#050C#;
  IL_OUT_FORMAT_SAME                      : constant Enum := 16#050D#;
  IL_STACK_OVERFLOW                       : constant Enum := 16#050E#;
  IL_STACK_UNDERFLOW                      : constant Enum := 16#050F#;
  IL_INVALID_CONVERSION                   : constant Enum := 16#0510#;
  IL_BAD_DIMENSIONS                       : constant Enum := 16#0511#;
  IL_FILE_READ_ERROR                      : constant Enum := 16#0512#;
  IL_FILE_WRITE_ERROR                     : constant Enum := 16#0513#;

  IL_LIB_GIF_ERROR                        : constant Enum := 16#05E1#;
  IL_LIB_JPEG_ERROR                       : constant Enum := 16#05E2#;
  IL_LIB_PNG_ERROR                        : constant Enum := 16#05E3#;
  IL_LIB_TIFF_ERROR                       : constant Enum := 16#05E4#;
  IL_LIB_MNG_ERROR                        : constant Enum := 16#05E5#;
  IL_LIB_JP2_ERROR                        : constant Enum := 16#05E6#;
  IL_LIB_EXR_ERROR                        : constant Enum := 16#05E7#;
  IL_UNKNOWN_ERROR                        : constant Enum := 16#05FF#;

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

end Imago.IL;

pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL).                                                     --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program is Free Software: You can redistribute it and/or modify    --
--  it under the terms of The GNU General Public License as published by    --
--    the Free Software Foundation: either version 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program is distributed in the hope that it will be useful,     --
--      but WITHOUT ANY WARRANTY; without even the implied warranty of      --
--      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the        --
--              GNU General Public License for more details.                --
--                                                                          --
--    You should have received a copy of the GNU General Public License     --
--   along with this program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
------------------------------------------------------------------------------
with System;

with Imago.Binary;
use Imago;

package Imago.IL is

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

                              ---------------
                              -- T Y P E S --
                              ---------------

  --------------------------------------------------------------------------
  -- New names for old types.
  subtype Bitfield  is Binary.Word;
  subtype Bool      is Binary.Byte;
  subtype Byte      is Binary.S_Byte;
  subtype ClampD    is Long_Float   range 0.0 .. 1.0;
  subtype ClampF    is Float        range 0.0 .. 1.0;
  subtype ClampH    is Short_Float  range 0.0 .. 1.0;
  subtype Double    is Long_Float;
  subtype Int       is Integer;
  subtype Short     is Short_Integer;
  subtype SizeI     is Integer;
  subtype UByte     is Binary.Byte;
  subtype UShort    is Binary.Short;
  subtype UInt      is Binary.Word;
  subtype Pointer   is System.Address;

  --------------------------------------------------------------------------
  -- Try to bring some touch of order to the ILenum mess.
  subtype Enum is Binary.Word;

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

                          -----------------------
                          -- C O N S T A N T S --
                          -----------------------

  --------------------------------------------------------------------------
  -- Useful values.
  Null_Pointer: constant Pointer := System.Null_Address;

  --------------------------------------------------------------------------
  -- "Enumeration" constants.
  IL_FALSE                                : constant Bool := 16#0#;
  IL_TRUE                                 : constant Bool := 16#1#;

  -- Data formats.
  IL_COLOUR_INDEX                         : constant Enum := 16#1900#;
  IL_COLOR_INDEX                          : constant Enum := 16#1900#;
  IL_ALPHA                                : constant Enum := 16#1906#;
  IL_RGB                                  : constant Enum := 16#1907#;
  IL_RGBA                                 : constant Enum := 16#1908#;
  IL_BGR                                  : constant Enum := 16#80E0#;
  IL_BGRA                                 : constant Enum := 16#80E1#;
  IL_LUMINANCE                            : constant Enum := 16#1909#;
  IL_LUMINANCE_ALPHA                      : constant Enum := 16#190A#;

  -- Types of data.
  IL_BYTE                                 : constant Enum := 16#1400#;
  IL_UNSIGNED_BYTE                        : constant Enum := 16#1401#;
  IL_SHORT                                : constant Enum := 16#1402#;
  IL_UNSIGNED_SHORT                       : constant Enum := 16#1403#;
  IL_INT                                  : constant Enum := 16#1404#;
  IL_UNSIGNED_INT                         : constant Enum := 16#1405#;
  IL_FLOAT                                : constant Enum := 16#1406#;
  IL_DOUBLE                               : constant Enum := 16#140A#;
  IL_HALF                                 : constant Enum := 16#140B#;

  -- IL specific defines.
  IL_VENDOR                               : constant Enum := 16#1F00#;
  IL_LOAD_EXT                             : constant Enum := 16#1F01#;
  IL_SAVE_EXT                             : constant Enum := 16#1F02#;

  IL_VERSION_1_7_8                        : constant Enum := 16#1#;
  IL_VERSION                              : constant Enum := 178;

  -- Attribute bits.
  IL_ORIGIN_BIT                           : constant Bitfield := 16#0000_0001#;
  IL_FILE_BIT                             : constant Bitfield := 16#0000_0002#;
  IL_PAL_BIT                              : constant Bitfield := 16#0000_0004#;
  IL_FORMAT_BIT                           : constant Bitfield := 16#0000_0008#;
  IL_TYPE_BIT                             : constant Bitfield := 16#0000_0010#;
  IL_COMPRESS_BIT                         : constant Bitfield := 16#0000_0020#;
  IL_LOADFAIL_BIT                         : constant Bitfield := 16#0000_0040#;
  IL_FORMAT_SPECIFIC_BIT                  : constant Bitfield := 16#0000_0080#;
  IL_ALL_ATTRIB_BITS                      : constant Bitfield := 16#000F_FFFF#;

  -- Types of palettes.
  IL_PAL_NONE                             : constant Enum := 16#0400#;
  IL_PAL_RGB24                            : constant Enum := 16#0401#;
  IL_PAL_RGB32                            : constant Enum := 16#0402#;
  IL_PAL_RGBA32                           : constant Enum := 16#0403#;
  IL_PAL_BGR24                            : constant Enum := 16#0404#;
  IL_PAL_BGR32                            : constant Enum := 16#0405#;
  IL_PAL_BGRA32                           : constant Enum := 16#0406#;

  -- Types of images.
  IL_TYPE_UNKNOWN                         : constant Enum := 16#0000#;
  IL_BMP                                  : constant Enum := 16#0420#;
  IL_CUT                                  : constant Enum := 16#0421#;
  IL_DOOM                                 : constant Enum := 16#0422#;
  IL_DOOM_FLAT                            : constant Enum := 16#0423#;
  IL_ICO                                  : constant Enum := 16#0424#;
  IL_JPG                                  : constant Enum := 16#0425#;
  IL_JFIF                                 : constant Enum := 16#0425#;
  IL_ILBM                                 : constant Enum := 16#0426#;
  IL_PCD                                  : constant Enum := 16#0427#;
  IL_PCX                                  : constant Enum := 16#0428#;
  IL_PIC                                  : constant Enum := 16#0429#;
  IL_PNG                                  : constant Enum := 16#042A#;
  IL_PNM                                  : constant Enum := 16#042B#;
  IL_SGI                                  : constant Enum := 16#042C#;
  IL_TGA                                  : constant Enum := 16#042D#;
  IL_TIF                                  : constant Enum := 16#042E#;
  IL_CHEAD                                : constant Enum := 16#042F#;
  IL_RAW                                  : constant Enum := 16#0430#;
  IL_MDL                                  : constant Enum := 16#0431#;
  IL_WAL                                  : constant Enum := 16#0432#;
  IL_LIF                                  : constant Enum := 16#0434#;
  IL_MNG                                  : constant Enum := 16#0435#;
  IL_JNG                                  : constant Enum := 16#0435#;
  IL_GIF                                  : constant Enum := 16#0436#;
  IL_DDS                                  : constant Enum := 16#0437#;
  IL_DCX                                  : constant Enum := 16#0438#;
  IL_PSD                                  : constant Enum := 16#0439#;
  IL_EXIF                                 : constant Enum := 16#043A#;
  IL_PSP                                  : constant Enum := 16#043B#;
  IL_PIX                                  : constant Enum := 16#043C#;
  IL_PXR                                  : constant Enum := 16#043D#;
  IL_XPM                                  : constant Enum := 16#043E#;
  IL_HDR                                  : constant Enum := 16#043F#;
  IL_ICNS                                 : constant Enum := 16#0440#;
  IL_JP2                                  : constant Enum := 16#0441#;
  IL_EXR                                  : constant Enum := 16#0442#;
  IL_WDP                                  : constant Enum := 16#0443#;
  IL_VTF                                  : constant Enum := 16#0444#;
  IL_WBMP                                 : constant Enum := 16#0445#;
  IL_SUN                                  : constant Enum := 16#0446#;
  IL_IFF                                  : constant Enum := 16#0447#;
  IL_TPL                                  : constant Enum := 16#0448#;
  IL_FITS                                 : constant Enum := 16#0449#;
  IL_DICOM                                : constant Enum := 16#044A#;
  IL_IWI                                  : constant Enum := 16#044B#;
  IL_BLP                                  : constant Enum := 16#044C#;
  IL_FTX                                  : constant Enum := 16#044D#;
  IL_ROT                                  : constant Enum := 16#044E#;
  IL_TEXTURE                              : constant Enum := 16#044F#;
  IL_DPX                                  : constant Enum := 16#0450#;
  IL_UTX                                  : constant Enum := 16#0451#;
  IL_MP3                                  : constant Enum := 16#0452#;

  IL_JASC_PAL                             : constant Enum := 16#0475#;

  -- Types of errors.
  IL_NO_ERROR                             : constant Enum := 16#0000#;
  IL_INVALID_ENUM                         : constant Enum := 16#0501#;
  IL_OUT_OF_MEMORY                        : constant Enum := 16#0502#;
  IL_FORMAT_NOT_SUPPORTED                 : constant Enum := 16#0503#;
  IL_INTERNAL_ERROR                       : constant Enum := 16#0504#;
  IL_INVALID_VALUE                        : constant Enum := 16#0505#;
  IL_ILLEGAL_OPERATION                    : constant Enum := 16#0506#;
  IL_ILLEGAL_FILE_VALUE                   : constant Enum := 16#0507#;
  IL_INVALID_FILE_HEADER                  : constant Enum := 16#0508#;
  IL_INVALID_PARAM                        : constant Enum := 16#0509#;
  IL_COULD_NOT_OPEN_FILE                  : constant Enum := 16#050A#;
  IL_INVALID_EXTENSION                    : constant Enum := 16#050B#;
  IL_FILE_ALREADY_EXISTS                  : constant Enum := 16#050C#;
  IL_OUT_FORMAT_SAME                      : constant Enum := 16#050D#;
  IL_STACK_OVERFLOW                       : constant Enum := 16#050E#;
  IL_STACK_UNDERFLOW                      : constant Enum := 16#050F#;
  IL_INVALID_CONVERSION                   : constant Enum := 16#0510#;
  IL_BAD_DIMENSIONS                       : constant Enum := 16#0511#;
  IL_FILE_READ_ERROR                      : constant Enum := 16#0512#;
  IL_FILE_WRITE_ERROR                     : constant Enum := 16#0513#;

  IL_LIB_GIF_ERROR                        : constant Enum := 16#05E1#;
  IL_LIB_JPEG_ERROR                       : constant Enum := 16#05E2#;
  IL_LIB_PNG_ERROR                        : constant Enum := 16#05E3#;
  IL_LIB_TIFF_ERROR                       : constant Enum := 16#05E4#;
  IL_LIB_MNG_ERROR                        : constant Enum := 16#05E5#;
  IL_LIB_JP2_ERROR                        : constant Enum := 16#05E6#;
  IL_LIB_EXR_ERROR                        : constant Enum := 16#05E7#;
  IL_UNKNOWN_ERROR                        : constant Enum := 16#05FF#;

  -- Origin definitions.
  IL_ORIGIN_SET                           : constant Enum := 16#0600#;
  IL_ORIGIN_LOWER_LEFT                    : constant Enum := 16#0601#;
  IL_ORIGIN_UPPER_LEFT                    : constant Enum := 16#0602#;
  IL_ORIGIN_MODE                          : constant Enum := 16#0603#;

  -- Format and type mode definitions.
  IL_FORMAT_SET                           : constant Enum := 16#0610#;
  IL_FORMAT_MODE                          : constant Enum := 16#0611#;
  IL_TYPE_SET                             : constant Enum := 16#0612#;
  IL_TYPE_MODE                            : constant Enum := 16#0613#;

  -- File definitions.
  IL_FILE_OVERWRITE                       : constant Enum := 16#0620#;
  IL_FILE_MODE                            : constant Enum := 16#0621#;

  -- Palette difinitions.
  IL_CONV_PAL                             : constant Enum := 16#0630#;

  -- Load fail definitions.
  IL_DEFAULT_ON_FAIL                      : constant Enum := 16#0632#;

  -- Key colour and alpha definitions.
  IL_USE_KEY_COLOUR                       : constant Enum := 16#0635#;
  IL_USE_KEY_COLOR                        : constant Enum := 16#0635#;
  IL_BLIT_BLEND                           : constant Enum := 16#0636#;

  -- Interlace definitions.
  IL_SAVE_INTERLACED                      : constant Enum := 16#0639#;
  IL_INTERLACE_MODE                       : constant Enum := 16#063A#;

  -- Quantization definitions.
  IL_QUANTIZATION_MODE                    : constant Enum := 16#0640#;
  IL_WU_QUANT                             : constant Enum := 16#0641#;
  IL_NEU_QUANT                            : constant Enum := 16#0642#;
  IL_NEU_QUANT_SAMPLE                     : constant Enum := 16#0643#;
  IL_MAX_QUANT_INDEXS                     : constant Enum := 16#0644#;
  IL_MAX_QUANT_INDICES                    : constant Enum := 16#0644#;

  -- Hints.
  IL_FASTEST                              : constant Enum := 16#0660#;
  IL_LESS_MEM                             : constant Enum := 16#0661#;
  IL_DONT_CARE                            : constant Enum := 16#0662#;
  IL_MEM_SPEED_HINT                       : constant Enum := 16#0665#;
  IL_USE_COMPRESSION                      : constant Enum := 16#0666#;
  IL_NO_COMPRESSION                       : constant Enum := 16#0667#;
  IL_COMPRESSION_HINT                     : constant Enum := 16#0668#;

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

end Imago.IL;

Add additional definitions.

Add additional definitions.

Signed-off-by: darkestkhan <e9a7a7cf2a6af79e93742343a7a5cac5d90f9bd2@gmail.com>


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 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 Util.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
with Security.Auth.OAuth.Googleplus;
package body Security.Auth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth");

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : Manager_Access;
   begin
      if Provider = PROVIDER_OPENID then
         Impl := new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         Impl := new Security.Auth.OAuth.Facebook.Manager;

      elsif Provider = PROVIDER_GOOGLE_PLUS then
         Impl := new Security.Auth.OAuth.Googleplus.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth;

-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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 Util.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
with Security.Auth.OAuth.Googleplus;
package body Security.Auth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth");

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Default factory used by `Initialize`.  It supports OpenID, Google, Facebook.
   --  ------------------------------
   function Default_Factory (Provider : in String) return Manager_Access is
   begin
      if Provider = PROVIDER_OPENID then
         return new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         return new Security.Auth.OAuth.Facebook.Manager;

      elsif Provider = PROVIDER_GOOGLE_PLUS then
         return new Security.Auth.OAuth.Googleplus.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
   end Default_Factory;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
   begin
      Initialize (Realm, Params, Default_Factory'Access, Name);
   end Initialize;

   procedure Initialize (Realm   : in out Manager;
                         Params  : in Parameters'Class;
                         Factory : not null
                         access function (Name : in String) return Manager_Access;
                         Name    : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : constant Manager_Access := Factory (Provider);
   begin
      if Impl = null then
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth;

Add Default_Factory function and new Initialize procedure to allow adding new OAuth providers more easily


------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Conditionals.Strings.Tests is

   procedure Check
     (Test : in out NT.Test;
      Context : in Strings.Context;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True);

   procedure Check
     (Test : in out NT.Test;
      Value : in String;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Check
     (Test : in out NT.Test;
      Context : in Strings.Context;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True)
   is
      function Match_Image return String;

      Cursor : Caches.Cursor := Expression.First;

      function Match_Image return String is
      begin
         if Expected then
            return " does not match ";
         else
            return " does match ";
         end if;
      end Match_Image;
   begin
      if Evaluate (Context, Cursor) /= Expected then
         Test.Fail ('"' & Context.Data.all & '"' & Match_Image & Image);
      end if;
   end Check;

   procedure Check
     (Test : in out NT.Test;
      Value : in String;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True)
   is
      function Match_Image return String;

      Cursor : Caches.Cursor := Expression.First;

      function Match_Image return String is
      begin
         if Expected then
            return " does not match ";
         else
            return " does match ";
         end if;
      end Match_Image;
   begin
      if Evaluate (Value, Cursor) /= Expected then
         Test.Fail ('"' & Value & '"' & Match_Image & Image);
      end if;
   end Check;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Basic_Usage (Report);
      Fallbacks (Report);
   end All_Tests;

   ----------------------
   -- Individual Tests --
   ----------------------

   procedure Basic_Usage (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Basic usage");
   begin
      declare
         procedure Check (Value : in String; Expected : in Boolean := True);

         Image : constant String := "Expression 1";
         Exp : constant Caches.Reference := Test_Tools.To_S_Expression
           ("(or is-empty (starts-with Hi)"
            & "(and (contains 1:.) (contains-any-of 1:! 1:?))"
            & "(case-insensitive (or (contains aLiCe)"
            & " (case-sensitive (contains Bob))))"
            & "(not is-ascii))");

         procedure Check (Value : in String; Expected : in Boolean := True) is
         begin
            Check (Test, Value, Exp, Image, Expected);
         end Check;
      begin
         Check ("");
         Check ("A", False);
         Check ("Hi, my name is John.");
         Check ("Hello, my name is John.", False);
         Check ("Hello. My name is John!");
         Check ("Hello. My name is John?");
         Check ("Alice and Bob");
         Check ("BOBBY!", False);
         Check ("AlicE and Malory");
         Check ("©");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Basic_Usage;

   procedure Fallbacks (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Fallback functions");
   begin
      declare
         procedure Check
           (Value : in String;
            With_Fallback : in Boolean);

         procedure Check_Counts
           (Expected_Parametric, Expected_Simple : in Natural);

         function Parametric_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom;
            Arguments : in out Lockable.Descriptor'Class)
           return Boolean;

         function Simple_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom)
           return Boolean;

         Parametric_Count : Natural := 0;
         Simple_Count : Natural := 0;

         Exp : constant Caches.Reference := Test_Tools.To_S_Expression
           ("(or"
            & "(and (starts-with a) non-existant)"
            & "(does-not-exist ohai ()))");

         procedure Check
           (Value : in String;
            With_Fallback : in Boolean)
         is
            Copy : aliased constant String := Value;
            Context : Strings.Context
              (Data => Copy'Access,
               Parametric_Fallback => (if With_Fallback
                                       then Parametric_Fallback'Access
                                       else null),
               Simple_Fallback     => (if With_Fallback
                                       then Simple_Fallback'Access
                                       else null));
         begin
            Context.Settings.Case_Sensitive := False;

            begin
               Check (Test, Context, Exp, "Fallback expression");

               if not With_Fallback then
                  Test.Fail ("Exception expected from """ & Value & '"');
               end if;
            exception
               when Constraint_Error =>
                  if With_Fallback then
                     raise;
                  end if;
            end;
         end Check;

         procedure Check_Counts
           (Expected_Parametric, Expected_Simple : in Natural) is
         begin
            if Parametric_Count /= Expected_Parametric then
               Test.Fail ("Parametric_Count is"
                 & Natural'Image (Parametric_Count) & ", expected"
                 & Natural'Image (Expected_Parametric));
            end if;

            if Simple_Count /= Expected_Simple then
               Test.Fail ("Simple_Count is"
                 & Natural'Image (Simple_Count) & ", expected"
                 & Natural'Image (Expected_Simple));
            end if;
         end Check_Counts;

         function Parametric_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom;
            Arguments : in out Lockable.Descriptor'Class)
           return Boolean
         is
            pragma Unreferenced (Settings, Arguments);
         begin
            Parametric_Count := Parametric_Count + 1;
            return To_String (Name) = "does-not-exist";
         end Parametric_Fallback;

         function Simple_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom)
           return Boolean
         is
            pragma Unreferenced (Settings);
         begin
            Simple_Count := Simple_Count + 1;
            return To_String (Name) = "non-existant";
         end Simple_Fallback;
      begin
         Check ("Oook?", False);
         Check ("Alice", False);
         Check ("Alpha", True);
         Check_Counts (0, 1);
         Check ("Bob", True);
         Check_Counts (1, 1);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Fallbacks;

end Natools.S_Expressions.Conditionals.Strings.Tests;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Conditionals.Strings.Tests is

   procedure Check
     (Test : in out NT.Test;
      Context : in Strings.Context;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True);

   procedure Check
     (Test : in out NT.Test;
      Value : in String;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Check
     (Test : in out NT.Test;
      Context : in Strings.Context;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True)
   is
      function Match_Image return String;

      Cursor : Caches.Cursor := Expression.First;

      function Match_Image return String is
      begin
         if Expected then
            return " does not match ";
         else
            return " does match ";
         end if;
      end Match_Image;
   begin
      if Evaluate (Context, Cursor) /= Expected then
         Test.Fail ('"' & Context.Data.all & '"' & Match_Image & Image);
      end if;
   end Check;

   procedure Check
     (Test : in out NT.Test;
      Value : in String;
      Expression : in Caches.Reference;
      Image : in String;
      Expected : in Boolean := True)
   is
      function Match_Image return String;

      Cursor : Caches.Cursor := Expression.First;

      function Match_Image return String is
      begin
         if Expected then
            return " does not match ";
         else
            return " does match ";
         end if;
      end Match_Image;
   begin
      if Evaluate (Value, Cursor) /= Expected then
         Test.Fail ('"' & Value & '"' & Match_Image & Image);
      end if;
   end Check;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Basic_Usage (Report);
      Fallbacks (Report);
   end All_Tests;

   ----------------------
   -- Individual Tests --
   ----------------------

   procedure Basic_Usage (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Basic usage");
   begin
      declare
         procedure Check (Value : in String; Expected : in Boolean := True);

         Image : constant String := "Expression 1";
         Exp : constant Caches.Reference := Test_Tools.To_S_Expression
           ("(or is-empty (starts-with Hi)"
            & "(is BY) (case-insensitive (is HELLO))"
            & "(and (contains 1:.) (contains-any-of 1:! 1:?))"
            & "(case-insensitive (or (contains aLiCe)"
            & " (case-sensitive (contains Bob))))"
            & "(not is-ascii))");

         procedure Check (Value : in String; Expected : in Boolean := True) is
         begin
            Check (Test, Value, Exp, Image, Expected);
         end Check;
      begin
         Check ("");
         Check ("A", False);
         Check ("Hi, my name is John.");
         Check ("Hello, my name is John.", False);
         Check ("Hello. My name is John!");
         Check ("Hello. My name is John?");
         Check ("Alice and Bob");
         Check ("BOBBY!", False);
         Check ("AlicE and Malory");
         Check ("©");
         Check ("BY");
         Check ("By", False);
         Check ("Hello");
         Check ("Hell", False);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Basic_Usage;

   procedure Fallbacks (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Fallback functions");
   begin
      declare
         procedure Check
           (Value : in String;
            With_Fallback : in Boolean);

         procedure Check_Counts
           (Expected_Parametric, Expected_Simple : in Natural);

         function Parametric_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom;
            Arguments : in out Lockable.Descriptor'Class)
           return Boolean;

         function Simple_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom)
           return Boolean;

         Parametric_Count : Natural := 0;
         Simple_Count : Natural := 0;

         Exp : constant Caches.Reference := Test_Tools.To_S_Expression
           ("(or"
            & "(and (starts-with a) non-existant)"
            & "(does-not-exist ohai ()))");

         procedure Check
           (Value : in String;
            With_Fallback : in Boolean)
         is
            Copy : aliased constant String := Value;
            Context : Strings.Context
              (Data => Copy'Access,
               Parametric_Fallback => (if With_Fallback
                                       then Parametric_Fallback'Access
                                       else null),
               Simple_Fallback     => (if With_Fallback
                                       then Simple_Fallback'Access
                                       else null));
         begin
            Context.Settings.Case_Sensitive := False;

            begin
               Check (Test, Context, Exp, "Fallback expression");

               if not With_Fallback then
                  Test.Fail ("Exception expected from """ & Value & '"');
               end if;
            exception
               when Constraint_Error =>
                  if With_Fallback then
                     raise;
                  end if;
            end;
         end Check;

         procedure Check_Counts
           (Expected_Parametric, Expected_Simple : in Natural) is
         begin
            if Parametric_Count /= Expected_Parametric then
               Test.Fail ("Parametric_Count is"
                 & Natural'Image (Parametric_Count) & ", expected"
                 & Natural'Image (Expected_Parametric));
            end if;

            if Simple_Count /= Expected_Simple then
               Test.Fail ("Simple_Count is"
                 & Natural'Image (Simple_Count) & ", expected"
                 & Natural'Image (Expected_Simple));
            end if;
         end Check_Counts;

         function Parametric_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom;
            Arguments : in out Lockable.Descriptor'Class)
           return Boolean
         is
            pragma Unreferenced (Settings, Arguments);
         begin
            Parametric_Count := Parametric_Count + 1;
            return To_String (Name) = "does-not-exist";
         end Parametric_Fallback;

         function Simple_Fallback
           (Settings : in Strings.Settings;
            Name : in Atom)
           return Boolean
         is
            pragma Unreferenced (Settings);
         begin
            Simple_Count := Simple_Count + 1;
            return To_String (Name) = "non-existant";
         end Simple_Fallback;
      begin
         Check ("Oook?", False);
         Check ("Alice", False);
         Check ("Alpha", True);
         Check_Counts (0, 1);
         Check ("Bob", True);
         Check_Counts (1, 1);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Fallbacks;

end Natools.S_Expressions.Conditionals.Strings.Tests;

test the new equality test

s_expressions-conditionals-strings-tests: test the new equality test