Natools

File src/natools-tests.adb from the latest check-in

------------------------------------------------------------------------------
-- Copyright (c) 2011, 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.           --
------------------------------------------------------------------------------


package body Natools.Tests is

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function To_Result (Succeeded : Boolean) return Result is
   begin
      if Succeeded then
         return Success;
      else
         return Fail;
      end if;
   end To_Result;


   procedure Report_Exception
     (Report    : in out Reporter'Class;
      Test_Name : String;
      Ex        : Ada.Exceptions.Exception_Occurrence;
      Code      : Result := Error) is
   begin
      Item (Report, Test_Name, Code);
      Info (Report,
            "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Report, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;



   -----------------
   -- Test Object --
   -----------------

   function Item
     (Report : access Reporter'Class;
      Name : String;
      Default_Outcome : Result := Success)
     return Test is
   begin
      return Test'(Ada.Finalization.Limited_Controlled with
         Report => Report,
         Name => Ada.Strings.Unbounded.To_Unbounded_String (Name),
         Info => Info_Lists.Empty_List,
         Outcome => Default_Outcome,
         Finalized => False);
   end Item;


   procedure Set_Result (Object : in out Test; Outcome : in Result) is
   begin
      Object.Outcome := Outcome;
   end Set_Result;


   procedure Info (Object : in out Test; Text : in String) is
   begin
      Object.Info.Append (Text);
   end Info;


   procedure Report_Exception
     (Object : in out Test;
      Ex     : in Ada.Exceptions.Exception_Occurrence;
      Code   : in Result := Error) is
   begin
      Set_Result (Object, Code);
      Info
        (Object,
         "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Object, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;


   procedure Fail (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Fail);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Fail;


   procedure Error (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Error);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Error;


   procedure Skip (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Skipped);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Skip;


   overriding procedure Finalize (Object : in out Test) is
      Cursor : Info_Lists.Cursor;
   begin
      if not Object.Finalized then
         Object.Finalized := True;
         Object.Report.Item
           (Ada.Strings.Unbounded.To_String (Object.Name),
            Object.Outcome);
         Cursor := Object.Info.First;
         while Info_Lists.Has_Element (Cursor) loop
            Object.Report.Info (Info_Lists.Element (Cursor));
            Info_Lists.Next (Cursor);
         end loop;
      end if;
   end Finalize;


   procedure Generic_Check
     (Object : in out Test;
      Expected : in Result;
      Found : in Result;
      Label : in String := "") is
   begin
      if Expected /= Found then
         if Multiline then
            Fail (Object, Label);
            Info (Object, "Expected: " & Image (Expected));
            Info (Object, "Found:    " & Image (Found));
         elsif Label /= "" then
            Fail (Object, Label
              & ": expected " & Image (Expected)
              & ", found " & Image (Found));
         else
            Fail (Object, "Expected " & Image (Expected)
              & ", found " & Image (Found));
         end if;
      end if;
   end Generic_Check;

end Natools.Tests;