src/Utilities/TestClass.pm

#
# Test a documented perl class
#
# Interface
# ---------
# new($module,testdatadir,project) : 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;
        my $project=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/;
        }
        else { $dir="" } 
        ($testmodule=$fullmodule)=~s/(.*\/)(.*)/$1test\/test_$2/;
        ($testmodule=$fullmodule)=~s/${dir}(.*)/${dir}test\/test_$1/;
        ($module=$testmodule)=~s/.*\///g;

        # Data Initialisation
        $self->{project}=$project;
        $self->{class}=$module;
        $self->{"datadir"}=$datadir;
        $self->{filenumber}=0;

        # Now setup a new testobject of the appropriate type
        require $testmodule."\.pm";
        $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;
        ($self->{class}=$module)=~s/.*\///g;
        $self->{classfile}=$ENV{SCRAM_HOME}."/src/".$self->{classname}."\.pm";
        $self->{testclassfile}=$path."/test/".$self->{testclass}."\.pm";
        $self->init(@_);
        $self->analyseInterface();
        delete $self->{expect};
        return $self;
}

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

        $self->_checkdoc($subname);
        $self->{inttest}{$subname}++;
        $self->_testout(">Trying interface $subname ");
        my $args=join ', ', @_;
        $self->_testout( " (".$args.")" );
        if ( exists $self->{expect} ) {
          @myreturn=($self->{object}->$subname(@_));
          if ( "@myreturn" eq $self->{expect} ) {
            $self->testpass("OK - returned as expected");
          } 
          else  {
            $self->testfail("Expecting $self->{expect}, got @myreturn");
          }
          return @myreturn;
        }
        else { 
          return ($self->{object}->$subname(@_));
        }
}

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

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