| Current Path : /var/www/web-klick.de/dsh/90_akt/DEV1303/DivBasicF/ |
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/90_akt/DEV1303/DivBasicF/ObjTask.pm |
package DivBasicF::ObjTask;
use strict;
use DBD::SQLite;
use Time::HiRes;
use Data::Dumper;
#******************************************************************
# Dieses Modul ermoeglicht einen Datenaustausch von Messages in
# Form von gedumpten Perl-Objekten ueber eine Datenbank.
#
# Benoetigte Environment-Variablen:
#
# 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 Methoe 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 sicht,
# 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 wieteren 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});
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;