package baseq; use DBI; #use strict; $POST="POST"; # GET or POST ?? %VARS=(); # Eingelesene Variablen $SPRACHENR=0; # Nummer der Sprache %SPRACHE={}; # Hash auf die Übersetzungen $PATH = "../www.prorata.de"; # Pfad zum HTML Verzeichnis $UMFIMG = "/umfimg/"; # Verzeichnis für die Statistiken..... my %konf=( "database" => "mysql", # Andere sind z.B. adabas, csv, oracle, informix "dataname" => "prorata2", # Name der Datenbank "datahost" => "192.168.98.222", # Hostname der Datenbank "datauser" => "wwwrun", # Datenbank - Benutzername "datapass" => "softis", # Passwort für die Datenbank "loglevel" => "2", "logfile" => "/tmp/prorata2.log" ); my @fontface=("Helvetica","Tahoma","Arial","Trebuchet"); my %Hcolor=("#999999","Grau", "#dddddd","Hellgrau", "#333333","Dunkelgrau", "#000000","Schwarz", "#ffffff","Weiß", "#ff0000","Rot", "#00ff00","Grün", "#0000ff","Blau", "#ffff00","Gelb" ); my @Lcolor = keys %Hcolor; my %Hsprache=("0" => "Deutsch", "1" => "English", "2" => "Italiano", "3" => "Magyar", ); my %felder = ( id => undef , # Identifikationsnummer name => "" , # Bezeichnungsstring conf => undef , # Konfigurationshash parent => undef, dbh => undef , # Databasehandle vars => undef, # CGI - Variablenzeiger template => 0, # Template warntext => undef, # Überschrift query => undef, RLfontface => \@fontface, RLfontcolor => \@Lcolor, RHfontcolor => \%Hcolor, ); #################################################################### #### Konstuktor der Basisklasse #### Argumente : - #### Returnwert : Referenz auf das neue Basisobjekt #################################################################### sub init { my $that = shift; my $class = ref($that) || $that; my $self = { %felder }; bless $self, $class; $self->{parent} = shift; $self->{id} = shift; $self->{dbh} = $self->{parent}->{dbh}; $self->{sprache} = $self->{parent}->{sprache}+0; $self->{conf}=\%konf; $self->loadsprache($self->{sprache}); return $self; } #################################################################### #### Schreibt Sprüche ins Logfile #### Argumente : EmergencyNR , Text #### Returnwert : #################################################################### sub printlog { my $self= shift; my $emerg=shift; my $TEXT= shift; my $file=$self->{conf}{logfile}; my $loglevel=$self->{conf}{loglevel}; if ($loglevel < $emerg) {return;} my ($sec,$min,$hour,$day,$mon,$year) = (localtime(time))[0,1,2,3,4,5]; $TEXT=sprintf("%2d.%2d %2d:%2d:%2d ",$day,$mon+1,$hour,$min,$sec) .$TEXT; open (FILE, ">>$file") or print "Content-type: text/html\n\nFehler mit der Logdatei"; print FILE "$TEXT\n"; close FILE; if ($emerg==1) {$self->exit("Notausgang !!")} return; } #################################################################### #### Schreibt ins Logfile #### Argumente : Emergency und Logtext #### Returnwert : - #################################################################### sub log { my $self = shift; my $emer = shift; my $TEXT = shift; $self->printlog($emer, "[Baseq] $TEXT"); } #################################################################### #### Verbindet mit der Datenbank und setzt $dbh #### Argumente : - #### Returnwert : - #################################################################### sub dbconn { my $self = shift; my $DB_DSN = "DBI:$self->{conf}{database}:$self->{conf}{dataname}:$self->{conf}{datahost}"; my $DB_USER = "$self->{conf}{datauser}"; my $DB_PASSWD = "$self->{conf}{datapass}"; if ( defined $self->{dbh} ) { return ; } # Wenn Verbindung schon steht..... my $x=1; $self->{dbh} = undef; while ($x<6 && ! defined $self->{dbh}) # ansonsten 4 mal versuchen zu verbinden........ { $self->{dbh} = DBI->connect($DB_DSN, $DB_USER,$DB_PASSWD) || $self->log(1, $DBI::errstr); if (! ref $self->{dbh} ) {sleep(1);} } $self->log(2,"Datenbankverbindung beim $x ten Versuch von $ENV{REMOTE_ADDR}"); } #################################################################### #### Beendet die Datenbankverbindung #### Argumente : - #### Returnwert : - #################################################################### sub dbdisconn { my $self = shift; $self->{dbh}->disconnect; $self->log(2,"Datenbankverbindung wurde getrennt"); } #################################################################### #### Prüft das Passwort #### Argumente : pin und encrypted passwd #### Returnwert : 1 wenn OK , sonst 0 #################################################################### sub checkkunde { my $self = shift; my $knr = shift()+0; my $pass = shift; my $dbpass = $self->sqlselect("select pass from kunden where knr=$knr"); $dbpass=crypt($dbpass,"xy"); if ($dbpass ne $pass) {$self->log(2,"Falsches Passwort von $knr");return 1;} return 0; } #################################################################### #### Führt SQL - Select aus #### Argumente : SQL Statement #### Returnwert : SELECT.. #################################################################### sub sqlselect { my $self = shift; my $SQL = shift; $self->dbconn; $self->log(3, $SQL); return $self->{dbh}->selectrow_array($SQL); } #################################################################### #### Führt SQL - Prepare und execute aus #### Argumente : pin und encrypted passwd #### Returnwert : 1 wenn OK , sonst 0 #################################################################### sub sqlprepare { my $self = shift; my $SQL = shift; $self->dbconn; $self->log(3, $SQL); my $sth=$self->{dbh}->prepare($SQL) || $self->log(2, $self->{dbh}->errstr); $sth->execute || $self->log(2, $self->{sth}->errstr); return $sth; } #################################################################### #### Führt SQL - DO aus #### Argumente : pin und encrypted passwd #### Returnwert : 1 wenn OK , sonst 0 #################################################################### sub sqldo { my $self = shift; my $SQL = shift; $self->dbconn; $self->log(3, $SQL); my $rows=$self->{dbh}->do($SQL) || $self->log(2, $self->{dbh}->errstr); $self->log(3, "Zeilen: $rows"); return $rows; } #################################################################### #### Ersetzt ' durch " #### Argumente : Text #### Returnwert : Text #################################################################### sub rep { my $self = shift; return @_[0]=~s/'/"/g; } #################################################################### #### Gibt eine Liste mit und tags zurück #### Argumente : pin und encrypted passwd #### Returnwert : 1 wenn OK , sonst 0 #################################################################### sub TR { my $self = shift; my $L= shift; return "\n ".join ("\n ", @$L)."\n\n" } #################################################################### #### Gibt eine Liste mit und tags zurück #### Argumente : pin und encrypted passwd #### Returnwert : 1 wenn OK , sonst 0 #################################################################### sub exit { my $self = shift; my $L= shift; if ($L eq "") {$L="Exit...";} $self->log(4,$L); $self->dbdisconn; exit; } #################################################################### #### Gibt die Sprache mit Nummer als Key im Hashref zurück #### Argumente : Text #### Returnwert : - #################################################################### sub sprachenhash { return \%Hsprache;} # my $self = shift; # my ( $umfid, $umfrage, %humf, $sql, $sth ); # $sql="select umfid, umfrage from umfragen where knr=$self->{knr}"; # $sth=$self->sqlprepare($sql); # while(($umfid, $umfrage)=$sth->fetchrow_array){ # $humf{$umfid}=$umfrage; # } # return \%humf; #} #################################################################### #### Lädt die gewünschte Sprache #### Argumente : Text #### Returnwert : - #################################################################### sub loadsprache { my $self = shift; my $sprache = shift; if ($sprache eq "") {$sprache=0;} if ( ($SPRACHENR == $sprache) && ($SPRACHE{BU1} ne "") ) {return;} $SPRACHENR=$sprache; my ( $umfid, $umfrage, $krz, $text, %humf, $sql, $sth ); $sql="select krz,text from sprachen where sprache=$sprache"; $sth=$self->sqlprepare($sql); while(($krz, $text)=$sth->fetchrow_array){ $SPRACHE{$krz}=$text; } return ; } #################################################################### #### Übersetzt in die gew. Sprache #### Argumente : Krz #### Returnwert : - #################################################################### sub trans { my $self = shift; my $krz = shift; return $SPRACHE{$krz}; } #################################################################### #### Formatiert eine Zeit aus der DB #### Argumente : Zeit als Zahl #### Returnwert : Formatierter String #################################################################### sub timestamp { my $self = shift; my $st = shift; if ($st==0) {return "Keine Angabe";} my $jahr=substr($st,0,4); my $mon=substr($st,4,2); my $tag=substr($st,6,2); my $std=substr($st,8,2); my $min=substr($st,10,2); my $sek=substr($st,12,2); return "$tag.$mon.$jahr $std:$min:$sek"; } #################################################################### #### Zeitdauer in tage, stunden, minuten und sekunden #### zweier Zeiten #### Argumente : Krz #### Returnwert : - #################################################################### sub duration { my $self = shift; my ($t, $s, $m, $k); my ($ges, $tag, $std, $min, $sek)=$self->timediff(@_); if ($tag==1){$t="1 Tag";} if ($tag>1){$t="$tag Tage";} if ($std==1){$s="1 Stunde";} if ($std>1){$s="$std Stunden";} if ($min==1){$m="1 Minute";} if ($min>1){$m="$min Minuten";} if ($sek==1){$k="1 Sekunde";} if ($sek>1){$k="$sek Sekunden";} return "$t $s $m $k"; } #################################################################### #### Subtrahiert 2 Zeiten aus der DB #### Argumente : Krz #### Returnwert : Array: (Gessek Tage, Std, Min, Sek) #################################################################### sub timediff { my $self = shift; my $st1 = shift; my $st = shift; my ($t,$s,$m,$k); my (@Z, @Z1); my @m=(0,0,31,59,90,120,151,181,212,243,273,304,334); @Z =$st =~/(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})/; @Z1=$st1=~/(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})/; $Z[2] +=@m[$Z[1]] +365*$Z[0]; $Z1[2]+=@m[$Z1[1]]+365*$Z1[0]; for (my $x=2; $x<6; $x++) { $Z[$x]-=$Z1[$x]; } if ($Z[5]<0){$Z[5]+=60; $Z[4]-=1;} if ($Z[4]<0){$Z[4]+=60; $Z[3]-=1;} if ($Z[3]<0){$Z[3]+=24; $Z[2]-=1;} shift @Z; $Z[0]=$Z[4]+60*$Z[3]+3600*$Z[2]+$Z[1]*86400; return @Z; } #################################################################### #### Liest die Umgebungsvariablen #### Argumente : - #### Returnwert : %Vars #################################################################### sub Vars { my $self=shift; my ($in, $key, $val, $pair, @ins); if ($ENV{'REQUEST_METHOD'} eq "GET") { $in=$ENV{'QUERY_STRING'}; @ins=split(/&/,$in); } elsif ($ENV{'REQUEST_METHOD'} eq "POST"){ read(STDIN, $in, $ENV{'CONTENT_LENGTH'}); #print "POST ".$in."hjj\n"; @ins=split(/&/,$in); } else {@ins=@ARGV; } foreach $pair (@ins) { ($key, $val)=split(/=/,$pair); $val =~ tr/+/ /; $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; #print $key."--".$val."\n"; $VARS{$key}=$val; } return \%VARS; } #################################################################### #### gibt eine DropDownliste zurueck #### Argumente : $name, \@Elemente, $selected, \%Labelhash #### Returnwert : HTMLstring #################################################################### sub DD { my $self=shift; my $name=shift; my $elem=shift; my $sele=shift; my $label=shift; my ($opt, $val, $sel); my $HTML="\n \n"; } #################################################################### #### gibt eine Checkbox zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub CB { my ($self, $name, $val, $ch) = @_; if ($ch > 0) {$ch=" CHECKED";} return ""; } #################################################################### #### gibt einen Radiobutton zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub RB { my ($self, $name, $val, $ch) = @_; if ($ch ne "") {$ch=" CHECKED"} return ""; } #################################################################### #### gibt einen Submitbutton zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub SM { my ($self, $name, $val) = @_; return "trans($val)."\">"; } #################################################################### #### gibt eine Submitbutton - Leiste #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub SMrow { my ($self, $names, $vals) = @_; my ($val,$name, @L); for (my $x=0; $x<@$vals; $x++) { push @L, $self->SM($$names[$x], $$vals[$x]); } return "\n".$self->TR(\@L)."
\n"; } #################################################################### #### gibt eine DropDownliste der Sprachen zurueck #### Argumente : - #### Returnwert : HTMLstring #################################################################### sub DDsprache { my ($self, $name, $sel) = @_; return $self->DD($name,[0,1,2,3],$sel,\%Hsprache); } #################################################################### #### Gibt eine DropDownliste der Umfragen zurück #### Argumente : Text #### Returnwert : - #################################################################### sub DDumfrage { my ($self, $name, $sel) = @_; my ( $umfid, $umfrage, %humf, @lumf, $sql, $sth ); if ($self->{knr} eq "") {$self->{knr}=0;} $sql="select umfid, umfrage from umfragen where knr=$self->{knr} order by umfid"; $sth=$self->sqlprepare($sql); while(($umfid, $umfrage)=$sth->fetchrow_array){ $humf{$umfid}=$umfrage; push @lumf, $umfid; } return $self->DD($name,\@lumf,$sel,\%humf); } #################################################################### #### Gibt die Template DropDownliste zurueck #### Argumente : $name, $val, und 0 = alle, 1 = nur eigene #### Returnwert : HTML string #################################################################### sub DDtemp { my ($self, $name, $val) = @_; my $knr=""; if (shift()==0) {$knr="knr=0 or";} my ( $nr, $beschr, %htemp, @ltemp, $sql, $sth ); if ($self->{knr} eq "") {$self->{knr}=0;} $sql="select nr, beschr from template where $knr knr=$self->{knr}"; $sth=$self->sqlprepare($sql); while(($nr, $beschr)=$sth->fetchrow_array){ $htemp{$nr}=$beschr; push @ltemp, $nr; } return $self->DD($name,\@ltemp,$val,\%htemp); } #################################################################### #### gibt eine Textfield zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub TF { my ($self, $name, $val, $size, $maxsize) = @_; if ($size>0) {$size=" SIZE=\"$size\"";} if ($maxsize>0) {$maxsize=" MAXSIZE=\"$maxsize\"";} return ""; } #################################################################### #### gibt ein Hiddenfield zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub HD { my ($self, $name, $val) = @_; if ($val eq "") {return;} return "\n"; } #################################################################### #### gibt ein Image Tag zurueck #### Argumente : $name, $value #### Returnwert : HTMLstring #################################################################### sub IMG { my ($self, $img) = @_; return "\n"; } #################################################################### #### gibt Ticks ' und allen htmltags außer #### gereinigten String zurueck #### Argumente : Dreckiger String #### Returnwert : Sauberer string #################################################################### sub clean { my $self=shift; my $a=shift; $a=$self->tclean($a); $a=~s/<([^aA\/][^>]*)>/[$1]/g; $a=~s/<(\/[^aA][^>]*)>/[$1]/g; return $a; } #################################################################### #### gibt einen von ticks ' gereinigten String zurueck #### Argumente : Dreckiger String #### Returnwert : Sauberer string #################################################################### sub tclean { my $self=shift; my $a=shift; $a=~s/[´`']/"/g; return $a; } #################################################################### #### gibt einen vollstaendig von HTML-Tags und Anfuehrungstrichen #### gereinigten String zurueck #### Argumente : Dreckiger String #### Returnwert : Sauberer string #################################################################### sub fclean { my $self=shift; my $a=shift; $a=~s//]/g; $a=~s/[´`'"]/\*/g; return $a; } #################################################################### #### Gibt eine Login Maske aus #### Argumente : - #### Returnwert : - #################################################################### sub login { my $self = shift; if ($self->{warntext} eq "") {$self->{warntext}=$self->trans("WA3");} my $HTML = "\n". $self->TR([$self->sfont("PIN"),$self->TF('apin') ]) . $self->TR([$self->sfont($self->trans("HI18")), " " ]) . "
\n

\n". $self->SMrow( ["lbut","lbut"] , ["BU12","BU11"] ); $self->printhtml($self->trans("TI3"), $HTML); } #################################################################### #### Führt einen sicheren Redirect aus #### Argumente : - #### Returnwert : - #################################################################### sub redirect { my $self = shift; my $exu="http://www.prorata.de"; if ($self->{exiturl}=~/^http:\/\/.*/i) {$exu=$self->{exiturl};} print "Status: 302 Moved\nLocation: $exu\n\n"; $self->exit("Redirect to: $exu"); }