src/Utilities/TestClass.pm

#
# Test a documented perl class
#
# Interface
# ---------
# new($module,testdatadir) : module example - Utilities/urlhandler
# dotest(@args) : Start testing - arguments dependent on inheriting class
#
# newtest() : Initiate a testing sequence
# verify(actual_result_file, expected_result_file) : compare two files
# verifydir(dir) : Check existence of the directory
# datadir([dir]) : return the current data directory (set it to dir if supplied)
# ------------------- Private Methods ----------------------------------
# newfilename() : return a new filename that can be opened etc.
# temparea() : return a directory for building temporary stuff
# newobject(@args) : Set up a new object to be tested
# testinterface($name,@args) : perform interface tests for $name with @args
# expect(string) : tell the testinterface of any expected return values
# clearexpect()  : Reset any expect variables.

package TestClass;
require 5.004;
$bold  = "\033[1m";
$normal = "\033[0m";

# -------------------- Front line Interface methods ---------------------
sub new {
        my $class=shift;
        my $fullmodule=shift;
        chomp $fullmodule;
        my $datadir=shift;

        # The usual Object blessing
        $self={};
        bless $self,$class;

        #some local working variables
        my $testmodule;
        my $module;
        my $dir="";
#       if ( $fullmodule=~/\// ) {
#         ($dir=$fullmodule)=~s/(.*\/)(.*)/$1/;
#       }
        if ( $fullmodule=~/::/ ) {
          ($dir=$fullmodule)=~s/(.*::)(.*)/$1/;
        }
        else { $dir="" } 
        ($testmodule=$fullmodule)=~s/(.*\/)(.*)/$1test::test_$2/;
        ($testmodule=$fullmodule)=~s/${dir}(.*)/${dir}test::test_$1/;
        ($module=$testmodule)=~s/.*\///g;

        $self->{class}=$module;
        $self->{"datadir"}=$datadir;
        $self->{filenumber}=0;
        $self->{temparea}="/tmp/SCRAMtest";
        use File::Path;
        mkpath ($self->{temparea},0, 0777);

        # Now setup a new testobject of the appropriate type
        eval "require $testmodule";
        die $@ if $@;
        $self->{testobj}=$module->_new($self, $fullmodule);

        return $self;
}

#
# Call the test routine of our inheriting class
#
sub dotest {
        $self=shift;
        $self->{testobj}->test(@_);
        $self->{testobj}->checktests();
}


# A virtual method to be overridden
sub init {
        my $self=shift;
}

#
# initiate a new test sequence
#
sub newtest {
        my $self=shift;
        my $string=shift;
        $self->{testnumber}++;
        $self->_testout("");
        $self->_testout("---------------------------* Test $self->{testnumber}".
                                " *------------------------------");
        $self->_testout("|  $string ");
        $self->_testout("|");
        $self->_testout(
            "---------------------------------------------------------------");
        
}

sub verify {
        my $self=shift;
        my $file1=shift;
        my $file2=shift;
        my $same=1;

        $self->_testout(">Verifying files : $file1 \n".
                        "                   $file2");
        open ( FILE1, "<$file1" ) or die "Cannot Read Test Output $file1 $!\n";
        open ( FILE2, "<$file2" ) or die "Cannot Read Benchmark file ".
                                                        "$file2 $!\n";
        while ( $f1=<FILE1> ) {
         $f2=<FILE2>;
         if ( $f2 ne $f1 ) {
           print "T:\n$f1\nB:$f2\n";
           $same=0;
         }
        }
        close FILE1;
        close FILE2;
        if ( $same==0 ) {
          $self->testfail("File $file1 is not the same as $file2");
        }
}

sub verifydir {
        my $self=shift;
        my $name=shift;

        if ( -d "$name" ) {
           $self->testpass("");
        }
        else {
           $self->testfail("Directory $name does not exist");
        }
}

sub testfail {
        my $self=shift;
        my $string=shift;

        $self->_testout("$bold $string $normal");
        push @{$self->{failedtests}}, $self->{testnumber};
}

sub testpass {
        my $self=shift;
        my $string=shift;

        $self->_testout($string);
}

sub newfilename {
        my $self=shift;
        $self->{filenumber}++;
        return "temptest_$self->{filenumber}";
}

sub temparea {
        my $self=shift;
        return $self->{temparea};
}

#
# return the data directory ( and set if given an argument )
#
sub datadir {
        my $self=shift;
        my $dir=shift;
        if ( $dir ne "" ) {
                $self->{datadir}=$dir;
        }
        return $self->{datadir};
}

#
# -------------------- Private Methods ----------------------------
#       (only to be used by the inheriting class)

# 
# A basic new method for inheriting classes
#

sub _new {
        my $class=shift;
        my $testobject=shift;
        my $module=shift;


        # Bless this object and all those who inherit from her
        my $self={};
        bless $self, $class;

        # we want the dat members from the initialisation of our class in
        # here too
        foreach $key ( keys %$testobject ) {
         $self->{$key}=$testobject->{$key};
        }

        print "Initialising $class\n";

        # Data Initialisation
        $self->{testclass}=$class;
        ($self->{classname}=$module)=~s/::/\//g;
        ($self->{class}=$module)=~s/.*\///g;
        $self->{classfile}=$ENV{SCRAM_HOME}."/src/".$self->{classname}."\.pm";
        $self->init(@_);
        $self->analyseInterface();
        delete $self->{expect};
        return $self;
}

#
# Test the interface
#
sub testinterface {
        my $self=shift;
        my $subname=shift;
        my $myreturn;
        my $expected;

        $self->_checkdoc($subname);
        $self->{inttest}{$subname}++;
        $self->_testout(">Trying interface $subname ");
        my $args=join ', ', @_;
        $self->_testout( " (".$args.")" );
        $num=0;
        if ( exists $self->{expect} ) {
         @mylist=eval { $self->{object}->$subname(@_); };
          die "Test Failed $@\n" if $@; 
         if ( defined @mylist ) {
         foreach $myreturn ( @mylist ) {
          if ( ! defined $myreturn ) {
                print "Undefined Value Passed Back\n";
          }
          elsif ( \$myreturn=~/HASH/ ) {
             print "Hash Refreturned\n";
          }
          elsif ( \$myreturn=~/CODE/ ) {
             print "Code Ref returned\n";
          }
          elsif ( \$myreturn=~/ARRAY/ ) {
            print "Array Ref returned\n";
          }
          else {
            $expected=$self->{expect}[$num++];
            if ( $myreturn eq $expected ) { #simple return case
             $self->testpass("OK - returned as expected ($expected)");
            }
            else  {
              $self->testfail("Expecting $expected, got ".
                                                $myreturn);
            }
          }
        } # end foreach block
        }
          return @mylist;
        }
        else { 
          return ($self->{object}->$subname(@_));
        }
}

#
# expect - tell testinterface what returns to expect and fail/pass
#
sub expect {
        my $self=shift;
        my $string=shift;

        push @{$self->{expect}}, $string;
}

sub clearexpect {
        my $self=shift;
        my $string=shift;

        delete $self->{expect};
}

#
# checktests
#
sub checktests {
        my $self=shift;
        $self->newtest(">Checking all documented Interfaces have been tested ");
        foreach $key ( keys %{$self->{interfaceargs}} ) {
          if ( ! exists $self->{inttest}{$key} ) {
            $self->testfail ("$key has not been tested");
          }
        }
        # Now see whats failed
        foreach $fail ( @{$self->{failedtests}} ) {
         $self->_testout("$bold Failed in $fail $normal");
        }
}

#
# Create a new object
#
sub newobject {
        my $self=shift;

        $self->_checkdoc("new");
        $self->_testout(">Creating new Object $self->{class}");
        $self->{object}=$self->{class}->new(@_);
        $self->_testout(" ( $self->{object} )");
        $self->{inttest}{"new"}++;
}

#
# check if interface has been documented
#
sub _checkdoc {
        my $self=shift;
        my $name=shift;
        
        if ( exists $self->{interfaceargs}{$name} ) {
        }
        else {
           $self->_testout
                ("Tester: Interface Method '$name' is not documented\n");
        }
}

#
# Output messages to screen/logs etc
#
sub _testout($) {
        my $self=shift;
        my $string=shift;

        print $string;  
        print "\n";
}
#
# Method to read the interface documentation
#

sub analyseInterface {
        my $self=shift;
        my $intregion=0;

        open ( SRCIN, $self->{"classfile"} ) 
                        or die "Unable to open $classfile $!\n";
        while ( <SRCIN> ) {
           if ( $_=~/#\s*Interface/g ) {
                $intregion=1;
                next;
           }
           if ( $intregion ) { # if we are in the interface documentation
            if ( ( $_!~/^#/ ) || ( $_=~/^#\s?-{40}/ ) ) { #moving out of Int doc
                $intregion=0;
                next;
            }
            if ( $_=~/^#\s*(.*)\((.*)\)?:(.*)/ ) {
             $interface=$1;
             $args=$2;
             $rest=$3;
             next if ($interface eq ""); 
             push @{$self->{'interfaces'}},$interface;
             $self->{interfaceargs}{$interface}=$args;
             print " Documented Interface $interface\n";
            }
           }
        }
        close SRCIN;
}
Revision:	1.4
Committed:	Wed Sep 1 09:15:58 1999 UTC (25 years, 8 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.3:	+22 -15 lines
Log Message:	trap eval error messages
#	User	Rev	Content
1	williamc	1.1	#
2			# Test a documented perl class
3			#
4			# Interface
5			# ---------
6	williamc	1.4	# new($module,testdatadir) : module example - Utilities/urlhandler
7	williamc	1.1	# dotest(@args) : Start testing - arguments dependent on inheriting class
8			#
9			# newtest() : Initiate a testing sequence
10			# verify(actual_result_file, expected_result_file) : compare two files
11			# verifydir(dir) : Check existence of the directory
12			# datadir([dir]) : return the current data directory (set it to dir if supplied)
13			# ------------------- Private Methods ----------------------------------
14			# newfilename() : return a new filename that can be opened etc.
15			# temparea() : return a directory for building temporary stuff
16			# newobject(@args) : Set up a new object to be tested
17			# testinterface($name,@args) : perform interface tests for $name with @args
18			# expect(string) : tell the testinterface of any expected return values
19			# clearexpect() : Reset any expect variables.
20
21			package TestClass;
22			require 5.004;
23			$bold = "\033[1m";
24			$normal = "\033[0m";
25
26			# -------------------- Front line Interface methods ---------------------
27			sub new {
28			my $class=shift;
29			my $fullmodule=shift;
30			chomp $fullmodule;
31			my $datadir=shift;
32
33			# The usual Object blessing
34			$self={};
35			bless $self,$class;
36
37			#some local working variables
38			my $testmodule;
39			my $module;
40	williamc	1.2	my $dir="";
41	williamc	1.4	# if ( $fullmodule=~/\// ) {
42			# ($dir=$fullmodule)=~s/(.\/)(.)/$1/;
43			# }
44			if ( $fullmodule=~/::/ ) {
45			($dir=$fullmodule)=~s/(.::)(.)/$1/;
46			}
47	williamc	1.1	else { $dir="" }
48	williamc	1.4	($testmodule=$fullmodule)=~s/(.\/)(.)/$1test::test_$2/;
49			($testmodule=$fullmodule)=~s/${dir}(.*)/${dir}test::test_$1/;
50	williamc	1.1	($module=$testmodule)=~s/.*\///g;
51
52			$self->{class}=$module;
53			$self->{"datadir"}=$datadir;
54			$self->{filenumber}=0;
55	williamc	1.2	$self->{temparea}="/tmp/SCRAMtest";
56			use File::Path;
57			mkpath ($self->{temparea},0, 0777);
58	williamc	1.1
59			# Now setup a new testobject of the appropriate type
60	williamc	1.4	eval "require $testmodule";
61			die $@ if $@;
62	williamc	1.1	$self->{testobj}=$module->_new($self, $fullmodule);
63
64			return $self;
65			}
66
67			#
68			# Call the test routine of our inheriting class
69			#
70			sub dotest {
71			$self=shift;
72			$self->{testobj}->test(@_);
73			$self->{testobj}->checktests();
74			}
75
76
77
78			# A virtual method to be overridden
79			sub init {
80			my $self=shift;
81			}
82
83			#
84			# initiate a new test sequence
85			#
86			sub newtest {
87			my $self=shift;
88			my $string=shift;
89			$self->{testnumber}++;
90	williamc	1.2	$self->_testout("");
91	williamc	1.1	$self->_testout("---------------------------* Test $self->{testnumber}".
92			" *------------------------------");
93			$self->_testout("\| $string ");
94			$self->_testout("\|");
95			$self->_testout(
96			"---------------------------------------------------------------");
97
98			}
99
100			sub verify {
101			my $self=shift;
102			my $file1=shift;
103			my $file2=shift;
104			my $same=1;
105
106			$self->_testout(">Verifying files : $file1 \n".
107			" $file2");
108			open ( FILE1, "<$file1" ) or die "Cannot Read Test Output $file1 $!\n";
109			open ( FILE2, "<$file2" ) or die "Cannot Read Benchmark file ".
110			"$file2 $!\n";
111			while ( $f1=<FILE1> ) {
112			$f2=<FILE2>;
113			if ( $f2 ne $f1 ) {
114			print "T:\n$f1\nB:$f2\n";
115			$same=0;
116			}
117			}
118			close FILE1;
119			close FILE2;
120			if ( $same==0 ) {
121			$self->testfail("File $file1 is not the same as $file2");
122			}
123			}
124
125			sub verifydir {
126			my $self=shift;
127			my $name=shift;
128
129			if ( -d "$name" ) {
130	williamc	1.2	$self->testpass("");
131	williamc	1.1	}
132			else {
133			$self->testfail("Directory $name does not exist");
134			}
135			}
136
137			sub testfail {
138			my $self=shift;
139			my $string=shift;
140
141			$self->_testout("$bold $string $normal");
142			push @{$self->{failedtests}}, $self->{testnumber};
143			}
144
145			sub testpass {
146			my $self=shift;
147			my $string=shift;
148
149			$self->_testout($string);
150			}
151
152			sub newfilename {
153			my $self=shift;
154			$self->{filenumber}++;
155			return "temptest_$self->{filenumber}";
156			}
157
158			sub temparea {
159			my $self=shift;
160			return $self->{temparea};
161			}
162
163			#
164			# return the data directory ( and set if given an argument )
165			#
166			sub datadir {
167			my $self=shift;
168			my $dir=shift;
169			if ( $dir ne "" ) {
170			$self->{datadir}=$dir;
171			}
172			return $self->{datadir};
173			}
174
175			#
176			# -------------------- Private Methods ----------------------------
177			# (only to be used by the inheriting class)
178
179			#
180			# A basic new method for inheriting classes
181			#
182
183			sub _new {
184			my $class=shift;
185			my $testobject=shift;
186			my $module=shift;
187
188
189			# Bless this object and all those who inherit from her
190			my $self={};
191			bless $self, $class;
192
193			# we want the dat members from the initialisation of our class in
194			# here too
195			foreach $key ( keys %$testobject ) {
196			$self->{$key}=$testobject->{$key};
197			}
198
199			print "Initialising $class\n";
200
201			# Data Initialisation
202			$self->{testclass}=$class;
203	williamc	1.4	($self->{classname}=$module)=~s/::/\//g;
204	williamc	1.1	($self->{class}=$module)=~s/.*\///g;
205			$self->{classfile}=$ENV{SCRAM_HOME}."/src/".$self->{classname}."\.pm";
206			$self->init(@_);
207			$self->analyseInterface();
208			delete $self->{expect};
209			return $self;
210			}
211
212			#
213			# Test the interface
214			#
215			sub testinterface {
216			my $self=shift;
217			my $subname=shift;
218			my $myreturn;
219	williamc	1.4	my $expected;
220	williamc	1.1
221			$self->_checkdoc($subname);
222			$self->{inttest}{$subname}++;
223			$self->_testout(">Trying interface $subname ");
224			my $args=join ', ', @_;
225			$self->_testout( " (".$args.")" );
226	williamc	1.2	$num=0;
227	williamc	1.1	if ( exists $self->{expect} ) {
228	williamc	1.2	@mylist=eval { $self->{object}->$subname(@_); };
229			die "Test Failed $@\n" if $@;
230	williamc	1.4	if ( defined @mylist ) {
231			foreach $myreturn ( @mylist ) {
232			if ( ! defined $myreturn ) {
233			print "Undefined Value Passed Back\n";
234			}
235			elsif ( \$myreturn=~/HASH/ ) {
236	williamc	1.2	print "Hash Refreturned\n";
237	williamc	1.1	}
238	williamc	1.2	elsif ( \$myreturn=~/CODE/ ) {
239			print "Code Ref returned\n";
240			}
241			elsif ( \$myreturn=~/ARRAY/ ) {
242			print "Array Ref returned\n";
243			}
244			else {
245	williamc	1.4	$expected=$self->{expect}[$num++];
246	williamc	1.2	if ( $myreturn eq $expected ) { #simple return case
247			$self->testpass("OK - returned as expected ($expected)");
248			}
249			else {
250			$self->testfail("Expecting $expected, got ".
251			$myreturn);
252			}
253			}
254	williamc	1.4	} # end foreach block
255			}
256	williamc	1.2	return @mylist;
257	williamc	1.1	}
258			else {
259			return ($self->{object}->$subname(@_));
260			}
261			}
262
263			#
264			# expect - tell testinterface what returns to expect and fail/pass
265			#
266			sub expect {
267			my $self=shift;
268			my $string=shift;
269
270	williamc	1.2	push @{$self->{expect}}, $string;
271	williamc	1.1	}
272
273			sub clearexpect {
274			my $self=shift;
275			my $string=shift;
276
277			delete $self->{expect};
278			}
279
280			#
281			# checktests
282			#
283			sub checktests {
284			my $self=shift;
285			$self->newtest(">Checking all documented Interfaces have been tested ");
286			foreach $key ( keys %{$self->{interfaceargs}} ) {
287			if ( ! exists $self->{inttest}{$key} ) {
288			$self->testfail ("$key has not been tested");
289			}
290			}
291			# Now see whats failed
292			foreach $fail ( @{$self->{failedtests}} ) {
293			$self->_testout("$bold Failed in $fail $normal");
294			}
295			}
296
297			#
298			# Create a new object
299			#
300			sub newobject {
301			my $self=shift;
302
303			$self->_checkdoc("new");
304			$self->_testout(">Creating new Object $self->{class}");
305			$self->{object}=$self->{class}->new(@_);
306			$self->_testout(" ( $self->{object} )");
307			$self->{inttest}{"new"}++;
308			}
309
310			#
311			# check if interface has been documented
312			#
313			sub _checkdoc {
314			my $self=shift;
315			my $name=shift;
316
317			if ( exists $self->{interfaceargs}{$name} ) {
318			}
319			else {
320			$self->_testout
321			("Tester: Interface Method '$name' is not documented\n");
322			}
323			}
324
325			#
326			# Output messages to screen/logs etc
327			#
328			sub _testout($) {
329			my $self=shift;
330			my $string=shift;
331
332			print $string;
333			print "\n";
334			}
335			#
336			# Method to read the interface documentation
337			#
338
339			sub analyseInterface {
340			my $self=shift;
341			my $intregion=0;
342
343			open ( SRCIN, $self->{"classfile"} )
344			or die "Unable to open $classfile $!\n";
345			while ( <SRCIN> ) {
346			if ( $_=~/#\s*Interface/g ) {
347			$intregion=1;
348			next;
349			}
350			if ( $intregion ) { # if we are in the interface documentation
351			if ( ( $_!~/^#/ ) \|\| ( $_=~/^#\s?-{40}/ ) ) { #moving out of Int doc
352			$intregion=0;
353			next;
354			}
355			if ( $_=~/^#\s(.)\((.)\)?:(.)/ ) {
356			$interface=$1;
357			$args=$2;
358			$rest=$3;
359			next if ($interface eq "");
360			push @{$self->{'interfaces'}},$interface;
361			$self->{interfaceargs}{$interface}=$args;
362			print " Documented Interface $interface\n";
363			}
364			}
365			}
366			close SRCIN;
367			}