Welcome To Our Shell

Mister Spy & Souheyl Bypass Shell

package DivBasicF::AutoItem;

use strict;
use vars qw(@ISA);
use Data::Dumper;
use DivBasicF::ObjProcess;
@ISA = qw(DivBasicF::ObjProcess);

our $maxvalue = 0.1**43.4294;

#******************************************************************

sub init_idx { return("package,pkgend,pkgstart,program,syntax," .
                      "level,requestmode,result,remark"); }
sub tblrequ  { return("conn_requ"); }

#**********************************************************************

sub init_db {

   my $self         = shift;
   my $dbh          = shift;
   my $create_index = shift;
   my $requtbl      = $self->tblrequ();
   
   $dbh->do("create table if not exists $requtbl " .
            " (testitem text,level text,arch text,user text," .
            "requ text,relevance double)");
                      
   $dbh->do("$create_index $requtbl"."_testitem__idx on $requtbl (testitem)");
   $dbh->do("$create_index $requtbl"."_level__idx on $requtbl (level)");
#   $dbh->do("$create_index $requtbl"."_arch__idx on $requtbl (arch)"); 
             # fuehrt zu unguenstigem Query Plan, daher hier den Index NICHT anlegen!
   $dbh->do("$create_index $requtbl"."_user__idx on $requtbl (user)");
   $dbh->do("$create_index $requtbl"."_requ__idx on $requtbl (requ)");
   $dbh->do("$create_index $requtbl"."_relevance__idx on $requtbl (relevance)");

}

#******************************************************************

sub IDX {

   my $self = shift;

   my $o; my $r;
   my $dbh = $self->{'PARENT'}->dbh();

   my $package            = "package";
   my $testitem           = "testitem";
   my $requtbl            = $self->tblrequ();
   $dbh->do("delete from $requtbl where $testitem = '" . $self->{'package'} . "'");

   if ($self->{'program'} =~ /^package +(\S+?)\;/) {
      $self->{'package'} = $1;
   } 
   eval($self->{'program'});
   if ($@) {
      $self->{'result'}  = 9999;
      $self->{'remark'}  = "FATAL. $@";
      $self->{'requ'}    = {};
      $self->{'user'}    = "";
   } else {
      eval("\$o = \$self->{'package'}->new()");
      if ($@) {
         $self->{'result'} = 8000;
         $self->{'remark'} = "To be continued";
      } else {
         $self->{'result'} = $o->result();
         $self->{'remark'} = $o->remark();
         $self->{'requ'}   = {@{$o->requ()}};
         $self->{'user'}   = $o->user();
      }
   }   
      
   $self->{'requestmode'} = 0;
   $self->{'pkgstart'}    = $self->{'package'} . "::";
   $self->{'pkgend'}      = $self->{'package'} . "::zzzz";
   $self->{'level'}       = $self->{'package'};
   $self->{'level'}       =~ s/[^\:]//g;
   $self->{'level'}       = sprintf("%03u",length($self->{'level'})/2);
   my $pkg                = $self->{'package'};
   my $level              = sprintf("%03u",$self->{'level'} + 1);
   my $store              = $self->{'PARENT'}->tblstore();
   my $arch               = "";
   my $user               = "";
   $self->{'requ'}->{'ALL'} = 0.9999999 if (join("",values %{$self->{'requ'}}) =~ /^(11|1)$/);
#   if ($self->{'program'} =~ /sub +formular +/) { $self->{'requestmode'} = 2; }
#   if ($self->{'program'} =~ /\_REQUEST\_/)     { $self->{'requestmode'} = 1; }

#  Berechnung der neuen kumulierten Requirement-Relevanzen

   foreach $r (reverse sort { $self->{'requ'}->{$a} <=> $self->{'requ'}->{$b} }
                      keys %{$self->{'requ'}}) {
      $o = 1 - $self->{'requ'}->{$r};
      if ($o < $maxvalue) {
         $arch = $r if ($r =~ /^ARCH/);
         $user = $r if ($r =~ /^USER/);
      } else {
         $o = sprintf("%12.9f",-log($o));
         $dbh->do("insert into $requtbl ($testitem,level,arch,user,requ,relevance) "
          . " values ('$pkg','".$self->{'level'}."','$arch','$user','$r',$o)");
      }
   }
 
   delete ($self->{'PARENT'}->{'DBH'});
   
   return($self->{'package'});

   
}

#******************************************************************

#  to overload:

sub result { my $self = shift; return(0); }
sub remark { my $self = shift; return(""); }
sub user   { my $self = shift; return("");  }
sub requ   { my $self = shift; return([]); }

sub run    {

   my $self = shift; 
   $self->test_start(@_);

   my $o = <<'TEXT_ENDE';
sub run    {

   my $self = shift; 
   $self->test_start(@_);

   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 (@_) {
      $o = shift(@_);
      next if (!$o);
      push(@pars,$o);
   }
   $self->{'requ'} = { @pars };
#   $self->{'requ'} = { @{$self->requ()}, @pars };
   foreach $o (keys %{$self->{'requ'}}) {
      if ($o =~ /^___(.*)___$/) {
         $self->{$o} = $self->{'requ'}->{$o};
         delete( $self->{'requ'}->{$o} );
      }
   }

}

#******************************************************************

sub test_end {

   my $self        = shift;
   $self->{'log'} .= shift;

   my $user1 = "xx"; 

   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$@;
   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); # 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/gs;

   $o    = $self->{'result'}    || 0;
   $text =~ s/---RESULT---/$o/gs;
   $o    = $self->{'remark'}    || "";
   $text =~ s/---REMARK---/$o/gs;

   $text =~ s/---REQUIREMENT---/$r/gs;
   
   $self->{'program'} = $text;
   delete ($self->{'___JUMP___'});

   $self->{'PARENT'}->push( $self, $self->{'PARENT'}->get_connection() ) || $self->{'program'};


}

#******************************************************************

#  Hier koennen Teile des Test-trees ausgegeben werden.
#  Die Tiefe $depth gibt an, bis zu welcher Tiefe Test-Items
#  ausgegeben werden. Eine Liste aller Child-Items des gegebenen
#  Test-Items erhaelt man mit  $depth = 1.
#
#  In $archs kann eine kommaseparierte Liste aller Architekturen
#  angegeben werden. Bleibt die Liste leer, dann werden alle
#  Architekturen angegeben.
#
#  Wird die Tiefe negativ angegeben, dann wird ueber alle Requirements
#  summiert, so dass man einfach eine Liste aller Test-Items bekommt.
#  In diesem Fall ist die Relevanz der Tests ohne Bedeutung
#
#  Ausgabeformat:
#  Architektur, Requirement, Test-Item, Fehler-Code, Relevanz, Remark 


sub report {

   my $self  = shift;
   my $depth = shift;  #  Tiefe, bis zu der Child-Items verfolgt werden
   my $archs = shift;  #  Kommaseparierte Liste von Architekturen
   my $o     = shift || $self->{'package'};
   
   my $dump  = 0;
   if ($archs =~ s/^\.//) {
      $dump = 1;
   }
   
   my $requ = "r.requ";
   my $arch = "r.arch";
   if ($depth < 0) {   #  alle Requirements werden zusammengefasst
      $depth = -$depth;
      $requ = "'ALL'";
      $arch = "'ALL'";
   }
   if ($depth < 1) { $depth = 0; }
      
   my $requtbl = $self->tblrequ();
   my $store   = $self->{'PARENT'}->tblstore();
   my $dbh     = $self->{'PARENT'}->dbh();
   
   if ($depth == 9999) {
      $o = " o.result='' ";
   } else {
      $o =~ s/[^\:]//gs;
      $o =  length($o)/2;
      $o = $o + $depth + 1;
      $o = 999 if ($o > 999);
      $o = " o.level < '" . sprintf("%03u",$o) . "' ";
   }
   if ($archs) {
      $archs =~ s/\,/\' or r.arch=\'/gs;
      $archs = " and ( r.arch='" . $archs . "' ) "; 
   }

   my $cursor = "select $arch,$requ,o.package,max(o1.result)," .
                   "sum(r.relevance),o.remark,substr(o.text,0,20) from " .
                   "$store as o,$store as o1,$requtbl as r where " .
                   "o1.package=r.testitem and " .
                   "(o.pkgstart < o1.package and o1.package < o.pkgend " .
                   "or o.package=o1.package) $archs and " .
                   "o.package like '" . $self->{'package'} . "\%' and $o " .
                   "group by $arch,$requ,o.package";

# print STDERR "CURSOR: $cursor\n";

   my @ee;
   my $erg = [];
   $cursor = $dbh->prepare($cursor);
   $cursor->execute();

   while (0 == 0) {
      @ee = $cursor->fetchrow();
      last if (!@ee);
      $ee[4] = 1 - exp((-1)*$ee[4]) if ($requ =~ /\./);
      if ($ee[6] =~ /^\.run\./) {
         $ee[4] = "RUNNING";
         $ee[5] = "Item is running";
      }
      elsif ($ee[5] =~ /^WAIT/) {
         $ee[4] = $ee[5];
         $ee[5] = "Item sleeps";
      }
      elsif ($ee[5] =~ /^REQUEST/) {
         $ee[4] = $ee[5];
         $ee[5] = "Item requests additional info";
      }
      elsif ($ee[5] eq '') {
         $ee[5] = "OK"      if ($ee[3] == 1);
         $ee[5] = "WARNING" if ($ee[3] > 1);
         $ee[5] = "ERROR"   if ($ee[3] > 1000);
      }
      pop(@ee);
      push(@$erg,[@ee]);
   }
   $erg = [ sort {
               "::" . $a->[0] . "::" . $a->[1] . "::" . $a->[2] . "::" cmp
               "::" . $b->[0] . "::" . $b->[1] . "::" . $b->[2] . "::"
               } @$erg ];
   $cursor->finish();
   delete ( $self->{'PARENT'}->{'DBH'} );
   
   return( Dumper($erg) ) if ($dump);
   return($erg);
   
}

#*************************************************************************

sub sleep {

   my $self = shift;
   my $time = shift;

   if (!$time) {
      $time = $self->{'PARENT'}->max_time();
      $self->{'remark'} = "REQUEST";
   } else {
      $self->{'remark'} = "WAIT" . $time;
   }
   $self->sleep($time);
   
}

#*************************************************************************

sub check {

   my $self   = shift;
   my $o1     = shift;
   my $o2     = shift;
   my $o3     = shift;
   if ($o1 == "") { $o1 = $o2; $o2 = $o3; }

   $o1     = "," . $o1 . ",";
   $o2     = "," . $o2 . ",";
   my $not = "";
   if ($o1 eq ",OK," or $o2 !~ /$o1/) {
      $self->{'result'}   = 1009;
      $self->{'remark'}   = "Wrong check. \n$o1 does not match \n$o2.";
      $not = " NOT";
   }
   
   $self->{'log'} .= "\nCheck$not passed: $o1  <=>  $o2\n--------------------------\n\n";
   $self->test_end() if ($not);
   
}


#*******************************************************
#*******************************************************

#  Obsolet:

sub xxreport {

   my $self  = shift;
   my $depth = shift;  #  Tiefe, bis zu der die Test-Items aufgeloest werden
   my $requs = shift;  #  Liste von Requirements, kommasepariert
   
   my $o; my $rel; my $rtable; my @ee;
   my $requtbl = $self->{'PARENT'}->special_func("tblrequ");
   my $store   = $self->{'PARENT'}->tblstore();

   my $cursor = "select r.requ,o.package,o.maxresult,r.relevance," .
                "o.result,o.remark,o.user---RELEVANCE--- from " .
                "$requtbl as r,$store as o---TBL--- where " .
                "o.package like '" . $self->{'package'} . "\%' and " .
                "o.package=r.testitem";

   my $zaehler = 0;

   foreach $o (split(/,/,$requs)) {
      $zaehler = sprintf("%1u",$zaehler+1);
      $rtable  = $rtable . ",$requtbl as r$zaehler";
      $rel     = ",r$zaehler.relevance";
      $cursor  = $cursor . " and o.package=r$zaehler.testitem and " .
                 "r$zaehler.requ='$o' and not r.requ ='$o'";
   }
   $cursor =~ s/---RELEVANCE---/$rel/;
   $cursor =~ s/---TBL---/$rtable/;
# print "CC: $cursor\n"; sleep 5;
   
   my $erg = [];
   my $dbh = $self->{'PARENT'}->dbh();
   $cursor = $dbh->prepare($cursor);
   $cursor->execute();
   while (0 == 0) {
      @ee = $cursor->fetchrow();
      last if (!@ee);
      push(@$erg,[$ee[0]."::".$ee[1],[@ee]]);
   }
   $cursor->finish();
   delete ( $self->{'PARENT'}->{'DBH'} );
   return($erg);
   
}

#*************************************************************************

1;