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

with Wiki.Documents;
with Wiki.Attributes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   package Wide_Wide_String_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Unbounded_Wide_Wide_String);

   subtype Wide_Wide_String_Vector is Wide_Wide_String_Vectors.Vector;
   subtype Wide_Wide_String_Cursor is Wide_Wide_String_Vectors.Cursor;

   type Parser is limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Token               : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
      Html_Stack          : Wide_Wide_String_Vector;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   procedure Start_Element (P          : in out Parser;
                            Name       : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type);

   procedure End_Element (P    : in out Parser;
                          Name : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Flush the pending HTML stack elements.
   procedure Flush_Stack (P : in out Parser);

end Wiki.Parsers;

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

with Wiki.Documents;
with Wiki.Attributes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   type Parser is limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Token               : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   procedure Start_Element (P          : in out Parser;
                            Name       : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type);

   procedure End_Element (P    : in out Parser;
                          Name : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

end Wiki.Parsers;

Remove the Html_Stack (must use the HTML filter instead)


------------------------------------------------------------------------------
-- Copyright (c) 2014-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.Lockable.Tests;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Parsers.Tests is

   generic
      Name : String;
      Source, Expected : Atom;
   procedure Blackbox_Test (Report : in out NT.Reporter'Class);
      --  Perform a simple blackbox test, feeding Source to a new parser
      --  plugged on a canonical printer and comparing with Expected.

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

   procedure Blackbox_Test (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item (Name);
   begin
      declare
         Input, Output : aliased Test_Tools.Memory_Stream;
         Printer : Printers.Canonical (Output'Access);
         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Output.Set_Expected (Expected);
         Input.Set_Data (Source);
         Parser.Next;
         Printers.Transfer (Parser, Printer);
         Output.Check_Stream (Test);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Blackbox_Test;

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

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Canonical_Encoding (Report);
      Atom_Encodings (Report);
      Base64_Subexpression (Report);
      Special_Subexpression (Report);
      Nested_Subpexression (Report);
      Number_Prefixes (Report);
      Quoted_Escapes (Report);
      Lockable_Interface (Report);
      Reset (Report);
      Locked_Next (Report);
      Memory_Parser (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Atom_Encodings (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Basic atom encodings",
         Source => To_Atom ("17:Verbatim encoding"
           & """Quoted\040string"""
           & "#48657861646563696d616c2064756d70#"
           & "token "
           & "|QmFzZS02NCBlbmNvZGluZw==|"),
         Expected => To_Atom ("17:Verbatim encoding"
           & "13:Quoted string"
           & "16:Hexadecimal dump"
           & "5:token"
           & "16:Base-64 encoding"));
   begin
      Test (Report);
   end Atom_Encodings;

   procedure Canonical_Encoding (Report : in out NT.Reporter'Class) is
      Sample_Image : constant String
        := "3:The(5:quick((5:brown3:fox)5:jumps))9:over3:the()4:lazy0:3:dog";

      procedure Test is new Blackbox_Test
        (Name => "Canonical encoding",
         Source => To_Atom (Sample_Image),
         Expected => To_Atom (Sample_Image));
   begin
      Test (Report);
   end Canonical_Encoding;

   procedure Base64_Subexpression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Base-64 subexpression",
         Source => To_Atom ("head({KDc6c3VibGlzdCk1OnRva2Vu})""tail"""),
         Expected => To_Atom ("4:head((7:sublist)5:token)4:tail"));
   begin
      Test (Report);
   end Base64_Subexpression;

   procedure Lockable_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Lockable.Descriptor interface");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Input.Set_Data (Lockable.Tests.Test_Expression);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Lockable.Tests.Test_Interface (Test, Parser);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Lockable_Interface;

   procedure Locked_Next (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Next on locked parser");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
         Lock_State : Lockable.Lock_State;
      begin
         Input.Set_Data (To_Atom ("(command (subcommand arg (arg list)))0:"));
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("subcommand"), 2);
         Parser.Lock (Lock_State);
         Test_Tools.Test_Atom_Accessors
           (Test, Parser, To_Atom ("subcommand"), 0);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Parser.Unlock (Lock_State);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Null_Atom, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Locked_Next;

   procedure Memory_Parser (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Memory-backed parser");
   begin
      declare
         Parser : Parsers.Memory_Parser
           := Create_From_String ("(command (subcommand arg (arg list)))0:");
      begin
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("subcommand"), 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 3);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 3);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 3);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Null_Atom, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Memory_Parser;

   procedure Nested_Subpexression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Nested base-64 subepxressions",
         Source => To_Atom ("(5:begin"
           & "{KG5lc3RlZCB7S0dSbFpYQWdjR0Y1Ykc5aFpDaz19KQ==}"
           & "end)"),
         Expected => To_Atom ("(5:begin"
           & "(6:nested(4:deep7:payload))"
           & "3:end)"));
   begin
      Test (Report);
   end Nested_Subpexression;

   procedure Number_Prefixes (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Number prefixes",
         Source => To_Atom ("8:verbatim"
           & "(valid 6""quoted"" 11#68657861646563696d616c#"
           & " 7|YmFzZS02NA==| 9{NzpleHByLTY0})"
           & "(undefined 42 10% 123() 10)"
           & "(invalid 10""quoted"" 3#68657861646563696d616c#"
           & " 75|YmFzZS02NA==| 1{NzpleHByLTY0})"),
         Expected => To_Atom ("8:verbatim"
           & "(5:valid6:quoted11:hexadecimal7:base-647:expr-64)"
           & "(9:undefined2:423:10%3:123()2:10)"
           & "(7:invalid6:quoted11:hexadecimal7:base-647:expr-64)"));
   begin
      Test (Report);
   end Number_Prefixes;

   procedure Quoted_Escapes (Report : in out NT.Reporter'Class) is
      CR : constant Character := Character'Val (13);
      LF : constant Character := Character'Val (10);

      procedure Test is new Blackbox_Test
        (Name => "Escapes in quoted encoding",
         Source => To_Atom ("(single-letters ""\b\t\n\v\f\r\\\k"")"
           & "(newlines ""head\" & CR & "tail"" ""head\" & LF & "tail"""
           & " ""head\" & CR & LF & "tail"" ""head\" & LF & CR & "tail"")"
           & "(octal ""head\040\04\xtail"")"
           & "(hexadecimal ""head\x20\x2a\x2D\x2gtail"")"
           & "(special ""\x""1:"")"),
         Expected => To_Atom ("(14:single-letters9:"
           & Character'Val (8) & Character'Val (9)
           & Character'Val (10) & Character'Val (11)
           & Character'Val (12) & Character'Val (13)
           & "\\k)"
           & "(8:newlines8:headtail8:headtail8:headtail8:headtail)"
           & "(5:octal14:head \04\xtail)"
           & "(11:hexadecimal15:head *-\x2gtail)"
           & "(7:special2:\x1:"")"));
   begin
      Test (Report);
   end Quoted_Escapes;

   procedure Reset (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parser reset");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
         Empty : Parsers.Stream_Parser (Input'Access);

         use type Atom_Buffers.Atom_Buffer;
         use type Lockable.Lock_Stack;
      begin
         Input.Write (To_Atom ("(begin(first second"));
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("begin"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 2);
         Parser.Reset (Hard => False);
         Input.Write (To_Atom ("other(new list)end"));
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("other"), 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("new"), 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Parser.Reset (Hard => True);

         if Parser.Internal /= Empty.Internal
           or else Parser.Next_Event /= Empty.Next_Event
           or else Parser.Latest /= Empty.Latest
           or else Parser.Pending.Capacity /= 0
           or else Parser.Buffer.Capacity /= 0
           or else Parser.Level /= Empty.Level
           or else Parser.Lock_Stack /= Empty.Lock_Stack
           or else Parser.Locked /= Empty.Locked
         then
            Test.Fail ("Parser after hard reset is not empty");
         end if;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Reset;

   procedure Special_Subexpression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Special base-64 subexpression",
         Source => To_Atom ("(begin "
           & "{aGlkZGVuLWVuZCkoaGlkZGVuLWJlZ2lu}"
           & " end)"
           & "({MTY6b3ZlcmZsb3dpbmc=} atom)"),
         Expected => To_Atom ("(5:begin"
           & "10:hidden-end)(12:hidden-begin"
           & "3:end)"
           & "(16:overflowing atom)"));
   begin
      Test (Report);
   end Special_Subexpression;

end Natools.S_Expressions.Parsers.Tests;

------------------------------------------------------------------------------
-- Copyright (c) 2014-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.Lockable.Tests;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Parsers.Tests is

   generic
      Name : String;
      Source, Expected : Atom;
   procedure Blackbox_Test (Report : in out NT.Reporter'Class);
      --  Perform a simple blackbox test, feeding Source to a new parser
      --  plugged on a canonical printer and comparing with Expected.

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

   procedure Blackbox_Test (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item (Name);
   begin
      declare
         Input, Output : aliased Test_Tools.Memory_Stream;
         Printer : Printers.Canonical (Output'Access);
         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Output.Set_Expected (Expected);
         Input.Set_Data (Source);
         Parser.Next;
         Printers.Transfer (Parser, Printer);
         Output.Check_Stream (Test);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Blackbox_Test;

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

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Canonical_Encoding (Report);
      Atom_Encodings (Report);
      Base64_Subexpression (Report);
      Special_Subexpression (Report);
      Nested_Subpexression (Report);
      Number_Prefixes (Report);
      Quoted_Escapes (Report);
      Lockable_Interface (Report);
      Reset (Report);
      Locked_Next (Report);
      Memory_Parser (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Atom_Encodings (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Basic atom encodings",
         Source => To_Atom ("17:Verbatim encoding"
           & """Quoted\040string"""
           & "#48657861646563696d616c2064756d70#"
           & "token "
           & "|QmFzZS02NCBlbmNvZGluZw==|"),
         Expected => To_Atom ("17:Verbatim encoding"
           & "13:Quoted string"
           & "16:Hexadecimal dump"
           & "5:token"
           & "16:Base-64 encoding"));
   begin
      Test (Report);
   end Atom_Encodings;

   procedure Base64_Subexpression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Base-64 subexpression",
         Source => To_Atom ("head({KDc6c3VibGlzdCk1OnRva2Vu})""tail"""),
         Expected => To_Atom ("4:head((7:sublist)5:token)4:tail"));
   begin
      Test (Report);
   end Base64_Subexpression;

   procedure Canonical_Encoding (Report : in out NT.Reporter'Class) is
      Sample_Image : constant String
        := "3:The(5:quick((5:brown3:fox)5:jumps))9:over3:the()4:lazy0:3:dog";

      procedure Test is new Blackbox_Test
        (Name => "Canonical encoding",
         Source => To_Atom (Sample_Image),
         Expected => To_Atom (Sample_Image));
   begin
      Test (Report);
   end Canonical_Encoding;

   procedure Lockable_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Lockable.Descriptor interface");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Input.Set_Data (Lockable.Tests.Test_Expression);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Lockable.Tests.Test_Interface (Test, Parser);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Lockable_Interface;

   procedure Locked_Next (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Next on locked parser");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
         Lock_State : Lockable.Lock_State;
      begin
         Input.Set_Data (To_Atom ("(command (subcommand arg (arg list)))0:"));
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("subcommand"), 2);
         Parser.Lock (Lock_State);
         Test_Tools.Test_Atom_Accessors
           (Test, Parser, To_Atom ("subcommand"), 0);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Parser.Unlock (Lock_State);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Null_Atom, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Locked_Next;

   procedure Memory_Parser (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Memory-backed parser");
   begin
      declare
         Parser : Parsers.Memory_Parser
           := Create_From_String ("(command (subcommand arg (arg list)))0:");
      begin
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("subcommand"), 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 3);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("arg"), 3);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 3);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Parser, Null_Atom, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Memory_Parser;

   procedure Nested_Subpexression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Nested base-64 subepxressions",
         Source => To_Atom ("(5:begin"
           & "{KG5lc3RlZCB7S0dSbFpYQWdjR0Y1Ykc5aFpDaz19KQ==}"
           & "end)"),
         Expected => To_Atom ("(5:begin"
           & "(6:nested(4:deep7:payload))"
           & "3:end)"));
   begin
      Test (Report);
   end Nested_Subpexression;

   procedure Number_Prefixes (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Number prefixes",
         Source => To_Atom ("8:verbatim"
           & "(valid 6""quoted"" 11#68657861646563696d616c#"
           & " 7|YmFzZS02NA==| 9{NzpleHByLTY0})"
           & "(undefined 42 10% 123() 10)"
           & "(invalid 10""quoted"" 3#68657861646563696d616c#"
           & " 75|YmFzZS02NA==| 1{NzpleHByLTY0})"),
         Expected => To_Atom ("8:verbatim"
           & "(5:valid6:quoted11:hexadecimal7:base-647:expr-64)"
           & "(9:undefined2:423:10%3:123()2:10)"
           & "(7:invalid6:quoted11:hexadecimal7:base-647:expr-64)"));
   begin
      Test (Report);
   end Number_Prefixes;

   procedure Quoted_Escapes (Report : in out NT.Reporter'Class) is
      CR : constant Character := Character'Val (13);
      LF : constant Character := Character'Val (10);

      procedure Test is new Blackbox_Test
        (Name => "Escapes in quoted encoding",
         Source => To_Atom ("(single-letters ""\b\t\n\v\f\r\\\k"")"
           & "(newlines ""head\" & CR & "tail"" ""head\" & LF & "tail"""
           & " ""head\" & CR & LF & "tail"" ""head\" & LF & CR & "tail"")"
           & "(octal ""head\040\04\xtail"")"
           & "(hexadecimal ""head\x20\x2a\x2D\x2gtail"")"
           & "(special ""\x""1:"")"),
         Expected => To_Atom ("(14:single-letters9:"
           & Character'Val (8) & Character'Val (9)
           & Character'Val (10) & Character'Val (11)
           & Character'Val (12) & Character'Val (13)
           & "\\k)"
           & "(8:newlines8:headtail8:headtail8:headtail8:headtail)"
           & "(5:octal14:head \04\xtail)"
           & "(11:hexadecimal15:head *-\x2gtail)"
           & "(7:special2:\x1:"")"));
   begin
      Test (Report);
   end Quoted_Escapes;

   procedure Reset (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parser reset");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Stream_Parser (Input'Access);
         Empty : Parsers.Stream_Parser (Input'Access);

         use type Atom_Buffers.Atom_Buffer;
         use type Lockable.Lock_Stack;
      begin
         Input.Write (To_Atom ("(begin(first second"));
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("begin"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Parser, Events.End_Of_Input, 2);
         Parser.Reset (Hard => False);
         Input.Write (To_Atom ("other(new list)end"));
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("other"), 0);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("new"), 1);
         Test_Tools.Next_And_Check (Test, Parser, To_Atom ("list"), 1);
         Test_Tools.Next_And_Check (Test, Parser, Events.Close_List, 0);
         Parser.Reset (Hard => True);

         if Parser.Internal /= Empty.Internal
           or else Parser.Next_Event /= Empty.Next_Event
           or else Parser.Latest /= Empty.Latest
           or else Parser.Pending.Capacity /= 0
           or else Parser.Buffer.Capacity /= 0
           or else Parser.Level /= Empty.Level
           or else Parser.Lock_Stack /= Empty.Lock_Stack
           or else Parser.Locked /= Empty.Locked
         then
            Test.Fail ("Parser after hard reset is not empty");
         end if;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Reset;

   procedure Special_Subexpression (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Special base-64 subexpression",
         Source => To_Atom ("(begin "
           & "{aGlkZGVuLWVuZCkoaGlkZGVuLWJlZ2lu}"
           & " end)"
           & "({MTY6b3ZlcmZsb3dpbmc=} atom)"),
         Expected => To_Atom ("(5:begin"
           & "10:hidden-end)(12:hidden-begin"
           & "3:end)"
           & "(16:overflowing atom)"));
   begin
      Test (Report);
   end Special_Subexpression;

end Natools.S_Expressions.Parsers.Tests;

fix alphabetical ordering of tests

s_expressions-parsers-tests: fix alphabetical ordering of tests


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

with Util.Commands.Drivers;
with Util.Commands.Consoles;
with Util.Commands.Consoles.Text;
with Druss.Gateways;
package Druss.Commands is

   --  The list of fields that are printed on the console.
   type Field_Type is (F_IP_ADDR,
                       F_WAN_IP,
                       F_INTERNET,
                       F_VOIP,
                       F_WIFI,
                       F_WIFI5,
                       F_ACCESS_CONTROL,
                       F_DYNDNS,
                       F_DEVICES,
                       F_COUNT,
                       F_BOOL,
                       F_CHANNEL,
                       F_PROTOCOL,
                       F_ENCRYPTION,
                       F_SSID);

   --  The type of notice that are reported.
   type Notice_Type is (N_HELP,
                        N_INFO);

   --  Make the generic abstract console interface.
   package Consoles is
     new Util.Commands.Consoles (Field_Type  => Field_Type,
                                 Notice_Type => Notice_Type);

   --  And the text console to write on stdout (a Gtk console could be done someday).
   package Text_Consoles is
      new Consoles.Text;

   type Context_Type is limited record
      Gateways : Druss.Gateways.Gateway_Vector;
      Console  : Consoles.Console_Access;
   end record;

   package Drivers is
     new Util.Commands.Drivers (Context_Type => Context_Type,
                                Driver_Name  => "druss-drivers");

   subtype Argument_List is Util.Commands.Argument_List;

   Driver : Drivers.Driver_Type;

   procedure Gateway_Command (Command   : in Drivers.Command_Type'Class;
                              Args      : in Util.Commands.Argument_List'Class;
                              Arg_Pos   : in Positive;
                              Process   : access procedure (Gateway : in out Gateways.Gateway_Type;
                                                            Param   : in String);
                              Context   : in out Context_Type);

   procedure Initialize;

end Druss.Commands;

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

with Util.Commands.Drivers;
with Util.Commands.Consoles;
with Util.Commands.Consoles.Text;
with Druss.Gateways;
package Druss.Commands is

   --  The list of fields that are printed on the console.
   type Field_Type is (F_IP_ADDR,
                       F_WAN_IP,
                       F_INTERNET,
                       F_VOIP,
                       F_WIFI,
                       F_WIFI5,
                       F_ACCESS_CONTROL,
                       F_DYNDNS,
                       F_DEVICES,
                       F_COUNT,
                       F_BOOL,
                       F_CHANNEL,
                       F_PROTOCOL,
                       F_ENCRYPTION,
                       F_SSID);

   --  The type of notice that are reported.
   type Notice_Type is (N_HELP,
                        N_INFO);

   --  Make the generic abstract console interface.
   package Consoles is
     new Util.Commands.Consoles (Field_Type  => Field_Type,
                                 Notice_Type => Notice_Type);

   --  And the text console to write on stdout (a Gtk console could be done someday).
   package Text_Consoles is
      new Consoles.Text;

   type Context_Type is limited record
      Gateways : Druss.Gateways.Gateway_Vector;
      Console  : Consoles.Console_Access;
   end record;

   package Drivers is
     new Util.Commands.Drivers (Context_Type => Context_Type,
                                Driver_Name  => "druss-drivers");

   subtype Argument_List is Util.Commands.Argument_List;

   Driver : Drivers.Driver_Type;

   procedure Gateway_Command (Command   : in Drivers.Command_Type'Class;
                              Args      : in Util.Commands.Argument_List'Class;
                              Arg_Pos   : in Positive;
                              Process   : access procedure (Gateway : in out Gateways.Gateway_Type;
                                                            Param   : in String);
                              Context   : in out Context_Type);

   procedure Initialize;

   --  Print the bbox API status.
   procedure Print_Status (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

end Druss.Commands;

Declare the Print_Status procedure

Declare the Print_Status procedure


with Ada.IO_Exceptions;
with Interfaces.C.Strings;
with Interfaces.C;
with System;

package body OpenAL.Context is
  package C         renames Interfaces.C;
  package C_Strings renames Interfaces.C.Strings;

  function Open_Device
    (Specifier : in String) return Device_t
  is
    C_Spec : aliased C.char_array := C.To_C (Specifier);
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Open_Device
      (Specifier => C_Spec (C_Spec'First)'Address);
    return Device;
  end Open_Device;

  function Open_Default_Device return Device_t is
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Open_Device
      (Specifier => System.Null_Address);
    return Device;
  end Open_Default_Device;

  function Close_Device
    (Device : in Device_t) return Boolean is
  begin
    return Boolean (ALC_Thin.Close_Device (Device.Device_Data));
  end Close_Device;

  function Create_Context
    (Device : in Device_t) return Context_t is
  begin
    return Context_t (ALC_Thin.Create_Context
      (Device         => Device.Device_Data,
       Attribute_List => System.Null_Address));
  end Create_Context;

  function Make_Context_Current
    (Context : in Context_t) return Boolean is
  begin
    return Boolean (ALC_Thin.Make_Context_Current (ALC_Thin.Context_t (Context)));
  end Make_Context_Current;

  procedure Process_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Process_Context (ALC_Thin.Context_t (Context));
  end Process_Context;

  procedure Suspend_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Suspend_Context (ALC_Thin.Context_t (Context));
  end Suspend_Context;

  procedure Destroy_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Destroy_Context (ALC_Thin.Context_t (Context));
  end Destroy_Context;

  function Get_Current_Context return Context_t is
  begin
    return Context_t (ALC_Thin.Get_Current_Context);
  end Get_Current_Context;

  function Get_Context_Device (Context : in Context_t) return Device_t is
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Get_Contexts_Device (ALC_Thin.Context_t (Context));
    return Device;
  end Get_Context_Device;

  function Is_Extension_Present
    (Device : in Device_t;
     Name   : in String) return Boolean
  is
    C_Name : aliased C.char_array := C.To_C (Name);
  begin
    return Boolean (ALC_Thin.Is_Extension_Present
      (Device         => Device.Device_Data,
       Extension_Name => C_Name (C_Name'First)'Address));
  end Is_Extension_Present;

  --
  -- String queries
  --

  function Get_String
    (Device    : ALC_Thin.Device_t;
     Parameter : Types.Enumeration_t) return C_Strings.chars_ptr;
  pragma Import (C, Get_String, "alcGetString");

  use type ALC_Thin.Device_t;

  Null_Device : constant ALC_Thin.Device_t := ALC_Thin.Device_t (System.Null_Address);

  function Get_Default_Device_Specifier return String is
    CS : constant C_Strings.chars_ptr := Get_String
      (Device    => Null_Device,
       Parameter => ALC_Thin.ALC_DEFAULT_DEVICE_SPECIFIER));
  begin
    if CS /= C_Strings.null_ptr then
      return C_Strings.Value (CS);
    else
      raise Ada.IO_Exceptions.Device_Error with "no device available";
    end if;
  end Get_Default_Device_Specifier;

  function Get_Device_Specifier
    (Device : in Device_t) return String is
  begin
    if Device.Device_Data = Null_Device then
      raise Ada.IO_Exceptions.Device_Error with "invalid device";
    end if;

    return C_Strings.Value
      (Get_String
        (Device    => Device.Device_Data,
         Parameter => ALC_Thin.ALC_DEVICE_SPECIFIER));
  end Get_Device_Specifier;

  function Get_Extensions
    (Device : in Device_t) return String is
  begin
    if Device.Device_Data = Null_Device then
      raise Ada.IO_Exceptions.Device_Error with "invalid device";
    end if;

    return C_Strings.Value
      (Get_String
        (Device    => Device.Device_Data,
         Parameter => ALC_Thin.ALC_EXTENSIONS));
  end Get_Extensions;

  function Get_Default_Capture_Device_Specifier return String is
    CS : constant C_Strings.chars_ptr := Get_String
      (Device    => Null_Device,
       Parameter => ALC_Thin.ALC_CAPTURE_DEFAULT_DEVICE_SPECIFIER);
  begin
    if CS /= C_Strings.Null_Ptr then
      return C_Strings.Value (CS);
    else
      raise Ada.IO_Exceptions.Device_Error with "no capture device available";
    end if;
  end Get_Default_Capture_Device_Specifier;

  function Get_Available_Capture_Devices return OpenAL.List.String_Vector_t is
    Address : System.Address;
    List    : OpenAL.List.String_Vector_t;
  begin
    Address := ALC_Thin.Get_String
      (Device => ALC_Thin.Device_t (System.Null_Address),
       Token  => ALC_Thin.ALC_CAPTURE_DEVICE_SPECIFIER);
    if Address /= System.Null_Address then
      OpenAL.List.Address_To_Vector
        (Address => Address,
         List    => List);
    end if;

    return List;
  end Get_Available_Capture_Devices;

  function Get_Available_Playback_Devices return OpenAL.List.String_Vector_t is
    Address : System.Address;
    List    : OpenAL.List.String_Vector_t;
  begin
    Address := ALC_Thin.Get_String
      (Device => ALC_Thin.Device_t (System.Null_Address),
       Token  => ALC_Thin.ALC_DEVICE_SPECIFIER);
    if Address /= System.Null_Address then
      OpenAL.List.Address_To_Vector
        (Address => Address,
         List    => List);
    end if;

    return List;
  end Get_Available_Playback_Devices;

  --
  -- Integer queries
  --

  function Get_Major_Version
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MAJOR_VERSION,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Major_Version;

  function Get_Minor_Version
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MINOR_VERSION,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Minor_Version;

  function Get_Capture_Samples
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_CAPTURE_SAMPLES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Capture_Samples;

  function Get_Frequency
    (Device : in Device_t) return Types.Frequency_t
  is
    Value : aliased Types.Integer_t := Types.Frequency_t'First;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_FREQUENCY,
       Size   => 1,
       Data   => Value'Address);
    return Types.Frequency_t (Value);
  end Get_Frequency;

  function Get_Refresh
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_REFRESH,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Refresh;

  function Get_Synchronous
    (Device : in Device_t) return Boolean
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_SYNC,
       Size   => 1,
       Data   => Value'Address);
    return Boolean'Val (Value);
  end Get_Synchronous;

  function Get_Mono_Sources
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MONO_SOURCES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Mono_Sources;

  function Get_Stereo_Sources
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_STEREO_SOURCES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Stereo_Sources;

end OpenAL.Context;

with Ada.IO_Exceptions;
with Interfaces.C.Strings;
with Interfaces.C;
with System;

package body OpenAL.Context is
  package C         renames Interfaces.C;
  package C_Strings renames Interfaces.C.Strings;

  function Open_Device
    (Specifier : in String) return Device_t
  is
    C_Spec : aliased C.char_array := C.To_C (Specifier);
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Open_Device
      (Specifier => C_Spec (C_Spec'First)'Address);
    return Device;
  end Open_Device;

  function Open_Default_Device return Device_t is
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Open_Device
      (Specifier => System.Null_Address);
    return Device;
  end Open_Default_Device;

  function Close_Device
    (Device : in Device_t) return Boolean is
  begin
    return Boolean (ALC_Thin.Close_Device (Device.Device_Data));
  end Close_Device;

  function Create_Context
    (Device : in Device_t) return Context_t is
  begin
    return Context_t (ALC_Thin.Create_Context
      (Device         => Device.Device_Data,
       Attribute_List => System.Null_Address));
  end Create_Context;

  function Make_Context_Current
    (Context : in Context_t) return Boolean is
  begin
    return Boolean (ALC_Thin.Make_Context_Current (ALC_Thin.Context_t (Context)));
  end Make_Context_Current;

  procedure Process_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Process_Context (ALC_Thin.Context_t (Context));
  end Process_Context;

  procedure Suspend_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Suspend_Context (ALC_Thin.Context_t (Context));
  end Suspend_Context;

  procedure Destroy_Context
    (Context : in Context_t) is
  begin
    ALC_Thin.Destroy_Context (ALC_Thin.Context_t (Context));
  end Destroy_Context;

  function Get_Current_Context return Context_t is
  begin
    return Context_t (ALC_Thin.Get_Current_Context);
  end Get_Current_Context;

  function Get_Context_Device (Context : in Context_t) return Device_t is
    Device : Device_t;
  begin
    Device.Device_Data := ALC_Thin.Get_Contexts_Device (ALC_Thin.Context_t (Context));
    return Device;
  end Get_Context_Device;

  function Is_Extension_Present
    (Device : in Device_t;
     Name   : in String) return Boolean
  is
    C_Name : aliased C.char_array := C.To_C (Name);
  begin
    return Boolean (ALC_Thin.Is_Extension_Present
      (Device         => Device.Device_Data,
       Extension_Name => C_Name (C_Name'First)'Address));
  end Is_Extension_Present;

  --
  -- String queries
  --

  function Get_String
    (Device    : ALC_Thin.Device_t;
     Parameter : Types.Enumeration_t) return C_Strings.chars_ptr;
  pragma Import (C, Get_String, "alcGetString");

  use type C_Strings.chars_ptr;
  use type ALC_Thin.Device_t;
  use type System.Address;

  Null_Device : constant ALC_Thin.Device_t := ALC_Thin.Device_t (System.Null_Address);

  function Get_Default_Device_Specifier return String is
    CS : constant C_Strings.chars_ptr := Get_String
      (Device    => Null_Device,
       Parameter => ALC_Thin.ALC_DEFAULT_DEVICE_SPECIFIER);
  begin
    if CS /= C_Strings.Null_Ptr then
      return C_Strings.Value (CS);
    else
      raise Ada.IO_Exceptions.Device_Error with "no device available";
    end if;
  end Get_Default_Device_Specifier;

  function Get_Device_Specifier
    (Device : in Device_t) return String is
  begin
    if Device.Device_Data = Null_Device then
      raise Ada.IO_Exceptions.Device_Error with "invalid device";
    end if;

    return C_Strings.Value
      (Get_String
        (Device    => Device.Device_Data,
         Parameter => ALC_Thin.ALC_DEVICE_SPECIFIER));
  end Get_Device_Specifier;

  function Get_Extensions
    (Device : in Device_t) return String is
  begin
    if Device.Device_Data = Null_Device then
      raise Ada.IO_Exceptions.Device_Error with "invalid device";
    end if;

    return C_Strings.Value
      (Get_String
        (Device    => Device.Device_Data,
         Parameter => ALC_Thin.ALC_EXTENSIONS));
  end Get_Extensions;

  function Get_Default_Capture_Device_Specifier return String is
    CS : constant C_Strings.chars_ptr := Get_String
      (Device    => Null_Device,
       Parameter => ALC_Thin.ALC_CAPTURE_DEFAULT_DEVICE_SPECIFIER);
  begin
    if CS /= C_Strings.Null_Ptr then
      return C_Strings.Value (CS);
    else
      raise Ada.IO_Exceptions.Device_Error with "no capture device available";
    end if;
  end Get_Default_Capture_Device_Specifier;

  function Get_Available_Capture_Devices return OpenAL.List.String_Vector_t is
    Address : System.Address;
    List    : OpenAL.List.String_Vector_t;
  begin
    Address := ALC_Thin.Get_String
      (Device => ALC_Thin.Device_t (System.Null_Address),
       Token  => ALC_Thin.ALC_CAPTURE_DEVICE_SPECIFIER);
    if Address /= System.Null_Address then
      OpenAL.List.Address_To_Vector
        (Address => Address,
         List    => List);
    end if;

    return List;
  end Get_Available_Capture_Devices;

  function Get_Available_Playback_Devices return OpenAL.List.String_Vector_t is
    Address : System.Address;
    List    : OpenAL.List.String_Vector_t;
  begin
    Address := ALC_Thin.Get_String
      (Device => ALC_Thin.Device_t (System.Null_Address),
       Token  => ALC_Thin.ALC_DEVICE_SPECIFIER);
    if Address /= System.Null_Address then
      OpenAL.List.Address_To_Vector
        (Address => Address,
         List    => List);
    end if;

    return List;
  end Get_Available_Playback_Devices;

  --
  -- Integer queries
  --

  function Get_Major_Version
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MAJOR_VERSION,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Major_Version;

  function Get_Minor_Version
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MINOR_VERSION,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Minor_Version;

  function Get_Capture_Samples
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_CAPTURE_SAMPLES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Capture_Samples;

  function Get_Frequency
    (Device : in Device_t) return Types.Frequency_t
  is
    Value : aliased Types.Integer_t := Types.Integer_t (Types.Frequency_t'First);
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_FREQUENCY,
       Size   => 1,
       Data   => Value'Address);
    return Types.Frequency_t (Value);
  end Get_Frequency;

  function Get_Refresh
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_REFRESH,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Refresh;

  function Get_Synchronous
    (Device : in Device_t) return Boolean
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_SYNC,
       Size   => 1,
       Data   => Value'Address);
    return Boolean'Val (Value);
  end Get_Synchronous;

  function Get_Mono_Sources
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_MONO_SOURCES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Mono_Sources;

  function Get_Stereo_Sources
    (Device : in Device_t) return Natural
  is
    Value : aliased Types.Integer_t := 0;
  begin
    ALC_Thin.Get_Integerv
      (Device => Device.Device_Data,
       Token  => ALC_Thin.ALC_STEREO_SOURCES,
       Size   => 1,
       Data   => Value'Address);
    return Natural (Value);
  end Get_Stereo_Sources;

end OpenAL.Context;

Clean up previous commit...

Clean up previous commit...


-----------------------------------------------------------------------
--  Util.Beans.Objects.Discrete_Tests - Generic simple test for discrete object types
--  Copyright (C) 2009, 2010, 2011, 2018, 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.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;

with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Beans.Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

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

with Ada.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;

with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Le_Ge (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) <= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'<=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      Res := To_Object_Test (N) >= To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'>=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");
      if To_Object_Test (N) + To_Object_Test (N) /= To_Object_Test (N) then
         Res := To_Object_Test (N) + To_Object_Test (N) <= To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'<=' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V & "Num="
                     & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                     & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
         Res := To_Object_Test (N) >= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                     & Boolean'Image (Res) & " when we expected: "
                     & Boolean'Image (Is_Neg)
                     & " with value: " & V);
      end if;
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) <= To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) >= To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Le_Ge;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);
   procedure Test_Le_Ge is new Test_Basic_Object (Test_Le_Ge);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Beans.Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>='." & Test_Name,
                       Test_Le_Ge'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

Add new tests for >= and <= comparisons

Add new tests for >= and <= comparisons