| Current Path : /var/www/web-klick.de/dsh/10_customer2017/1211__dgp/ |
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/1211__dgp/TestTree1.pm |
package DivBasicF::TestTree1;
use strict;
use Data::Dumper;
use MIME::Base64;
#******************************************************************
# This is the central TestTree1.pm module to perform hierarchical
# organized tests (tree of test items)
#
# 1. The root item
# ----------------
#
# Start with a directory and a 'root item' which hesitates directly
# from TestTree1.pm. Choose as executable the perl skript autotest.pl
# which is located in the PATH.
#
# So the root item (for example abc123.pm) looks like:
#
#
# #!/usr/local/bin/autotest.pl
# package abc123;
#
# use vars qw(@ISA);
# use DivBasicF::TestTree1;
# @ISA = qw(DivBasicF::TestTree1);
#
# 1;
#
#
# Get that root item executable rights. Then you can execute it directly.
#
# abc123.pm run: Executes the item and generates a child item abc123/<next_item>.pm
#
# This child item again has a run function hesitated by TestTree1.pm and can
# also be executed:
#
# abc123/<next_item>.pm run
#
# and so on. All child items have the run method from TestTree1.pm by hesitation.
# Moreover, all child items hesitate the (not overloaded) methods from
# all its ancestors.
#
# 2. Overloading the run method and creating test items with sleep
# -----------------------------------------------------------------
#
# To perform more interesting things, the run method of a test item
# should be overloaded. It should take and evaluate the parameters
# of the command line. The special method which makes a new child item
# of the actual item, is: sleep.
#
# sleep takes one or two parameters.
# 1. The sleeping time in seconds
# 2. The next method to jump to after re-awaking (see above), optional
#
# sleep does the following: It dumps the $self of the running process
# performing by the actual test item <testitem>.pm into a Base64 string.
# Then it chooses a file name <file>.pm by the method test_nr so that
# no child item of the given name exists yet. ( test_nr can be overloaded.)
# Then it creates new valid program code for the test item and stores it
# into the file
#
# <item>/<file>.py (if python code is found in $self->{'log'} )
# <item>/<file>.groovy (if groovy code is found in $self->{'log'} )
# <item>/<file>.pm (in all other cases).
#
# If a pm-file is generated, then its program code contains the methods:
#
# result
# remark
# user
# requ
# log
# dump_data
#
# result , remark , user , requ , log are made from the entries in
# $self->{'result'} , $self->{'remark'} , $self->{'user'} ,
# $self->{'requ'} and $self->{'log'}
# defined in the running process of the <item> .
# And dump_data contains the base64-encoded Dumper-dump of the
# $self from the running process itself.
#
# 3. Parameters of sleep and preparation the child item process for re-awakening
# --------------------------------------------------------------------------------
#
# The purpose of sleep is enabling the running child item process
# to be re-awakeable. To enabling this feature, it is important
# to set the parameters of sleep in the following way:
#
# a) sleep(-1,[<next_method>])
#
# With this call in the run method (or any other method the
# process happens to run) the created child item will sleep the
# $self->max() time (hesitated from the TretTree1.pm).
# The generated result is set to 9901 to indicate that
# the child is not yet ready with its computation and has to
# be awaked again. The remark method contains a max number value
# (for waiting until 'infinity').
# It is possible to manipulate that dumped child process
# by changing the remark to 0 (so that the sleep time is
# expired and it will run again by continue - see above)
# and changing manually the content of log , which will
# be read in again after awakening. This is the ability to
# manipulate a running test process with interactive entries
# in the $self->{'log'} which later can be evaluated.
#
# b) sleep( n ,[<next_method>])
# As like as a), but with the sleep time n. This is indicated
# by result 9902 , and remark returns the awake time in seconds
# since the period after 1.1.1970.
#
# c) sleep(-2)
# No manipulation of result and remark . No awake time anymore.
# Typically used for ready-run child items. result and remark
# should be set meaningful:
# result = 1 : OK
# 1 < result < 1000 : WARNING
# 1000 < result : ERROR
#
# d) sleep("<result>. <remark>")
# In that special form there will be set
# $self->{'result'} = <result>
# $self->{'remark'} = <remark>
# and the time-Parameter set to -2. Then the same behaviour like c),
# no dump_data will be created -> test finished.
#
# <next_function> is an optional parameter, which indicates the method
# that will be called after re-awakening the process. If it is not given,
# then the 'next' function in a list of the methods of the code will be
# chosen. This list only contains methods with names starting with
# r, run, t or test, and that list is alphabetically ordered.
#
# If no <next_function> is found, then there will not be the dump_data
# method (because in this case such a method does not make sense.
#
#
# 4. Re-awakening child processes
# -------------------------------
#
# If the generated child item has dump_data, it can be re-awakened.
# This can be done by applying continue on the generated and now
# dumped child item:
#
# <testitem>/<file>.pm continue
#
# Then the stored dump in dump data will re-create the former $self
# and re-activate it in the process.
# But this will only be done if the result method has 9901 or 9902,
# and the awake time given by remark is smaller than the actual time
# in seconds of the period since 1.1.1970. Otherwise the awakening
# will be refused.
#
#
# 5. Running child-items
# ----------------------
#
# When a child item is created and finally has a valid result and remark,
# it can be run again by calling:
#
# <testitem>/<file>.pm run
#
# in spite of not having a special run method. If log returns
# valid perl code, and it contains code for a run method, the
# content of log will be eval'ed, and after that the code of
# that implcit run is available and will be executed. If there
# is no valid perl code in log , then run will not work.
#
# For the purpose of debugging the perl code in given log ,
# you can comment out the embracing sub log { .... and
# LOG_DATA lines, so that you have the code statically.
#
#
# 6. Requirement handling and logging
# -----------------------------------
#
# The purpose of a test is to check which requirements are touched
# along the running test. This can be done by calling:
#
# $self->add_requ(<requirement>,<sensitivity>)
#
# where 0 < <sensitivity> < 1
#
# A log entry can be performed by:
#
# $self->add_log(<text>)
#******************************************************************
sub new {
my $class = shift;
my $self = {};
bless($self,$class);
return($self);
}
#******************************************************************
# Helpful utilites:
sub max_time { 40000000 }
sub choose { my $l = shift; my @pars = $l->sets(@_);
return($pars[int rand($#pars+1)]); }
sub choose_between { my $l = shift; my $a = shift; my $b = shift;
return($a + int rand(1 + $b - $a)); }
sub choose_until { my $l = shift;
my $b = shift; return(int rand(1 + $b)); }
sub mchoose { my $l = shift; my $nr = shift; my @pars = $l->sets(@_);
my @erg = (); while ($#erg < $nr-1) {
push(@erg,$l->choose(@pars)); } return(@erg); }
sub mchoose_between { my $l = shift;
my $nr = shift; my @erg = (); while ($#erg < $nr-1) {
push(@erg,$l->choose_between(@_)); } return(@erg); }
sub mchoose_until { my $l = shift;
my $nr = shift; my @erg = (); while ($#erg < $nr-1) {
push(@erg,$l->choose_until(@_)); } return(@erg); }
sub sets {
my $self = shift;
my @pars = @_;
my @erg = ();
my $o; my $o1; my $o2; my $start; my $xa; my $xe;
foreach $o (@pars) {
if ($o =~ /^([A-Za-z0-9])(\.|\-)([A-Za-z0-9])$/) {
$xa = $1;
$o2 = $2;
if ($o2 eq ".") {
$o2 = [];
} else {
$o2 = "";
}
$xe = $3;
$start = 0;
foreach $o1 (qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
a b c d e f g h i j k l m n o p q r s t u v w x y z
0 1 2 3 4 5 6 7 8 9)) {
if ($o1 eq $xa) { $start = 1; }
if ($start) {
if ($o2) {
push(@$o2,$o1);
} else {
push(@erg,$o1);
}
}
last if ($o1 eq $xe);
}
if ($o2) { push(@erg,$self->choose(@$o2)); }
}
elsif ($o =~ /^([\-\+]?\d+)\-([\-\+]?\d+)$/) {
push(@erg,$self->choose_between($1,$2));
}
elsif ($o =~ /^(\d+\.\d+\.\d+)\-(\d+\.\d+\.\d+)$/) {
$xa = Time::ParseDate::parsedate($1,UK=>1)/86400;
$xe = Time::ParseDate::parsedate($2,UK=>1)/86400;
$o1 = $self->choose_between($xa,$xe);
$o1 = Date::Format::time2str("%e.%L.%Y",$o1*86400);
$o1 =~ s/ //g;
push(@erg,$o1);
}
else {
push(@erg,$o);
}
}
return(@erg);
}
sub max { my $l = shift;
my $a = shift; my $b = shift; return($b) if ($a > $b); return($a); }
#******************************************************************
sub run {
my $self = shift;
my $o = <<'TEXT_ENDE';
sub run {
my $self = shift;
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->sleep(300);
}
TEXT_ENDE
$o =~ s/---LOG---/$o/;
$o =~ s/TEXXT_ENDE(.*)\nTEXXT_ENDE/TEXT_ENDE$1\nTEXT_ENDE/s;
$self->{'log'} = $o;
$self->sleep(300);
}
#******************************************************************
sub run0 {
my $self = shift;
my $pkg = shift;
my @pars = @_;
return("___RUN0___") if ($main::___RUN0___ == 1);
$main::___RUN0___ = 1;
my $o = $self->log();
eval( "package $pkg;\n" . $o );
return($@."Text string is:\n".$o) if ($@);
my $o1;
$o1 = $self->run(@_);
$main::___RUN0___ = 0;
return($o) if ($@);
return($o) if ($o1 eq "___RUN0___");
return($o1);
}
#******************************************************************
sub continue {
my $self = shift;
my $VAR1;
eval(decode_base64(eval("\$self->dump_data()")));
return("Process has no dump data. Semms to be finished.") if(!$VAR1);
return("Process " . $VAR1->{'AUTOTEST_FILE'} . ".pm cannot be continued cause there is no jump function. " .
"It seems to be finished.") if (!($VAR1->{'___JUMP___'}));
return("Process " . $VAR1->{'AUTOTEST_FILE'} . ".pm has finished, not continued.") if ($VAR1->{'result'} < 9901);
my $o = $self->remark() - time();
return("Awake time not yet reached. $o seconds to wait.") if ($o > 0);
$VAR1->{'log'} = eval("\$VAR1->log()") || $VAR1->{'log'};
$self = $VAR1;
$o = $self->{'___JUMP___'};
delete( $self->{'___JUMP___'} );
$self->$o() if ($o);
return("Process " . $self->{'AUTOTEST_FILE'} . ".pm restored and continued.");
}
#******************************************************************
sub sleep { # Dump a running process
my $self = shift;
my $time = shift;
$self->{'___JUMP___'} = shift || $self->goto_next_function();
if ($time =~ /^ *(\d+)\. *(.*?) *$/) {
$self->{'result'} = $1;
$self->{'remark'} = $2;
delete ($self->{'___JUMP___' });
$time = -2;
}
if ($time == -1) {
$self->{'result'} = 9901; # pending REQUEST
$self->{'remark'} = $self->max_time(); # sleep as long as possible
}
elsif ($time > -1) {
$self->{'result'} = 9902; # sleep of
$self->{'remark'} = time() + $time; # time $self->{'remark'}
}
my $zaehler; my $file; my $file1; my $ending;
my $testcase = "";
if (!($self->{'AUTOTEST_FILE'})) {
$file = ref($self);
$file1 = $file;
$file1 =~ s/\:\:/\//gs;
mkdir($file1);
$zaehler = 0;
$self->{'AUTOTEST_FILE'} = $self->next_test();
while (0 == 0) {
$zaehler = $zaehler + 1;
$testcase = $self->test_nr($zaehler);
last if (!$testcase);
next if (-f("$file1/$testcase.pm"));
next if (-f("$file1/$testcase.py"));
next if (-f("$file1/$testcase.exe"));
next if (-f("$file1/$testcase.groovy"));
last;
}
$self->{'AUTOTEST_FILE'} = $file1 . "/$testcase";
}
my $text = "";
if (!$text) { $ending = "pl"; $text = $self->check_perl() }
if (!$text) { $ending = "py"; $text = $self->check_python() }
if (!$text) { $ending = "pm"; $text = $self->check_autotest() }
$file = $self->{'AUTOTEST_FILE'}.".".$ending;
open(FFILE,">".$file);
print FFILE $text;
close(FFILE);
system("chmod a+x $file");
return("CREATED: $file") if ($testcase);
return("");
}
#*******************************************************************
sub next_test { my $self = shift; my $nr = shift; return(sprintf("%03u",$nr)); }
sub check_perl { "" }
sub check_python { "" }
sub check_autotest {
my $self = shift;
my $o1; my $o2; my @ee; my $maxlen = 10;
my $text = <<'TEXXT_ENDE';
#!---EXECUTABLE---
package ---PACKAGE---;
use strict;
use vars qw(@ISA $PKG);
$PKG = __PACKAGE__;
while ($PKG =~ s/^(.*)\:\:.*$/$1/) { eval("use $PKG"); next if ($@); @ISA = ($PKG); last }
sub run { my $self = shift; $self->run0(__PACKAGE__,@_); }
sub result { ---RESULT--- }
sub remark { "---REMARK---" }
sub user { "---USER---" }
sub requ { <<'REQU_DATA' }
---REQUIREMENT---
REQU_DATA
sub log { <<'LOG_DATA' }
TEXXT_ENDE
my $o = $self->{'AUTOTEST_FILE'};
$o =~ s/^(.*)\.(.*)$/$1/;
$o =~ s/[\\\/]/\:\:/g;
$text =~ s/---PACKAGE---/$o/g;
$o = $self->{'result'} || 0;
$text =~ s/---RESULT---/$o/;
$o = $self->{'remark'};
$text =~ s/---REMARK---/$o/;
$o = eval("\$self->user()") . "," . time() . "." . ( $self->{'user'} || "xx" );
while ($o =~ /^(.*\,)(\d+)(\..*)$/) {
@ee = localtime($2); # Sekundenformat in lesbares Format umwandeln
$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/g;
$text =~ s/---EXECUTABLE---/$0/;
$o = $self->{'requ'};
foreach $o1 (keys %$o) {
$o2 = length($o1);
$maxlen = $o2 if ($maxlen < $o2);
}
$o2 = "";
foreach $o1 (sort keys %$o) {
$o2 = $o2 . substr($o1." "x$maxlen,0,$maxlen) . " => " . sprintf("%5.4f",$o->{$o1}) . "\n";
}
$text =~ s/---REQUIREMENT---/$o2/gs;
$text = $text . $self->{'log'} . "\nLOG_DATA\n\n\n";
if ($self->{'___JUMP___'}) {
$text = $text . "sub dump_data \{ \<\<\'DUMP_DATA\' \}\n";
$text = $text . encode_base64(Dumper($self)) . "DUMP_DATA\n";
}
return($text."\n1\;\n");
}
#******************************************************************
sub goto_next_function {
my $self = shift;
my %list_of_functions = eval("\%".ref($self)."::");
my @ee = caller(2);
$ee[3] =~ s/^(.*)\:\:(.*)$/$2/;
my $jump = "";
my $func;
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*)$/);
if ($ee[3] eq "") { $jump = $func; }
if ($func eq $ee[3]) { $ee[3] = ""; }
last if ($jump);
}
print STDERR "Jump to: $jump\n" if ($jump);
return($jump);
}
#******************************************************************
sub simple_report {
my $self = shift;
my $rfile = shift; # Reportliste, Dateiname
my $rlist = shift;
my $o;
if (!(ref($rlist))) {
$rlist = {};
open(FFILE,"<".$rlist);
while (0 == 0) {
$o = shift(<FFILE>);
last if (!$o);
next if ($o !~ /^ *(.*?) +(\d+\.\d+) +(\d+) +(\d+) +(\d+) */);
$rlist->{$1} = [$2,$3,$4,$5];
}
close(FFILE);
}
my $result = $self->result();
my $requs = $self->requ();
$requs = {@$requs};
foreach $o (keys %$requs) { # Hinzufuegen zur Requirementliste
if (!(exists($rlist->{$o}))) {
$rlist->{$o} = [0.00,0,0,0,0];
}
$rlist->{$o}->[0] = 1 - (1 - $rlist->{$o}->[0])*(1 - $requs->{$o});
$rlist->{$o}->[1] = $rlist->{$o}->[1] + 1;
if ($result == 1) {
$rlist->{$o}->[2] = $rlist->{$o}->[2] + 1;
}
elsif ($result < 1000) {
$rlist->{$o}->[3] = $rlist->{$o}->[3] + 1;
}
else {
$rlist->{$o}->[4] = $rlist->{$o}->[4] + 1;
}
}
my $pkg = ref($self);
my $dir = "./" . $pkg;
$dir =~ s/\:\:/\//g;
opendir(DDIR,"$dir"); # Unteritems finden
my $subitems = [];
while (0 == 0) {
$o = readdir(DDIR);
last if (!$o);
next if ($o !~ /^(.*)\.(exe|pm|py|groovy)$/);
push(@$subitems,[$pkg."::".$1,$dir."/".$o]);
}
if (!$rfile) {
$rfile = $pkg . ".report";
$pkg =~ s/\:\:/\_\_/g;
push(@$subitems,["",""]);
}
foreach $o (@$subitems) {
eval("use " . $o->[0]);
if (!$@) {
$o->new()->simple_report($rfile,$rlist);
} else {
if (ref($rlist)) {
my $text = "\n\n\nRequirement " .
" Sensitivity All_Tests OK WARNING ERROR\n" .
"-----------------------------------------------------" .
"------------------------\n\n";
foreach $o (keys %$rlist) {
next if ($o eq "Standard");
next if ($o eq "run");
$text = $text . substr($o." ".$o,0,35) .
sprintf("%5.3f",$rlist->{$o}->[0]) . " " .
sprintf("%3u", $rlist->{$o}->[1]) . " " .
sprintf("%3u", $rlist->{$o}->[2]) . " " .
sprintf("%3u", $rlist->{$o}->[3]) . " " .
sprintf("%3u", $rlist->{$o}->[4]) . "\n";
}
return($rlist) if (!($o->[0])); # End-Ausgabe
open(FFILE,">$rfile");
print FFILE $text;
close(FFILE);
$rlist = "";
}
system($o->[1] . " simple_report $rfile");
}
}
return($rlist);
}
#************************************************************
sub add_log {
my $self = shift;
my $mode = shift;
my $text = shift;
$self->{'log'} = $self->{'log'} . $text . "\n";
print $text . "\n";
}
#************************************************************
sub add_req {
my $self = shift;
my $val = shift;
my $requ = shift;
$self->{'requ'}->{$requ} = $val;
$self->add_log(0," ---> Requirement $requ added with sensitivity $val");
}
#************************************************************
1;