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
# verifyexists(file) : Verify the existence of file
# datadir([dir]) : return the current data directory (set it to dir if supplied)
# testfail(string) : report that current test has failed
# testpass(string) : report that current test has passed
# 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.
#cleantemp()    : delete the temporary area

package Utilities::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);

        # make sure the temparea is cleaned
        use File::Path;
        rmtree($self->temparea());

        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=<FILE2> ) {
         $f2=<FILE1>;
         if ( (!defined $f2 ) || ( ! defined $f1) || ($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("Directory $name exists - test passed");
        }
        else {
           $self->testfail("Directory $name does not exist");
        }
}

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

        if ( -e "$name" ) {
           $self->testpass("$name exists - test passed");
        }
        else {
           $self->testfail("$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 ) {
         # size check
         if ( $#mylist < $#{$self->{expect}} ) {
                $self->testfail("not enough returned values");
         }
         foreach $myreturn ( @mylist ) {
          if ( ! defined $myreturn ) {
                print "Undefined Value Passed Back\n";
          }
          elsif ( $myreturn=~/HASH/ ) {
             print "Hash Ref ".ref($myreturn)." returned\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;

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

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;
}

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