| Current Path : /var/www/web-klick.de/dsh/10_customer2017/1204__intel/Testframework/ |
Linux ift1.ift-informatik.de 5.4.0-216-generic #236-Ubuntu SMP Fri Apr 11 19:53:21 UTC 2025 x86_64 |
| Current File : /var/www/web-klick.de/dsh/10_customer2017/1204__intel/Testframework/TestTree.pm |
package TestTree;
use strict;
use Data::Dumper;
#******************************************************************
sub new {
my $class = shift;
my $self = {};
bless($self,$class);
$self->init();
return($self);
}
#******************************************************************
# to overload:
sub init { 1; }
sub result { my $self = shift; return(1); }
sub remark { my $self = shift; return("OK"); }
sub user { my $self = shift; return(""); }
sub requ { my $self = shift; return([ 'Standard' => 0.01 ]); }
sub run {
my $self = shift;
$self->test_start(@_);
$self->{'requ'} = { 'Standard' => 0.01 };
my $o = <<'TEXT_ENDE';
sub run {
my $self = shift;
$self->test_start(@_);
$self->{'requ'} = { 'Standard' => 0.01 };
my $o = <<'TEXXT_ENDE';
---LOG---
TEXXT_ENDE
$o =~ s/---LOG---/$o/;
$o =~ s/TEXXT_ENDE(.*)\nTEXXT_ENDE/TEXT_ENDE$1\nTEXT_ENDE/s;
$self->{'log'} = $o;
$self->test_end();
}
TEXT_ENDE
$o =~ s/---LOG---/$o/;
$o =~ s/TEXXT_ENDE(.*)\nTEXXT_ENDE/TEXT_ENDE$1\nTEXT_ENDE/s;
$self->{'log'} = $o;
$self->test_end();
}
#******************************************************************
sub test_start {
my $self = shift;
my @pars = ();
my $o; my @ee; my $o1;
while (@_) { # requirements will be given
$o = shift(@_); # from an empty Parameter
next if (!$o); # ( <par1>, <par2>, ..., "", <requ1> => <value1>, ...
push(@pars,$o);
}
$self->{'requ'} = { @_ };
# $self->{'requ'} = { @{$self->requ()}, @pars };
foreach $o (keys %{$self->{'requ'}}) { # a requirement in a closure of
if ($o =~ /^___(.*)___$/) { # in ___ , will be interpreted as
$self->{$o} = $self->{'requ'}->{$o}; # object variable. Example:
delete( $self->{'requ'}->{$o} ); # $self->{'requ'}->{'___abc___'} = "jr" ->
} # $self->{'abc'} = "jr"
}
$self->{'package'} = $self->mk_package();
}
#*********************************************************************
sub mk_package {
my $self = shift;
my $file = ref($self);
my $file1 = $file;
$file1 =~ s/\:\:/\//gs;
mkdir($file1);
my $zaehler = 0;
while (0 == 0) {
$zaehler = sprintf("%03u",$zaehler+1);
last if (!(-f("$file1/$zaehler.pm")));
}
$self->{'package'} = $file . "::" . $zaehler;
}
#******************************************************************
sub test_end {
my $self = shift;
$self->{'log'} .= shift;
my $user1 = "xx";
if (!($self->{'requ'}) or !(%{$self->{'requ'}})) {
$self->{'requ'} = { "Standard" => 0.01 };
}
my $r = "";
my $l; my $o; my $o1; my @ee; my $dbh; my $cursor; my $nr;
# my $maxweight = $self->{'weight'} || 1;
foreach $o (sort keys %{$self->{'requ'}}) {
if ($o =~ /^user_(.*)$/i) {
$user1 = $1;
}
$l = length($o) + 2;
if ($l < 25) { $l = 25; }
$o1 = $self->{'requ'}->{$o};
# if ($o1 > $maxweight) { $o1 = $maxweight; }
$r = $r . " '" . substr($o."' ",0,$l + 2)
. " => " .
sprintf("%6.4f",$o1)
. " ,\n";
}
while ( $r =~ s/0( +),/ $1,/g ) { 1; }
while ( $r =~ s/\.( +),/ $1,/g ) { 1; }
my $text = <<'TEXT_ENDE';
package ---PACKAGE---;
use strict;
use vars qw(@ISA $PKG);
$PKG = __PACKAGE__;
while ($PKG =~ s/^(.*)\:\:.*$/$1/) { eval("use $PKG"); next if ($@); @ISA = ($PKG); last }
sub result { ---RESULT--- }
sub remark { "---REMARK---" }
sub user { "---USER---" }
sub requ { [
---REQUIREMENT---
] }
---FUNCTIONS---
1;
TEXT_ENDE
$o = $self->{'log'};
eval ( $o ); print STDERR "\n------------------\n\nThis is only a WARNING, NO ERROR:\n\n"
. $@ . "\n------------------\n\n" if ($@);
if ($@) {
$o = 'sub run { my $self = shift; $self->test_start(@_); $self->{'."'weight'".'} = 0; $self->test_end('."<<'LOG'".'); }' . "\n\nRun log of " . ref($self) .
"\n-------------------------------------\n\n\n" . $o . "\nLOG\n\n";
}
$text =~ s/---FUNCTIONS---/$o/gs;
$o = $self->{'package'} || ref($self) . "::001";
$text =~ s/---PACKAGE---/$o/gs;
$o = $self->user() . "," . time() . "." . $user1;
$o =~ s/^\,//;
while ($o =~ /^(.*\,)(\d+)(\..*)$/) {
@ee = localtime($2);
$o = $1 .
sprintf("%04u",$ee[5]+1900) . sprintf("%02u",$ee[4]+1) .
sprintf("%02u",$ee[3]) . "_" . sprintf("%02u",$ee[2]) .
sprintf("%02u",$ee[1]) . sprintf("%02u",$ee[0]) . $3;
}
$o =~ s/^,//;
$text =~ s/---USER---/$o/gs;
$text =~ s/---REQUIREMENT---/$r/gs;
# print $text; exit;
$o1 = $text;
$o = $self->{'result'} || 1;
$o1 =~ s/---RESULT---/$o/gs;
$o = $self->{'remark'} || "";
$o1 =~ s/---REMARK---/$o/gs;
# making it ready
$o = $self->{'result'} || 0;
$text =~ s/---RESULT---/$o/gs;
$o = $self->{'remark'} || "";
$text =~ s/---REMARK---/$o/gs;
$self->save_package($text);
}
#************************************************************
sub save_package {
my $self = shift;
my $text = shift;
my $o = $self->{'package'} . ".pm";
$o =~ s/\:\:/\//gs;
open(FFILE,">".$o);
print FFILE $text;
close(FFILE);
return("");
}
#************************************************************
sub goto_next_function {
my $self = shift;
my $func; my $jump;
my %list_of_functions = eval("\%".ref($self)."::");
$list_of_functions{'run'} = 1;
my $tlist = [];
foreach $func (sort {
$a =~ /^(.*?)(0*)(\d*)$/; my $a1 = $3;
$b =~ /^(.*?)(0*)(\d*)$/; my $b1 = $3;
$a1 <=> $b1 } keys %list_of_functions) {
next if ($func !~ /^(r|run|t|test)(\d*)$/);
$jump = $func;
last if (!($self->{'___JUMP___'}));
if ($self->{'___JUMP___'} eq $func) {
delete ($self->{'___JUMP___'});
}
}
$self->{'___JUMP___'} = $jump;
if (!$jump) {
$func = "ERROR: No function found in " . ref($self) .
"::get_next_function\n";
print STDERR $jump;
} else {
print STDERR "Jump to: $jump\n";
}
return($jump);
}
#******************************************************************
sub sleep {
my $self = shift;
my $time = shift;
sleep($time);
my $func = $self->goto_next_function();
$self->$func();
}
1;
__END__
=head1 NAME
TestTree.pm - a testframework in ONE Module.
=head1 SYNOPSIS
$testitem = new TestTree;
$testitem->run();
$testitem->test_start(@params);
$testitem->test_end();
$testitem->result();
$testitem->remark();
$testitem->user();
$testitem->requ();
=head1 DESCRIPTION
This 'SmartCM Testframework in a nutshell deals with so-called
'Test-Item'. A Test-Item can be a Test-Case, it generates a
Test Log as it runs. A Test-class also is a Test-Item, it generates
a Test Case. Generally, a test-item generates a sub-testitem.
In this Tesframework, the Test-Items of a test project are all
organized as a tree of Perl modules, where the generated sub-items
(or child items) of the testitem <item>.pm are stored in the
sub-directory <item> parallel to <item>.pm. The generated child items
are numbered up unless they will be renamed after the generation
process
All Test-Items inherit all methods from the Test-Items above
in the directory hierarchy, the root item at the the top inherits
from TestTree.pm itself.
Each Test-Item has a run method; the standard run method from
TestTree.pm generates a Test-Item which reproduces this run method
(fixpoint of test item generation).
The minimal root item is as:
package ProprietaryPackageName;
use strict;
use vars qw(@ISA);
use TestTree;
@ISA = qw(TestTree);
1;
but there may be more methods in it for the purpose of
inheritance to its decessors.
Each generated Test-Item has, additionally to the run method,
the four methods:
result
remark
user
requ
which are meaningful if the Test Item is interpreted as a Test Log.
The result should 1 for OK, < 1000 for WARNING, > 1000 for ERROR.
The remark should be a short notice on the result, user returns
a user information.
requ returns a hash, where the keys are requirement shortcuts,
and the values are estimated likelihoods for running into
an error in the case that the requirement is errorneous
implemented.
Reporting the TestCases against the requirements means to
evaluate the whole Test Tree via a kind of text grep. This
is to this point of time NOT included in the framework.
The Test-Items shall be run from the level of the
root item via the caller script p0.
=head1 METHODS
=over
=item B<run>
The run method takes no arguments and should be overloaded
from the Test Items. It should start with a call of
$self->test_start( requ1 => value, requ2 => value, ...)
( $self is the test item object)
where the requirements for this test case can be given
as they will be apparent in the Test Log. The last call
in the run method should be $self->test_end(), so that
the new Test Item can be written down into the file system.
The text in $self->{'log'} will be interpreted as perl code
and will be implemented in the generated child test item,
so here is the place to construct the child item's run method.
(If $self->{'log'} is not a valid perl code, a standard
run method will be made from it returning just the text
in $self->{'log'}.)
=item B<test_start>
Takes the relevant requirement hash with its error finding likelihood
values and puts it in the test log.
=item B<test_end>
Ends the run function and is mandatory for it.
=item B<result>
Returns the standard result (= 1). To be overloaded.
=item B<remark>
Returns the standard remark (= ""). To be overloaded.
=item B<user>
Returns the standard user (= ""). To be overloaded.
=item B<requ>
Returns the standard requirement hash (= { Standard => 0.01 }).
To be overloaded.
=back
=head1
See also: p0
=cut