VSS/testsuite/json/test_json_content_handler.adb

--
--  Copyright (C) 2020-2023, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
--

--  Test raising of exception by JSON_Content_Handler's conventions
--  subprograms without Success parameter.

with Ada.Assertions;

with VSS.JSON.Content_Handlers;
with VSS.Strings;

with Test_Support;

procedure Test_JSON_Content_Handler is

   procedure Test_JSON_Content_Handler;

   type Test_Content_Handler is
     limited new VSS.JSON.Content_Handlers.JSON_Content_Handler
   with record
      Status : Boolean := False;
   end record;

   overriding procedure Start_Document
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure End_Document
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure Start_Array
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure End_Array
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure Start_Object
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure End_Object
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding procedure Key_Name
     (Self    : in out Test_Content_Handler;
      Name    : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean);

   overriding procedure String_Value
     (Self    : in out Test_Content_Handler;
      Value   : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean);

   overriding procedure Number_Value
     (Self    : in out Test_Content_Handler;
      Value   : VSS.JSON.JSON_Number;
      Success : in out Boolean);

   overriding procedure Boolean_Value
     (Self    : in out Test_Content_Handler;
      Value   : Boolean;
      Success : in out Boolean);

   overriding procedure Null_Value
     (Self : in out Test_Content_Handler; Success : in out Boolean);

   overriding function Error_Message
     (Self : Test_Content_Handler) return VSS.Strings.Virtual_String;

   -------------------
   -- Boolean_Value --
   -------------------

   overriding procedure Boolean_Value
     (Self    : in out Test_Content_Handler;
      Value   : Boolean;
      Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Boolean_Value;

   ---------------
   -- End_Array --
   ---------------

   overriding procedure End_Array
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end End_Array;

   ------------------
   -- End_Document --
   ------------------

   overriding procedure End_Document
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end End_Document;

   ----------------
   -- End_Object --
   ----------------

   overriding procedure End_Object
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end End_Object;

   -------------------
   -- Error_Message --
   -------------------

   overriding function Error_Message
     (Self : Test_Content_Handler) return VSS.Strings.Virtual_String is
   begin
      return VSS.Strings.Empty_Virtual_String;
   end Error_Message;

   --------------
   -- Key_Name --
   --------------

   overriding procedure Key_Name
     (Self    : in out Test_Content_Handler;
      Name    : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Key_Name;

   ----------------
   -- Null_Value --
   ----------------

   overriding procedure Null_Value
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Null_Value;

   ------------------
   -- Number_Value --
   ------------------

   overriding procedure Number_Value
     (Self    : in out Test_Content_Handler;
      Value   : VSS.JSON.JSON_Number;
      Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Number_Value;

   -----------------
   -- Start_Array --
   -----------------

   overriding procedure Start_Array
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Start_Array;

   --------------------
   -- Start_Document --
   --------------------

   overriding procedure Start_Document
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Start_Document;

   ------------------
   -- Start_Object --
   ------------------

   overriding procedure Start_Object
     (Self : in out Test_Content_Handler; Success : in out Boolean) is
   begin
      Success := Self.Status;
   end Start_Object;

   ------------------
   -- String_Value --
   ------------------

   overriding procedure String_Value
     (Self    : in out Test_Content_Handler;
      Value   : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean) is
   begin
      Success := Self.Status;
   end String_Value;

   -------------------------------
   -- Test_JSON_Content_Handler --
   -------------------------------

   procedure Test_JSON_Content_Handler is
      Handler : aliased Test_Content_Handler;

      procedure Test_Start_Document;
      --  Start_Document

      procedure Test_End_Document;
      --  End_Document

      procedure Test_Start_Array;
      --  Start_Array

      procedure Test_End_Array;
      --  End_Array

      procedure Test_Start_Object;
      --  Start_Object

      procedure Test_End_Object;
      --  End_Object

      procedure Test_Key_Name;
      --  Key_Name

      procedure Test_String_Value;
      --  String_Value

      procedure Test_Number_Value;
      --  Number_Value

      procedure Test_Boolean_Value;
      --  Boolean_Value

      procedure Test_Null_Value;
      --  Null_Value

      procedure Test_Integer_Value;
      --  Integer_Value

      procedure Test_Float_Value;
      --  Float_Value

      ------------------------
      -- Test_Boolean_Value --
      ------------------------

      procedure Test_Boolean_Value is
      begin
         Handler.Status := True;
         Handler.Boolean_Value (False);

         begin
            Handler.Status := False;
            Handler.Boolean_Value (False);

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Boolean_Value;

      --------------------
      -- Test_End_Array --
      --------------------

      procedure Test_End_Array is
      begin
         Handler.Status := True;
         Handler.End_Array;

         begin
            Handler.Status := False;
            Handler.End_Array;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_End_Array;

      -----------------------
      -- Test_End_Document --
      -----------------------

      procedure Test_End_Document is
      begin
         Handler.Status := True;
         Handler.End_Document;

         begin
            Handler.Status := False;
            Handler.End_Document;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_End_Document;

      ---------------------
      -- Test_End_Object --
      ---------------------

      procedure Test_End_Object is
      begin
         Handler.Status := True;
         Handler.End_Object;

         begin
            Handler.Status := False;
            Handler.End_Object;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_End_Object;

      ----------------------
      -- Test_Float_Value --
      ----------------------

      procedure Test_Float_Value is
      begin
         Handler.Status := True;
         Handler.Float_Value (0.0);

         begin
            Handler.Status := False;
            Handler.Float_Value (0.0);

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Float_Value;

      ------------------------
      -- Test_Integer_Value --
      ------------------------

      procedure Test_Integer_Value is
      begin
         Handler.Status := True;
         Handler.Integer_Value (0);

         begin
            Handler.Status := False;
            Handler.Integer_Value (0);

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Integer_Value;

      -------------------
      -- Test_Key_Name --
      -------------------

      procedure Test_Key_Name is
      begin
         Handler.Status := True;
         Handler.Key_Name (VSS.Strings.Empty_Virtual_String);

         begin
            Handler.Status := False;
            Handler.Key_Name (VSS.Strings.Empty_Virtual_String);

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Key_Name;

      ---------------------
      -- Test_Null_Value --
      ---------------------

      procedure Test_Null_Value is
      begin
         Handler.Status := True;
         Handler.Null_Value;

         begin
            Handler.Status := False;
            Handler.Null_Value;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Null_Value;

      -----------------------
      -- Test_Number_Value --
      -----------------------

      procedure Test_Number_Value is
      begin
         Handler.Status := True;
         Handler.Number_Value ((others => <>));

         begin
            Handler.Status := False;
            Handler.Number_Value ((others => <>));

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Number_Value;

      ----------------------
      -- Test_Start_Array --
      ----------------------

      procedure Test_Start_Array is
      begin
         Handler.Status := True;
         Handler.Start_Array;

         begin
            Handler.Status := False;
            Handler.Start_Array;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Start_Array;

      -------------------------
      -- Test_Start_Document --
      -------------------------

      procedure Test_Start_Document is
      begin
         Handler.Status := True;
         Handler.Start_Document;

         begin
            Handler.Status := False;
            Handler.Start_Document;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Start_Document;

      -----------------------
      -- Test_Start_Object --
      -----------------------

      procedure Test_Start_Object is
      begin
         Handler.Status := True;
         Handler.Start_Object;

         begin
            Handler.Status := False;
            Handler.Start_Object;

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_Start_Object;

      -----------------------
      -- Test_String_Value --
      -----------------------

      procedure Test_String_Value is
      begin
         Handler.Status := True;
         Handler.String_Value (VSS.Strings.Empty_Virtual_String);

         begin
            Handler.Status := False;
            Handler.String_Value (VSS.Strings.Empty_Virtual_String);

            Test_Support.Fail;

         exception
            when Ada.Assertions.Assertion_Error =>
               null;
         end;
      end Test_String_Value;

   begin
      Test_Support.Run_Testcase (Test_Start_Document'Access, "Start_Document");
      Test_Support.Run_Testcase (Test_End_Document'Access, "End_Document");
      Test_Support.Run_Testcase (Test_Start_Array'Access, "Start_Array");
      Test_Support.Run_Testcase (Test_End_Array'Access, "End_Array");
      Test_Support.Run_Testcase (Test_Start_Object'Access, "Start_Object");
      Test_Support.Run_Testcase (Test_End_Object'Access, "End_Object");
      Test_Support.Run_Testcase (Test_Key_Name'Access, "Key_Name");
      Test_Support.Run_Testcase (Test_String_Value'Access, "String_Value");
      Test_Support.Run_Testcase (Test_Number_Value'Access, "Number_Value");
      Test_Support.Run_Testcase (Test_Boolean_Value'Access, "Boolean_Value");
      Test_Support.Run_Testcase (Test_Null_Value'Access, "Null_Value");
      Test_Support.Run_Testcase (Test_Integer_Value'Access, "Integer_Value");
      Test_Support.Run_Testcase (Test_Float_Value'Access, "Float_Value");
   end Test_JSON_Content_Handler;

begin
   Test_Support.Run_Testsuite
     (Test_JSON_Content_Handler'Access, "JSON_Content_Handler");
end Test_JSON_Content_Handler;