------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- test.sa: Class for testing classes.
-------------------------------------------------------------------
class TEST is
   -- To be included by a testing class. The test routine should
   -- start with the call `class_name("CLASS_FOO");'. It should then
   -- have calls to `test' or `unchecked_test' which actually perform
   -- the test. It should end with `finish' to print out the results.
   -- The results are sent to both `stderr' and `stdout' so you can
   -- redirect output to a file and still see whether all tests were
   -- passed. The routine being tested must return a string. The
   -- basic classes all have routines named `str' to produce string
   -- representations of themselves. A typical test might look something
   -- like: `test("sum", (1+1).str, "2");'. The tests are numbered and
   -- the failures are summarized at the end. 

   shared class_name_str:STR;	-- The name of the tested class.
   shared failures:FLIST{INT};	-- The tests which failed.
   shared failure_docs:FLIST{STR}; -- The documentation of the failures.
   shared test_number:INT;	-- Which test.
   shared checked_tests:INT;
   
   class_name(nm:STR)
   -- Specify the name of the class being tested. Must be called first.
   is
      class_name_str:=nm;
      test_number:=1;
      checked_tests:=0;
      #OUT + "Test of class " + nm + ":\n\n"
   end; -- class_name

   test(doc_ds,does_ds:$STR,should_ds:ARRAY{INT}) is
      -- Specialized version of test when the correct result is expressed
      -- as an array
      test(doc_ds,does_ds,should_ds.str);
   end;
	 
   test(doc_ds,does_ds,should_ds:$STR)
   -- Perform the test with the description `doc', return value `does',
   -- and desired return value `should'. Keep track of failures.
   is
      doc: STR := doc_ds.str; does: STR := does_ds.str; 
      should:STR := should_ds.str;
      if (void(class_name_str)) then
	 #ERR + "Error in TEST class: \"class_name\" not called\n";
	 class_name_str := "!!!UNKNOWN_CLASS_NAME!!!";
	 test_number := 1;
	 checked_tests := 0;
      end;
      #OUT + "   " + class_name_str + " Test ";
      #OUT + test_number.str + " (" + doc + ")  ";
      if does.is_eq(should).not then
	 failures:=failures.push(test_number);
	 failure_docs:=failure_docs.push(doc);
	 #OUT + " Found problem!\n";
      else
	 #OUT + " succeeded\n"; 
      end;
      #OUT + "   Should = " + should + "\n";
      #OUT + "   Does   = " + does + "\n\n";
      test_number:=test_number+1;
      checked_tests:=checked_tests+1;
   end; -- test
   
   raise_test(testname:$STR,testrout:ROUT:FMT,should:STR)
   -- Performs the test with the desciption 'doc'. The routine
   -- 'testrout' is expected to raise an exception with the string
   -- representation 'should'.
   is
      protect
	 test( testname, testrout.call, "raise \""+should.str+"\"." );
      when $STR then
	 test( testname, exception, should );
      else
	 raise exception
      end;
   end; -- raisetest
      
   unchecked_test(doc_ds,does_ds,should_ds:$STR)
   -- Perform the test with the description `doc', return value `does',
   -- and desired return value `should'. Don't keep track of failures.
   is
      doc: STR := doc_ds.str; does: STR := does_ds.str; 
      should:STR := should_ds.str;
      #OUT + "   " + class_name_str + " Test " + test_number.str +
	    " (" + doc + ")\n";
      #OUT + "   Should = " + should + "\n";
      #OUT + "   Does   = " + does +"\n\n";
      test_number:=test_number+1
   end; -- unchecked_test

   finish
   -- Complete the testing on the current class.
   is
      if failures.is_empty then
	 -- Put on both ERR and OUT so one can avoid looking
	 -- if one wants.
	 -- we don't want to print hundreds of 'passed' lines.
	 -- #ERR + "Class " + class_name_str +
	 -- " passed all " + checked_tests + " checkable tests.\n";
         #ERR + class_name_str + ' ';
	 #OUT + "OUT: Class " + class_name_str +
	       " passed all " + checked_tests + " checkable tests.\n"
      else
	 loop
	    f1::=failures.elt!.str;
	    f2::=failure_docs.elt!;
	    msg::="Class "+class_name_str+" failed test "+f1+" ("+f2+")\n";
	    #ERR + "\n" + msg;
	    #OUT + "OUT: " + msg;
	 end;
	 end
   end; -- finish

end; -- class TEST

-------------------------------------------------------------------
class TEST_TEST is
   -- Test of `TEST'.
   
   include TEST;
   
   main is
      -- Test of `TEST'.
      class_name("TEST");
      test("A good test", "good", "good");
      test("A bad test", "good", "bad");
      raise_test("A raise test", bind(raising), "an exception");
      unchecked_test("Unchecked test", "anything", "anything");
      finish;
   end; -- main
   
   raising: STR
   is
      raise "an exception"
   end; -- raising
   
end; -- class TEST_TEST

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

