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
#
# cmpstring(expectedstring,returnedstring) : cmp a string and fail if not equal
# 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)
# testswitch(int,"0 text"," non 0 text") : testpass or fail according to bool
# 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
# cmparray(arrayref, @reqvals) : test the arrayref against expected
# cmpstring(expectedstring,actualstring) :

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;
        rmtree("/tmp/SCRAMtest++");
        $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;

        return $self;
}

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

sub cmparray {
        my $self=shift;
        my $array=shift;
        my @vals=@_;

        if ( $#{$array} ne $#vals) { $self->testfail(
                 $#{$array}." items retuned, $#vals expected");
        }
        else {
        for( my $i=0; $i<= $#{$array}; $i++) {
           $self->cmpstring($vals[$i],$$array[$i]);
        }
        }
}


sub cmpstring {
        my $self=shift;
        my $s1=shift;
        my $s2=shift;

        if ( ! defined $s2) {
          if ( ( ! defined $s1 ) || ( $s1==undef )) {
            $self->testpass("Got undefined as expected");
          }
          else {
            $self->testfail("Return string is undefined expecting $s1"), 
          }
        }
        elsif ( $s1 ne $s2 ) {
          $self->testfail("Expecting $s1 got $s2");
        }
        else {
          $self->testpass("Got $s2 as expected");
        }
}
        
# 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 testswitch {
        my $self=shift;
        my $bool=shift;
        my $string1=shift;
        my $string2=shift;

        if ( ! $bool ) {
           $self->testpass($string1);
        } 
        else {
           $self->testfail($string2);
        }
}

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