Welcome To Our Shell

Mister Spy & Souheyl Bypass Shell

package DivBasicF::AutoItem;

use strict;
use vars qw(@ISA);
use Data::Dumper;
use Digest::SHA1;
use DivBasicF::TestTree;
use DivBasicF::ObjTask;
use Digest::SHA1;
@ISA = qw(DivBasicF::TestTree);

our $maxvalue = 0.1**43.4294;

sub DELIVER { 2 };

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

sub init         { my $self = shift; $self->{'PARENT'} = DivBasicF::ObjTask->new(); }
sub init_idx     { "package,pkgend,pkgstart,program,syntax,level,requestmode,result,remark"; }
sub tblrequ      { "conn_requ"; }
sub tbluser      { "conn_user"; }
sub tblarch      { "conn_arch"; }
sub make_package { 1; }

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

sub init_db {

   my $self         = shift;
   my $dbh          = shift;
   my $create_index = shift;
   my $o            = shift;
   my $requtbl      = $self->tblrequ();
   my $usertbl      = $self->tbluser();
   my $archtbl      = $self->tblarch();
   
   $dbh->do("create table if not exists $requtbl " .
            " (testitem text,level text,arch text,user text," .
            "requ text,relevance double)");
                      
   $dbh->do("create table if not exists $usertbl " .
            " (user text unique,accessrights text)");
                      
   $dbh->do("create table if not exists $archtbl " .
            " (arch text unique,remark text)");
                      
   $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)");

   $dbh->do("$create_index $usertbl"."_user__idx on $usertbl (user)");

   $dbh->do("insert into $usertbl (user,accessrights) values ('$o',':')");

}

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

sub IDX {

   my $self = shift;

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

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

   if ($self->{'program'} =~ /^package +(\S+?)\;/) {
      $self->{'package'} = $1;
   } 
      
   $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               = "NOARCH";
   my $user               = "NOUSER";
   $self->{'requ'}->{'ALL'} = 0.9999999 if (join("",values %{$self->{'requ'}}) =~ /^(11|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)");
      }
   }
   my $cursor = $dbh->prepare("select arch from $archtbl where arch = '$arch'");
   $cursor->execute();
   my @ee = $cursor->fetchrow();
   $cursor->finish();
   if (!@ee) {
      $dbh->do("insert into $archtbl (arch,remark) values " .
               "('$arch','Architecture $arch')");
   }
 
   delete ($self->{'PARENT'}->{'DBH'});
   
   return($self->{'package'});

   
}

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

sub save_package {

   my $self = shift;
   $self->{'program'} = shift;
   delete ($self->{'___JUMP___'});
   $self->{'PARENT'}->push( $self, $self->{'PARENT'}->get_connection() ) || $self->{'program'};
   
}

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

sub request {

   my $self = shift;
   $self->{'result'} = 9903;
   $self->{'remark'} = "REQUEST";
   my $o = $self->{'PARENT'}->connection(".");
   $self->{'PARENT'}->msg1([@_]);
   return( $self->{'PARENT'}->push( $self,$o ) );
   
}


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

sub sleep {

   my $self = shift;
   my $time = shift;
   my $func = shift || $self->goto_next_function();
   if ($self->{'___NOSLEEP___'}) {
      delete($self->{'___NOSLEEP___'});
      $time = 0;
   }
   if ($time == -1 or $time =~ /^max/i) {
      $time = $self->{'PARENT'}->max_time();
      $self->{'result'} = 9901;
      $self->{'remark'} = "REQUEST";
   } else {
      if ($time < -1) {
         $time = - $time;
      } else {
         $time = $time + time();
      }
      $self->{'result'} = 9902;
      $self->{'remark'} = $time;
   }

   my $o; my $o1; my @ee; my $dbh; my $cursor; my $nr;
   if (!($self->{'package'})) {
      $dbh    = $self->{'PARENT'}->dbh();
      $o      = ref($self);
      $cursor = $dbh->prepare("select package from " .
                   $self->{'PARENT'}->tblstore() .
                   " where package like '$o\%'");
      $nr = 0;
      $cursor->execute();
      while (0 == 0) {
         @ee = $cursor->fetchrow();
         last if (!@ee);
         next if ($ee[0] !~ /^$o\:\:(\d+)$/);
         $o1 = $1;
         next if ($o1 < $nr);
         $nr = $o1;
      }
      $cursor->finish();
      $self->{'package'} = ref($self) . "::" . sprintf("%03u",$nr+1);
      $self->{'requ'}    = { 'Standard' => 0.01 };
   }

   $o = $self->{'PARENT'}->msg([$func,@_],$time);
   return( $self->{'PARENT'}->push( $self,$o ) );

}


sub mk_package { 1; }

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


#  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 , Hash-Wert
#  Wird der Architekturangabe ein Punkt vorangestellt, dann werden
#  NUR die Hash-Werte ausgegeben.

sub report {

   my $self  = shift;
   my $depth = shift;  #  Tiefe, bis zu der Child-Items verfolgt werden
   my $archs = shift;  #  Kommaseparierte Liste von Architekturen
   my $requs = "";
   if ($archs =~ s/^(.*)\:(.*)$/$1/) {
      $requs = $2;
   }
   my $only_hashes = 0;

   if ($archs =~ s/^\.//) {
      $only_hashes = 1;
   }

   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'" if (!$requs);
      $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 . "' ) "; 
   }
   if ($requs) {
      $requs =~ s/\,/\' or r.requ=\'/gs;
      $requs = " and ( r.requ='" . $requs . "' ) "; 
   }

   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.result < 9905 and o.result < 9905 and o1.package=r.testitem " .
                   "and (o.pkgstart < o1.package and o1.package < o.pkgend " .
                   "or o.package=o1.package) $archs $requs 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);
      }
      $ee[2] = $ee[1] . "::" . $ee[2] if ($requs);
      pop(@ee);
      $ee[6] = substr(Digest::SHA1::sha1_hex(join("-",@ee)),0,8);
      if ($only_hashes) { @ee = ($ee[2],$ee[6]); }
      push(@$erg,[@ee]);
   }
   $erg = [ sort {
               "::" . $a->[0] . "::" . $a->[1] . "::" . $a->[2] . "::" cmp
               "::" . $b->[0] . "::" . $b->[1] . "::" . $b->[2] . "::"
               } @$erg ] if (!$only_hashes);
   $cursor->finish();
   delete ( $self->{'PARENT'}->{'DBH'} );
   return( Dumper($erg) ) if ($dump);
   return($erg);
   
}

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

sub user_settings {

   my $self     = shift;
   my $user     = shift;
   my $changes  = shift;

   my $usertbl  = $self->tbluser();
   my $dbh      = $self->{'PARENT'}->dbh();
   
   my $o; my $mode; my @ee;
   my $erg = {};
   my $cursor = "select user,accessrights from $usertbl";
   $cursor = $dbh->prepare($cursor);
   $cursor->execute();
   while (0 == 0) {
      @ee = $cursor->fetchrow();
      last if (!@ee);
      $erg->{$ee[0]} = $ee[1];
   }
   $cursor->finish();

   return if (!(exists $erg->{$user}));
   return if ($erg->{$user} ne ":");


   foreach $o (split(/,/,$changes)) {

      $mode = substr($o,0,1);
      $o    = substr($o,1);
      if    ($mode eq ":" and $erg->{$o} eq ":") {       #  ist und bleibt ein Admin
         1;
      }
      elsif ($mode eq ":" and $erg->{$o} eq ".") {       #  Aenderung eines Users
         $dbh->do("update $usertbl set accessrights=':' where user='$o'");  #  in einen Admin
         $erg->{$o} = ":";
      }
      elsif ($mode eq ":" and (!(exists $erg->{$o}))) {  #  Admin anlegen
         $dbh->do("insert into $usertbl (user,accessrights) values ('$o',':')");
         $erg->{$o} = ":";
#         $dbh->do("delete from $usertbl where user='$o'");
      }


      elsif ($mode eq "." and $erg->{$o} eq ":") {       #  Aenderung eines Admin
         $dbh->do("update $usertbl set accessrights='.' where user='$o'");  #  in einen User
         $erg->{$o} = ".";
      }
      elsif ($mode eq "." and $erg->{$o} eq ".") {       #  ist und bleibt ein User
         1;
      }
      elsif ($mode eq "." and (!(exists $erg->{$o}))) {  #  User anlegen
         $dbh->do("insert into $usertbl (user,accessrights) values ('$o','.'");
         $erg->{$o} = ".";
      }


      elsif ($mode eq "=") {       #  Loeschen eines Admin/Users
         $dbh->do("delete from $usertbl where user='$o'");
         delete ($erg->{$o});
      }

   }

   return($erg);

}

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

sub arch_settings {

   my $self     = shift;
   my $arch     = shift;
   my $remark   = shift;

   my $archtbl = $self->tblarch();
   my $store   = $self->{'PARENT'}->tblstore();
   my $dbh     = $self->{'PARENT'}->dbh();
   
   my $archs = {};
   my @ee;

   my $cursor = "select arch,remark from $archtbl";
   $cursor = $dbh->prepare($cursor);
   $cursor->execute();
   while (0 == 0) {
      @ee = $cursor->fetchrow();
      last if (!@ee);
      $archs->{$ee[0]} = $ee[1];
   }
   $cursor->finish();

   return($archs) if (!$arch);

   if (exists $archs->{$arch}) {
      if ($remark eq "___DELETE___") {
         $dbh->do("delete from $archtbl where arch='$arch'");
         delete($archs->{$arch});
      } else {
         $dbh->do("update $archtbl set remark='$remark' where arch='$arch'");
         $archs->{$arch} = $remark;
      }
   }
   elsif ($remark ne "___DELETE___") {
      $dbh->do("insert into $archtbl (arch,remark) values ('$arch','$remark')");
      $archs->{$arch} = $remark;
   }
   
   $cursor = "select arch from $archtbl where arch='$arch'";
   $cursor = $dbh->prepare($cursor);
   $cursor->execute();
   @ee     = $cursor->fetchrow();
   $cursor->finish();
   return("ERROR___ARCH_NOT_DELETED___")       if (@ee  and $remark eq "___DELETE___");
   return("ERROR___ARCH_NOT_ADDED_UPDATED___") if (!@ee and $remark ne "___DELETE___");
   return($archs);   

}


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

sub queries {

   my $self = shift;
   my $fkt  = shift;
   my $pars = [@_];
   
   my $o;
   my $pars1 = [];
   $self->{'___NOSLEEP___'} = 1;
   foreach $o (@$pars) {
      $o =~ s/^VAR\://;
      push(@$pars1,$o);
   }
   eval("\$o = \$self->$fkt('" . join("','",@$pars1) . "');");
   return($o) if (!$@);
   
   delete($self->{'___NOSLEEP'});
   $self->{'log'} = "Interactive dialog:\n------------------------\n\n";
   foreach $o (@$pars) {
      if ($o =~ s/^VAR\:(.*)$/$1\: /) {
         $o = $o . $self->{$1};
      }
      $self->{'log'} = $self->{'log'} . $o . "\n";
   }
   return("");
   
}

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

sub answers {

   my $self = shift;
   my $text = "\n" . shift;
   
   while (0 == 0) {
      last if ($text !~ s/\n([A-Z][A-Z0-9]+)\: +(\.*?)\n/\n/s);
      $self->{$1} = $2;
   }
   
}

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

#  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);
   
}

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

sub xxcheck {

   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);
   
}


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



1;