Welcome To Our Shell

Mister Spy & Souheyl Bypass Shell

package DivBasicF::ObjTask;

use strict;
use DBI;
use DBD::SQLite;
use Time::HiRes;
use Data::Dumper;

sub DELIVER { 2 }

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

#  Dieses Modul ermoeglicht einen Datenaustausch von Messages in
#  Form von gedumpten Perl-Objekten ueber eine Datenbank.
#
#  Benoetigte Environment-Variable:
#
#  procdb:  Datenbank-String, z.B.: dbi:SQLite:/home/user/testdb7.db
#
#  Konstruktor:   my $task = DivBasicF::ObjTask->new();
#
#  Messages bestehen aus:
#     einer Message-ID (20-stellige Kombination aus Zahlen und Kleinbuchstaben)
#     einer Nachricht  (beliebiges Perl-Objekt)
#     eine Antwort-ID, unter der eine Antwort-Message erwartet wird
#
#  Mit $id = $task->msg($message) kann eine Message hinterlegt werden,
#  wobei die Message-ID $id der Message zurueckgegeben wird.
#  Eine andere Instanz  $task1  von DivBasicF::ObjTask, die auf diese
#  ID mit $task1->connection($id) gesetzt wird, kann dann ein Handshaking
#  mit der ersten Instanz beginnen:
#
#
#      $id = $task->msg($message1)
#                                      $task1->connection($id);
#                                      $message1 = $task1->get();
#                                      $task1->msg($message2);
#      $message2 = $task->get();
#      $task->msg($message3);
#                                      $message3 = $task1->get();
#                                         ....
#           .....
#
#  Dieses Handshaking funktioniert ueber gleichzeitig mit der Message
#  hinterlegte Ruecksende-IDs, unter denen der empfangende Prozess
#  antworten kann und auf die wiederum auf der Gegenseite gelauscht wird.
#
#  Zeitverhalten:
#  $task->msg($message,<time>) ermoeglicht das zeitversetzte Hinterlegen
#  einer Message: Erst nach <time> Sekunden wird die Message aktiv und kann
#  abgerufen werden.
#
#  Ist eine Message noch nicht abrufbar, dann sendet die Methode  get
#  einen Nullwert zurueck.
#
#
#
#  Einfrieren von Objekten:
#
#  $task kann Objekte in einer Task-Tabelle einfrieren:
#     $task->push($obj,$conn)
#  Hierbei wird eine Message-ID $conn mit hinterlegt.
#
#  Das Auftauen eines Objekts aus der Datenbank geschieht mit:
#     my ($obj,$conn) = $task->fetch(<query-string>,<mode>);
#
#  Der Query-String ist ein logischer Ausdruck einer
#  Datenbank-Klausel. Die Tabellenspalten der Task-Tabelle
#  sind mit IDX.<spalte> adressierbar. Der symbolische logische
#  Ausdruck  MESSAGE  setzt die Bedingung, dass nur Objekte
#  in Betracht gezogen, unter deren Message-ID eine Nachricht
#  vorliegt.
#  Rueckgegeben wird das aufgetaute Objekt sowie die entsprechende
#  Message-ID.
#
#  Beispiel:   ($obj,$conn) = $task->fetch("MESSAGE","lock")
#  holt einen Task $obj aus der Datenbank, fuer den eine Message
#  unter der Message-ID $conn vorliegt.
#
#  Indem ein Objekt sich selbst eine zeitversetzte Nachricht schickt,
#  und dann sich selbst mit einem  $task->push($self,$conn)  in
#  die Task-Tabelle dumpt, koennen langlaufende Sleeps ueber die
#  Task-Tabelle realisiert werden. Man braucht dazu einen weiteren Prozess,
#  der in einer Schleife immer wieder Prozesse auftaut, fuer die
#  ihre eigene Aufwach-Nachricht gueltig wird ('Wecker'-Funktion).

sub new {

	my $class = shift;
	my $self  = {};
	bless( $self, $class );
	my $obj = shift;

	# 1. Variablen abspeichern

	( $obj, $self->{'CONN'}, $self->{'STORE'}, $self->{'LOCK'}, $self->{'SEMA'} ) =
	  split( /,/, $obj );
	delete( $self->{'CONN'} )  if ( !( $self->{'CONN'} ) );
	delete( $self->{'STORE'} ) if ( !( $self->{'STORE'} ) );
	delete( $self->{'LOCK'} )  if ( !( $self->{'LOCK'} ) );
	delete( $self->{'SEMA'} )  if ( !( $self->{'SEMA'} ) );

	# 2. Weitere Variablen und Defaultwerte:

	$main::ENV{'procwaittime'}  = $main::ENV{'procwaittime'}  || 20;
	$main::ENV{'procfrequency'} = $main::ENV{'procfrequency'} || 25;

	( $main::ENV{'proccycles'}, $main::ENV{'procinterval'} ) =
	  $self->cycles_interval( $main::ENV{'procwaittime'},
		$main::ENV{'procfrequency'} );

	$Data::Dumper::Deepcopy = 1;
	$Data::Dumper::Indent   = 1;

	#   $Data::Dumper::Purity   = 1;  # damit NICHT immer die CODE-DUMMY-
	# Meldungen angezeigt werden, ist das
	# hier auskommentiert

	return ($self) if ( !$obj );

	# 3. Datenbankeinrichtung vorbereiten

	my $conn  = $self->tblconn();
	my $store = $self->tblstore();
	my $lock  = $self->tbllock();
	my $sema  = $self->tblsema();


    
        my $create_index = "create_index";
	my $dbh =
	  DBI->connect( split( / +/, $main::ENV{'procdb'} ), { PrintError => 0 } );
      # hier wurde die Datenbank testtree.db erzeugt, falls sie noch nicht existierte 
      #(Spezialität von SQLite)	 
        if($^O ne "MSWin32") {
           system("chmod g+w testtree.db");
           system("chgrp www-data testtree.db");
           say STDERR "DONE: chmod g+w testtree.db and chgrp www-data testtree.db";
        } else {
           no strict;
           use if $^O eq 'MSWin32', 'Win32';
           my $login = Win32::LoginName;
           system("echo y | cacls.exe testtree.db /e /g $login:f");
           say STDERR "DONE: changed control access list for testtree.db";
        }
	
	if ( $main::ENV{'procdb'} =~ /SQLite/ ) {    #  SQLite DB
		$dbh->do("pragma journal_mode=off");
		$create_index = "create index if not exists ";
	}
	elsif ( $self->{'DBSTRING'} =~ /^(.*)\:(.*)\:(.*)\:(.*)$/ ) {    #  MySQL DB
		$self->{'MYSQL'} = [ "dbi:mysql:host=$1\;database=$2", $3, $4 ];
		$dbh = DBI->connect( @{ $self->{'MYSQL'} }, { PrintError => 0 } );
	}

	# 4.  Zusatz-Datenbank-Einrichtung

	eval("use $obj");
	if ($@) {
		return ("ERROR IN DivBasicF::ObjTask: $@\nNo object created\n");
	}
	my $o = $obj;
	$obj = $obj->new();
	$obj->init_db( $dbh, $create_index, $o );

	# 5. Datentabellen einrichten, wenn noetig

	$o = "," . $obj->init_idx() . ",";
	$o =~ s/\,([a-zA-Z0-9\_]+)/\,$1 text/g;
	$o =~ s/^(,*)(.*?)(,*)$/$2/;
	if ($o) { $o = "," . $o; }

	$dbh->do( "create table if not exists $conn "
		  . "(replynr varchar(20),msgid varchar(20),"
		  . "msgtime varchar(16),text text,"
		  . "connlock varchar(7))" );
	$dbh->do( "create table if not exists $lock " . "(id varchar(20) unique)" );
	$dbh->do( "create table if not exists $sema "
		  . "(id varchar(30) unique,text text,semalock varchar(1))" );
	$dbh->do( "create table if not exists $store "
		  . " (conn varchar(20),text text,objlock varchar(1)"
		  . $o
		  . ")" );

	# 6. Indexe einrichten, wenn noetig

	$dbh->do( "$create_index $conn" . "_replynr__idx on $conn (replynr)" );
	$dbh->do( "$create_index $conn" . "_msgid__idx   on $conn (msgid)" );
	$dbh->do( "$create_index $conn" . "_msgtime__idx on $conn (msgtime)" );

	$dbh->do( "$create_index $lock" . "__idx         on $lock (id)" );
	$dbh->do( "$create_index $sema" . "__idx         on $sema (id)" );

	foreach $o ( split( /\,/, "conn" . $o ) ) {
		next if ( $o !~ /^([a-zA-Z0-9\_]+)/ );
		$dbh->do( "$create_index $store" . "_" . $1 . "__idx on $store ($1)" );
	}

	#   $o = $self->msg(["xxx"],$self->max_time());  #  Wurzel-Item mit in die
	#   $self->push($obj,$o);                        #  Datenbank hineinschreiben

	$dbh->disconnect();
	delete( $self->{'DBH'} );
	undef($dbh);
	return ($self);

}

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

sub get_connection { my $self = shift; return ( $self->{'CONNECTION'} ); }
sub max_time { return (4099887766); }

sub tblconn {
	my $self = shift;
	my $o = $self->{'CONN'} || "conn";
	return ($o);
}

sub tblstore {
	my $self = shift;
	my $o = $self->{'STORE'} || "conn_store";
	return ($o);
}

sub tbllock {
	my $self = shift;
	my $o = $self->{'LOCK'} || "conn_lock";
	return ($o);
}

sub tblsema {
	my $self = shift;
	my $o = $self->{'SEMA'} || "conn_sema";
	return ($o);
}

#sub special_func   {
#   my $self = shift;
#   my $func = shift;
#   return(0) if (!($self->{'SPECIAL'}));
#   return($self->{'SPECIAL'}->$func(@_));
#}

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

#  Hilfsfunktion

sub cycles_interval {

	my $self      = shift;
	my $wait_time = shift;
	my $frequenz  = shift;
	my $cycles    = $main::ENV{'proccycles'};
	my $interval  = $main::ENV{'procinterval'};

	if ( $wait_time < 0 ) {
		return ( 1, 0 );
	}

	if ($frequenz) {
		if ( !$wait_time ) {
			$wait_time = $main::ENV{'procwaittime'};
		}
		$cycles   = $wait_time * $frequenz;
		$interval = 1 / $frequenz;
	}
	elsif ($wait_time) {
		$cycles = $wait_time * $main::ENV{'procfrequency'};
		$cycles = 1 if ( $cycles < 1 );
	}

	return ( $cycles, $interval );

}

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

sub dbh {

	my $self = shift;

	#   if (!($self->{'DBH'})) {
	#      print STDERR `pwd` . "\n";
	#      opendir(".",DDIR);
	#      while (0 == 0) {
	#         my $o = readdir(DDIR);
	#         last if ($o);
	#         print STDERR "DD Datei: $o\n";
	#      }
	#      closedir(DDIR);

	#      print STDERR "DDM: $main::ENV{'procdb'} " . `pwd` . "\n";
	return (0) if ( !( $main::ENV{'procdb'} ) );
	$self->{'DBH'} =
	  DBI->connect( split( / +/, $main::ENV{'procdb'} ), { PrintError => 0 } );

	#     print STDERR "QQQ: " . $self->{'DBH'} . "\n";
	#   }
	return ( $self->{'DBH'} );

}

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

sub connection {    #   $self->{'CONNECTION'} wird auf $conn gesetzt.
	                #   Wenn es das nicht gibt, dann wird eine neue
	my $self = shift;    #  $self->{'CONNECTION'} generiert und die alte
	my $conn = shift;    #  zurueckgegeben.

	if ($conn) {
		$self->{'CONNECTION'} = $conn if ( $conn ne "." );
		return ($conn);
	}

	my $msgid;
	my $erg;
	my $pattern;
	my $dbh;
	my $lock;

	$conn = $self->{'CONNECTION'};

	$lock    = $self->tbllock();
	$pattern = [
		qw(0 1 2 3 4 5 6 7 8 9 a b c d e f g h i j k),
		qw(l m n o p q r s t u v w x y z z z z)
	];
	$dbh = $self->dbh();
	my $zaehler = 1;
	while ( 0 == 0 ) {    # Erstellung der neuen Message-Id
		$zaehler = $zaehler + 1;
		$msgid   = [];
		while ( $#{$msgid} < 19 ) {
			push( @$msgid, $pattern->[ int rand(35) ] );
		}
		$msgid = join( "", @$msgid );
		next if ( $msgid eq $self->{'RESET_ID'} );
		$erg =
		  $dbh->do( "insert into $lock (id) values ('$msgid')",
			{ PrintError => 0 } );    #  locken
		last if ( $erg == 1 );        #  wenn erfolgreich eingetragen
		print STDERR
"NO ERROR. But Warning: $msgid happens to exist yet. Erg: $erg. New attempt\n";
		last if ( $zaehler > 100 );
	}
	$self->{'CONNECTION'} = $msgid;
	return ($conn);

}

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

#  Senden einer Message, neue Connection ID

sub msg {

	my $self = shift;
	delete( $self->{'CONNECTION_OLD'} );
	return ( $self->msg1(@_) );

}

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

#  Senden einer Message, Beibehaltung der Connection ID

sub msg1 {

	my $self    = shift;
	my $text    = shift;
	my $msgtime = shift;    #  optionale Zeit, zu der die Message gueltig sein soll
	$msgtime = 1 if ( !$msgtime );
	my $cursor;
	my @ee;

	my $dbh  = $self->dbh();
	my $conn = $self->connection( $self->{'CONNECTION_OLD'} );
	$conn = $self->connection() if ( !$conn );

	my $erg = $dbh->do(
		"insert into "
		  . $self->tblconn()
		  . " (replynr,msgid,msgtime,text,connlock)"
		  . " values ('"
		  . $conn . "','"
		  . $self->{'CONNECTION'}
		  . "',$msgtime,?,'0')",
		{}, Dumper($text)
	);

	return ("") if ( $erg eq "0E0" );
	return ($conn);

}

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

#  Holen einer Message

sub get {

	my $self      = shift;
	my $wait_time = shift;    #   Wartezeit
	my $frequenz  = shift;    #   Warte-Frequenz pro Sekunde

	my ( $cycles, $interval ) = $self->cycles_interval( $wait_time, $frequenz );
	my $zaehler = 0;
	my $text;
	my $o;
	my $VAR1;
	my $cursor;
	my @ee;
	my $mark;
	my $dbh = $self->dbh();

	my $conn = $self->tblconn();
	my $lock = $self->tbllock();

	while ( 0 == 0 ) {
		$zaehler = $zaehler + 1;
		return () if ( $zaehler > $cycles );
		$o = time();
		$cursor =
		  $dbh->prepare( "select msgid from $conn where replynr='"
			  . $self->{'CONNECTION'}
			  . "' and "
			  . "msgtime+0 < $o limit 1" );
		$cursor->execute();
		@ee = $cursor->fetchrow();
		$cursor->finish();
		next if ( !@ee );
		next if ( !( $ee[0] ) );
		$o = $ee[0];
		$mark = sprintf( "%1u", int( 1000000 + rand(8999990) ) );
		$text =
		  $dbh->do( "update $conn set connlock='$mark' where replynr='"
			  . $self->{'CONNECTION'}
			  . "' and msgid='$o' "
			  . "and connlock='0'" );
		last if ( $text ne "0E0" );
		select( undef, undef, undef, $interval );    # sleep 1;

	}
	$cursor =
	  $dbh->prepare( "select msgid,text from $conn "
		  . "where replynr='"
		  . $self->{'CONNECTION'}
		  . "' and msgid='$o' and connlock='$mark'" );
	$cursor->execute();
	@ee = $cursor->fetchrow();
	$cursor->finish();
	$dbh->do( "delete from $conn where replynr='"
		  . $self->{'CONNECTION'}
		  . "' and msgid='$o' and connlock='$mark'" );

	$dbh->do( "delete from $lock where id='" . $self->{'CONNECTION'} . "'" );
	$self->{'CONNECTION_OLD'} = $self->{'CONNECTION'};
	$self->{'CONNECTION'}     = $ee[0];
	eval( $ee[1] );
	return ( "ERROR: " . $@ ) if ($@);
	return ($VAR1);

}

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

sub push {    #  Abspeichern eines Prozesses, der auf den Trigger $conn reagiert

	my $self = shift;
	my $obj  = shift;
	my $conn = shift;    #  Trigger
	my $o    = shift;

	my $dbh = $self->dbh();
	return (0) if ( !$dbh );
	if ( ref($conn) eq "ARRAY" ) {    # wenn es statt einer Connection-ID einen
		$conn = $self->msg( $conn, time() + $o );    # Message-Inhalt gibt
	}
	elsif ($o) {    # Moeglichkeit zur Aenderung der Sleeptime der Message
		$dbh->do( "update "
			  . $self->tblconn()
			  . " set msgtime="
			  . sprintf( "%1u", time() + $o )
			  . " where replynr='$conn'" );
	}

	if ( $obj->{'___conn___'} ) {   #  wenn es einen alten Trigger gibt, den loeschen
		$o =
		  $dbh->do( "delete from "
			  . $self->tblstore()
			  . " where conn='"
			  . $obj->{'___conn___'}
			  . "'" );
		return ("___DELETE_FAILED___") if ( $o eq "E0E" );
		delete( $obj->{'___conn___'} );
	}

	my $idx = $obj->IDX();          # Indexe anpassen

	my $o1 = "conn,text";
	my $o2 = "'$conn',?";
	my @ee = ();
	foreach $o ( split( /,/, $obj->init_idx() ) ) {
		$o1 = $o1 . "," . $o;
		$o2 = $o2 . ",?";
		if ( $obj->{$o} ) {
			push( @ee, $obj->{$o} );
		}
		else {
			push( @ee, '' );
		}
	}

	delete( $self->{'DBH'} );
	$dbh->do( "insert into " . $self->tblstore() . " ($o1) values (" . $o2 . ")",
		{}, Dumper($obj), @ee );

	return ($idx);

}

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

sub change_idx {

	my $self  = shift;
	my $conn  = shift;
	my $idx   = shift;
	my $value = shift;

	my $dbh = $self->dbh();
	$dbh->do( "update " . $self->tblstore() . " set $idx=? where conn='$conn'",
		{}, $value );

}

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

sub fetch {    #  Einen Prozess holen, fuer den ein Request vorliegt

	my $self = shift;
	my $idx  = shift;    #  weitere eingrenzende Suchbedingungen
	my $mode = shift;    #  1 oder l<ock>:   Prozess in der Datenbank sperren
	                     #  2 oder d<elete>: Prozess in der Datenbank loeschen

	my $store = $self->tblstore();
	my $conn  = $self->tblconn();
	my $dbh   = $self->dbh();
	my $VAR1;
	my $cursor = "select $store.* from $store where not text = '.run.'";
	if ($idx) {
		$idx =~ s/IDX\./$store\./gs;
		$VAR1 = time();

#      if ($idx =~ s/MESSAGE/ ( ( $store.conn = $conn.replynr or $store.conn = $conn.conn ) and $conn.msgtime+0 < $VAR1 ) /gs) {
		if ( $idx =~
s/MESSAGE/ ( ( $store.conn = $conn.replynr ) and $conn.msgtime+0 < $VAR1 ) /gs
		  )
		{
			$cursor =
			  "select $store.* from $store,$conn where not $store.text = '.run.'";
		}
		$idx = " and ( " . $idx . " ) ";

		# print "II: $cursor $idx\n";
	}

	$cursor = $dbh->prepare( $cursor . $idx . " limit 1" );
	$cursor->execute();
	my $ee = $cursor->fetchrow_hashref();

	# print Dumper($ee); sleep 5;
	$cursor->finish();
	if ( !$ee ) { return ("___NO_TASK_FOUND___"); }
	eval( $ee->{'text'} );    # print STDERR $@;
	return ( "ERROR (ObjTask, func fetch): " . $@ ) if ($@);

	if ( $mode =~ /^[1l]/i ) {
		$cursor =
		  $dbh->do( "update $store set text='.run.' "
			  . "where conn = '"
			  . $ee->{'conn'}
			  . "'" );
		return ("___UPDATE_FETCH_FAILED___") if ( $cursor eq "0E0" );
		$VAR1->{'___conn___'} = $ee->{'conn'};
	}
	elsif ( $mode =~ /[2d]/i ) {
		$cursor =
		  $dbh->do( "delete from "
			  . $self->tblstore()
			  . " where conn='"
			  . $ee->{'conn'}
			  . "'" );
		return ("___DELETE_FAILED___") if ( $cursor eq "E0E" );
	}
	else {
		$VAR1->{'___conn___'} = $ee->{'conn'};
	}

	$self->load_classes($VAR1);
	foreach $idx ( keys %$ee ) {
		next if ( $idx eq "conn" );
		next if ( $idx eq "text" );

		#      next if ($idx !~ /^$store\.(.*)$/);
		$VAR1->{$idx} = $ee->{$idx};
	}

	#   $VAR1->REVERSE_IDX();
	$self->connection($conn) if ($conn);
	$VAR1->{'PARENT'} = $self;
	return ( $VAR1, $ee->{'conn'} );

}

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

#  Nachladen der benoetigten Klassen nach fetch

sub load_classes {

	my $self = shift;
	my $obj  = shift;

	my $rtype = ref($obj);
	if ( $obj =~ /\=(ARRAY|HASH)/ ) {
		print STDERR "Re-Loaded OBJ: $obj\n" if ($obj);
		eval("use $rtype");
	}
	if ( $obj =~ /ARRAY/ ) {
		foreach $rtype (@$obj) {
			$self->load_classes($rtype);
		}
	}
	elsif ( $obj =~ /HASH/ ) {
		foreach $rtype ( values %$obj ) {
			$self->load_classes($rtype);
		}
	}

	return ($obj);

}

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

sub lock_semaphore {

	my $self = shift;
	my $id   = shift;

	my $dbh = $self->dbh();

	my $cursor = $dbh->prepare(
		"select semalock from " . $self->tblsema() . " where id='$id' limit 1" );
	$cursor->execute();
	my @ee = $cursor->fetchrow();
	$cursor->finish();

	if ( !@ee ) {
		$ee[0] = $dbh->do(
			"insert into "
			  . $self->tblsema()
			  . " (id,text,semalock) values ('$id','',1)",
			{ PrintError => 0 }
		);
		return (1) if ( $ee[0] ne "0E0" );
	}

	$ee[0] = $dbh->do(
		"update "
		  . $self->tblsema()
		  . " set semalock='1' "
		  . "where id like '$id' and semalock='0'",
		{ PrintError => 0 }
	);
	return (0) if ( $ee[0] eq "0E0" );
	return (1);

}

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

sub read_semaphore {

	my $self = shift;
	my $id   = shift;

	my $dbh = $self->dbh();

	my $cursor =
	  $dbh->prepare( "select text from "
		  . $self->tblsema()
		  . " where id='$id' and semalock='1' limit 1" );
	$cursor->execute();
	my @ee = $cursor->fetchrow();
	$cursor->finish();

	if ( !@ee ) {
		return ("___NO_SEMAPHORE_$id\_FOUND___");
	}
	return ( $ee[0] );

}

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

sub write_semaphore {

	my $self = shift;
	my $id   = shift;
	my $text = shift;

	my $dbh = $self->dbh();
	my $o   = $dbh->do(
		"update "
		  . $self->tblsema()
		  . " set text='$text' "
		  . "where id='$id' and semalock='1'",
		{ PrintError => 0 }
	);
	return (0) if ( $o eq "0E0" );
	return (1);

}

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

sub unlock_semaphore {

	my $self = shift;
	my $id   = shift;

	my $dbh = $self->dbh();
	my $o   = $dbh->do(
		"update "
		  . $self->tblsema()
		  . " set semalock='0' "
		  . "where id='$id' and semalock='1'",
		{ PrintError => 0 }
	);
	return (0) if ( $o eq "0E0" );
	return (1);

}

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

sub delete_semaphore {

	my $self = shift;
	my $id   = shift;

	my $dbh = $self->dbh();
	my $o   = $dbh->do( "delete from " . $self->tblsema() . " where id='$id'",
		{ PrintError => 0 } );
	return (0) if ( $o eq "0E0" );
	return (1);

}

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

sub delete_all_semaphores {

	my $self = shift;
	my $id   = shift;

	my $dbh = $self->dbh();
	my $o   = $dbh->do( "delete from " . $self->tblsema() . " where id like '$id\%'",
		{ PrintError => 0 } );
	return (0) if ( $o eq "0E0" );
	return (1);

}

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

1;