<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package baseq;

use DBI;
#use strict;

$POST="POST";         # GET or POST ??
%VARS=();             # Eingelesene (uebergebene) Variablen
$SPRACHENR=0;	      # Nummer der Sprache
%SPRACHE={};	      # Hash auf die Übersetzungen
$PATH = "../www.prorata.de";   # Pfad zum HTML Verzeichnis 	
$UMFIMG = "/prorataweb/umfimg/";  # Verzeichnis für die Statistiken.....
$HELPPATH="../www.prorata.de/prorataweb/help/";
$TEMPLATES="../www.prorata.de/prorataweb/templates/";

$TESTPIN=100;
$TESTPASS="muster";
%TITLE = (HF =&gt; "Geschlecht", BI =&gt; "Bildungsstand", FS =&gt; "Familienstand", BS =&gt; "Besch&amp;auml;ftigungsverh&amp;auml;ltnis",
			 ALT =&gt; "Altersgruppen", PLZ =&gt; "PLZ der Wohnorte", FID =&gt; "Beantwortete Fragen");

@VH=("nie bestellt","Neckermann","Quelle","Otto","Schwab","Bauer","Heine","Chic","bon prix","Oppermann","Bader","Walz","Beate Uhse",
		"Schneider","Hach","Viking","hessnatur","Spezialisierte Versandhäuser","Online Versandhäuser","andere" );

@KRIT=("","Auto","Babyprodukte","Babypflege","Bücher","Dienstleistungen","EDV-Hardware","EDV-Software","Getränke","Haushaltspflegeartikel",
	"Haushaltsgeräte","Haushaltsausstattung","Hygieneartikel","Internet","Kosmetikprodukte","Lebensmittel","Reisen","Sportartikel",
	"Spielwaren","Telekommunikation","Tierartikel","Tierfutter","Tiefkühlkost","Zeitschriften","Zeitungen");

@HOB=("","Aktienhandel","Autos, Motorsport",
	"Ausgehen","Computer,Informationstechnologie","Denk- und Einzelspiele","Fitneß- ,Gesundheitsthemen","Fernsehen, Videofilme",
	"Gäste einladen, Feiern","Gesellschaftsspiele","Ins Kino gehen, Kinofilme","Konzert / Theater /Oper","Kunst / Kultur","Kochen",
	"Lesen, Bücher","Mit Freunden / Bekannten zusammensein","Mit der Familie zusammensein","Mode, Modetrends","Musik hören, CDs,Schaltplatten",
	"Reisen, Urlaub","Sport treiben","Shopping / Einkaufbummel","Natur / Garten","Wirtschaftsthemen","Wissenschaftliche Themen, Forschung","Katzen","Hunde","andere Tiere");
@HF=("","Herr","Frau");
@LA=("","Deutschland","Österreich","Schweiz","Niederlande");
@LK=("","D","A","CH");
@BI=("Keine Angaben","Hauptschulabschluß","Realschulabschluß","Abitur/Fachhochschulreife","Fachhochschulabschluß","Universitätsabschluß","Promotion"); 
@PR=("Keine Angaben","T-Online","AOL","Arcor","Otello","Freenet","Talknet","1 &amp; 1","Netcologne","OWL-Online","Surf Callino","Viag Interkom","Compuserve","Okaynet","Debitel","Nikoma","UU-Net","Germanynet","Uni-Server","FH-Server","Andere");
@FS=("Keine Angaben","Verheiratet","Ledig");
@BS=("Keine Angaben","Vollzeitbeschäftigt","Teilzeitbeschäftigt","Rentner/in","Student/in","Schueler/in","zur Zeit erwerbslos","Hausfrau/-mann");
@BST=("Keine Angaben","Selbständig","Angestellt","Anderes");
@LO=("Keine Angaben","Überweisung","Scheck");
@KT=("","Produkt Kategorien","Hobbys","Versandhäuser");
@BSYS=("Keine Ahnung","Windows 3.1", "Windows 95/98/ME", "Windows NT/2000/XP","BeOS","Mac","OS-2", "Linux","NeXt","Solaris","HP-UX","anderes Unix"); 
@HK=("Keine Angaben", "Durch Bekannte, Verwandte, Freunde", "Zufällig, durch das Surfen im Internet", "Prorata Sonderaktion","Über Hinweise aus Chat-Rooms, best. Seiten im Internet", "Über Bannerwerbung","Auf Empfehlung eines anderen Online-Panelisten");
@MO=("","Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember");

#@ALT=("bis 20 Jahre", "21 bis 25 Jahre", "26 bis 30 Jahre", "31 bis 40 Jahre", "41 bis 50 Jahre", "51 bis 65 Jahre", "über 65 Jahre");

@ALT=("keine Angabe","unter 18", "18 bis 24 Jahre", "25 bis 34 Jahre", "35 bis 54 Jahre", "über 54 Jahre");
@PLZ=("00000-09999", "10000-19999", "20000-29999", "30000-39999", "40000-49999", "50000-59999", "60000-69999", "70000-79999", "80000-89999", "90000-99999");


my %konf=( "database" =&gt; "mysql",	    	# Andere sind z.B. adabas, csv, oracle, informix
           "dataname" =&gt; "prorata2-deleted",    	# Name der Datenbank
           "datahost" =&gt; "sql2.prorata.de", 	        # Hostname der Datenbank
           "datauser" =&gt; "prorata",       	# Datenbank - Benutzername
           "datapass" =&gt; "altoids7",	      	# Passwort für die Datenbank
           "loglevel" =&gt; "3",
           "logfile"  =&gt; "/tmp/prorata2.log" );


my @fontface=("News Gothic","Helvetica","Tahoma","Arial","Trebuchet");

my %Hcolor=("#006666","Türkisdunkel",
		"#99cccc","Türkishell",
		"#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" =&gt; "Deutsch",
	      "1" =&gt; "English",
	      "2" =&gt; "Italiano",
	      "3" =&gt; "Magyar"	 );

my %felder = (
	id =&gt; undef ,            # Identifikationsnummer
	name =&gt; "" ,             # Bezeichnungsstring
	conf =&gt; undef ,          # Konfigurationshash
	parent =&gt; undef,         # Vaterobjekt
	dbh  =&gt; undef ,          # Databasehandle
    vars =&gt; undef,           # CGI - Variablenzeiger
	template =&gt; 0,		 # Template
	warntext =&gt; undef,	 # Überschrift
	query	=&gt; undef,
    RLfontface =&gt; \@fontface,    # Zeiger auf die Fontfaces	
    RLfontcolor =&gt; \@Lcolor,     # Liste der Fontfarben
	RHfontcolor =&gt; \%Hcolor,     # Hash mit den Farbenbezeichnungen
                                  # werden ueberladen aus der Farbtabelle
);

####################################################################
####         Konstuktor der Basisklasse
####         Argumente  : parent und id
####         Returnwert : Referenz auf das neue Basisobjekt
####################################################################
sub init {
	my $that = shift;
	my $class = ref($that) || $that;
	my $self = { %felder };
	bless $self, $class;
	$self-&gt;{parent}   = shift;
    $self-&gt;{id}	  = shift;
	if ($self-&gt;{id} eq "") {$self-&gt;{id}=0;}
	$self-&gt;{dbh}      = $self-&gt;{parent}-&gt;{dbh};
	$self-&gt;{sprache}  = $self-&gt;{parent}-&gt;{sprache}+0;
	$self-&gt;{conf}=\%konf;
    $self-&gt;loadsprache($self-&gt;{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-&gt;{conf}{logfile};
	my $loglevel=$self-&gt;{conf}{loglevel};
	if ($loglevel &lt; $emerg) {return;} # Wenn der oben eingestellte Loglevel niedriger ist...
	
        my ($sec,$min,$hour,$day,$mon,$year) = (localtime(time))[0,1,2,3,4,5];      # Datum und Zeit holen
        $TEXT=sprintf("%2d.%2d %2d:%2d:%2d ",$day,$mon+1,$hour,$min,$sec) .$TEXT;   # Datum formatieren
	open (FILE, "&gt;&gt;$file") or print "Content-type: text/plain\n\nFehler mit der Logdatei";
	print FILE "$TEXT\n";
        close FILE;
        if ($emerg==1) {$self-&gt;exit("Notausgang !!")}
	return;
}

####################################################################
####         Schreibt ins Logfile
####         Argumente  : Emergency und Logtext
####         Returnwert : -
####################################################################
sub log {
	my $self = shift;
        my $emer = shift;
	my $TEXT = shift;
	$self-&gt;printlog($emer, "[Baseq] $TEXT");
}

####################################################################
####         Verbindet mit der Datenbank und setzt $dbh
####         Argumente  : -
####         Returnwert : -
####################################################################
sub dbconn {
    my $self = shift;
    my $DB_DSN      = "DBI:$self-&gt;{conf}{database}:$self-&gt;{conf}{dataname}:$self-&gt;{conf}{datahost}";
    my $DB_USER     = "$self-&gt;{conf}{datauser}";
    my $DB_PASSWD   = "$self-&gt;{conf}{datapass}";
    if ( defined $self-&gt;{dbh} ) { return ; }  # Wenn Verbindung schon steht.....
    my $x=1; $self-&gt;{dbh} = undef;
    while ($x&lt;6 &amp;&amp; ! defined $self-&gt;{dbh})  # ansonsten 4 mal versuchen zu verbinden........
	{
	  $self-&gt;{dbh} = DBI-&gt;connect($DB_DSN, $DB_USER,$DB_PASSWD) || $self-&gt;log(1, $DBI::errstr);
      if (! ref $self-&gt;{dbh} )  {sleep(1);}    # Warten.....
    }
    $self-&gt;log(2,"Datenbankverbindung beim $x ten Versuch von $ENV{REMOTE_ADDR}");
    return;	
}


####################################################################
####         Beendet die Datenbankverbindung
####         Argumente  : -
####         Returnwert : -
####################################################################
sub dbdisconn {
	my $self = shift;
	$self-&gt;{dbh}-&gt;disconnect; 
        $self-&gt;log(2,"Datenbankverbindung wurde getrennt von $ENV{REMOTE_ADDR}");
        return;
}

####################################################################
####         Führt SQL - Select aus
####         Argumente  : SQL Statement
####         Returnwert : SELECT..
####################################################################
sub sqlselect {
	my $self = shift;
	my $SQL = shift;
        $self-&gt;dbconn;
        $self-&gt;log(3, $SQL);
	return $self-&gt;{dbh}-&gt;selectrow_array($SQL);
}

####################################################################
####         Führt SQL - Prepare und execute aus
####         Argumente  : SQL Statement
####         Returnwert : Handle
####################################################################
sub sqlprepare {
	my $self = shift;
	my $SQL = shift;
        $self-&gt;dbconn;
        $self-&gt;log(3, $SQL);
	my $sth=$self-&gt;{dbh}-&gt;prepare($SQL) || $self-&gt;log(2, "DBH-Error: ".$self-&gt;{dbh}-&gt;errstr);
	if (! ref $sth) {$self-&gt;log(1, "Kein STH - Handle bekommen; SQL war: $SQL");}
	$sth-&gt;execute || $self-&gt;log(2, "STH-Error: ".$sth-&gt;errstr);
        return $sth;
}


####################################################################
####         Führt SQL - DO aus
####         Argumente  : SQL Statement
####         Returnwert : Anzahl der betroffenen Zeilen
####################################################################
sub sqldo {
	my $self = shift;
	my $SQL = shift;
        $self-&gt;dbconn;
        $self-&gt;log(3, $SQL);
	my $rows=$self-&gt;{dbh}-&gt;do($SQL) || $self-&gt;log(2, "DBH-Error: ".$self-&gt;{dbh}-&gt;errstr);
	$self-&gt;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 &lt;TD&gt; und &lt;TR&gt; tags zurück
####         Argumente  : Zeiger auf Liste der Zellenstrings, Standard TD-inhalt, Zeiger auf  TD-inhalte 
####         Returnwert : HTML STRING der Zeile
####################################################################
sub TR {
	my ( $self , $L , $L2, $L1 ) = @_;
	if (! defined $L1) {$L1=[];}
	my @LI=@$L;
	if ($L2 ne "") {$L2=" ".$L2}
	for ($x=0; $x&lt;=$#LI; $x++) { $LI[$x]=$$L1[$x].$L2."&gt;".$LI[$x]; }
	return "&lt;TR&gt;\n   &lt;TD ".join ("&lt;/TD&gt;\n   &lt;TD", @LI)."&lt;/TD&gt;\n&lt;/TR&gt;\n";
}


####################################################################
####         Verlässt das Programm mit Verabschiedung...
####         Argumente  : Abschiedsbrief :-)
####         Returnwert : -
####################################################################
sub exit {
	my $self = shift;
	my $L= shift;
	if ($L eq "") {$L="Exit...";}
	$self-&gt;log(4,$L);
	$self-&gt;dbdisconn;
	exit;
}

####################################################################
####         Lädt die gewünschte Sprache und setzt die globalen
####         Variablen  $SPRACHENR und $SPRACHE
####         Argumente  : Sprachen nummer
####         Returnwert : -
####################################################################
sub loadsprache {
        my $self = shift;
        my $sprache = shift;
        if ($sprache eq "") {$sprache=0;}            # Defaultsprache
        # Wenn diese Sprache bereits aktiv und geladenb ist gibt es nichts zu tun !
	if ( ($SPRACHENR == $sprache) &amp;&amp; ($SPRACHE{BU1} ne "") ) {return;}
	$SPRACHENR=$sprache;
	$self-&gt;log(4,"Baseq:Loading Sprache $sprache");
	my ( $umfid, $umfrage, $krz, $text, %humf, $sql, $sth );
        $sql="select krz,text from sprachen where sprache=$sprache";
        $sth=$self-&gt;sqlprepare($sql);
        while(($krz, $text)=$sth-&gt;fetchrow_array){
           $SPRACHE{$krz}=$text;
        }
        return ;
}

####################################################################
####         Übersetzt in die gew. Sprache
####         Argumente  : Krz
####         Returnwert : Text zum Kuerzel...
####################################################################
sub trans {
        my $self = shift;
        my $krz = shift;
        return $SPRACHE{$krz};
}

####################################################################
####         Formatiert einen Timestamp aus der DB
####         Argumente  : Zeit als Zahl  (20001125130657)
####         Returnwert : Formatierter String (25.11.2000 13:06:57)
####################################################################
sub timestamp {
        my $self = shift;
        my $st = shift;
	$self-&gt;log(4,"Entering: Baseq:Timestamp");
	if ($st==0) {return "Keine Angabe";}    # Wenn der Timestamp leer ist.....
        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  : Timestamp1 , Timestamp2
####         Returnwert : Zeidifferenz (5 Tage 4 Stunden 10 Minuten 1 Sekunde)
####################################################################
sub duration {
        my $self = shift;
	my ($t, $s, $m, $k);
	my ($ges, $tag, $std, $min, $sek)=$self-&gt;timediff(@_);
	$self-&gt;log(4,"Entering: Baseq:duration");
	if ($tag==1){$t="1 Tag";}
	if ($tag&gt;1){$t="$tag Tage";}
	if ($std==1){$s="1 Stunde";}
	if ($std&gt;1){$s="$std Stunden";}
	if ($min==1){$m="1 Minute";} 
	if ($min&gt;1){$m="$min Minuten";} 
	if ($sek==1){$k="1 Sekunde";} 
	if ($sek&gt;1){$k="$sek Sekunden";} 
   	return "$t $s $m $k";
	
}

####################################################################
####         Subtrahiert 2 Timestamps aus der DB
####         Argumente  : Stamp1 und Stamp2
####         Returnwert : Array: (Gesamtsek, 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);  # Tage bis zum 1. diesen Monats
	$self-&gt;log(4,"Entering: Baseq:Timediff");
	@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];  # Monate und Jahre zu den Tagen addieren
	$Z1[2]+=@m[$Z1[1]]+365*$Z1[0];
	for (my $x=2; $x&lt;6; $x++) { $Z[$x]-=$Z1[$x]; }    # Subtrahieren
	if ($Z[5]&lt;0){$Z[5]+=60; $Z[4]-=1;}
	if ($Z[4]&lt;0){$Z[4]+=60; $Z[3]-=1;}     # Uebertraege
	if ($Z[3]&lt;0){$Z[3]+=24; $Z[2]-=1;}
	shift @Z; 
	$Z[0]=$Z[4]+60*$Z[3]+3600*$Z[2]+$Z[1]*86400;   # Sekunden berechnen
	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") {                  # Per GET Methode
       $in=$ENV{'QUERY_STRING'};
       @ins=split(/&amp;/,$in);
  }
  elsif ($ENV{'REQUEST_METHOD'} eq "POST"){               # Per POST uebergebene
       read(STDIN, $in, $ENV{'CONTENT_LENGTH'});
       @ins=split(/&amp;/,$in);
  }
  else {@ins=@ARGV; }					  # Von der Kommandozeile uebergebene

  foreach $pair (@ins) {				  # Vorverarbeitung
	($key, $val)=split(/=/,$pair);
	$val =~ tr/+/ /;                                  # Aufspaltung in KEY und VALUE
	$val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;   #Sonderzeichen aufdroeseln
	$val =~s/^ +//;
    $val =~s/ +$//;
	$VARS{$key}=$val;
  }
  return \%VARS;
}

####################################################################
####         Gibt eine DropDownliste zurueck
####         Argumente  : $name, \@Elemente, $selected, \%Labelhash
####         Returnwert : HTMLstring
####################################################################
sub DD {
  my ($self, $name, $elem, $sele, $label)=@_;
  my ($opt, $val, $sel);
  my @eleme=@$elem;
  my $HTML="\n &lt;SELECT NAME=\"$name\"&gt;\n";	
  $self-&gt;log(4,"Entering: Baseq:DD Name=$name");
  foreach $opt (@eleme) {
	$val=""; $sel="";
	if ($sele eq $opt) {$sel=" SELECTED";}
	if ($$label{$opt} ne "") {$val=" VALUE=\"$opt\""; $opt=$$label{$opt};}
	$HTML.="    &lt;OPTION$sel$val&gt;$opt\n";
  }
  return $HTML." &lt;/SELECT&gt;\n";	
}

####################################################################
####         gibt eine Checkbox zurueck
####         Argumente  : $name, $value, Zahl &gt; 0 wenn checked
####         Returnwert : HTMLstring
####################################################################
sub CB {
  my ($self, $name, $val, $ch) = @_;
  if ($ch &gt; 0) {$ch=" CHECKED";}	
  $self-&gt;log(4,"Entering: Baseq:CB N=$name V=$val CH=$ch" );
  return "&lt;INPUT TYPE=\"checkbox\"$ch NAME=\"$name\" VALUE=\"$val\"&gt;";
}

####################################################################
####         gibt einen Radiobutton zurueck
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub RB {
  my ($self, $name, $val, $ch) = @_;
  $self-&gt;log(4,"Entering: Baseq:RB N=$name V=$val");
  if ($ch ne "") {$ch=" CHECKED"}	
  return "&lt;INPUT TYPE=\"radio\"$ch NAME=\"$name\" VALUE=\"$val\"&gt;";
}

####################################################################
####         gibt einen Submitbutton zurueck
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub SM {
  my ($self, $name, $val, $width) = @_;
  my ($li,$re);
  my $value=$self-&gt;trans($val);
  my $type="SUBMIT";	
  if ($val eq "BU38") {$type="RESET";}
  if ($width&lt;1) {$width=$self-&gt;{buttonwidth};}
  $self-&gt;log(4,"Entering: Baseq:SM N=$name V=$val");
  $width -= length($value);
  if ($width&gt;0) {
     $li=$re=$width&gt;&gt;1;$re+=$width%2;
     $self-&gt;log(4,"Überbreite=$width, Links=$li, Rechts=$re");
     $value=(" " x $li) .$value.( " " x $re); 
  }
  return "&lt;INPUT TYPE=\"$type\" NAME=\"$name\" VALUE=\"$value\" style=\"font-family: Fixedsys\"&gt;";
}

####################################################################
####         gibt eine Submitbutton - Leiste
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub SMrow {
  my ($self, $names, $vals) = @_;
  my ($val,$name, @L);
  $self-&gt;log(4,"Entering: Baseq:SMrow N=$name V=$val");
  for (my $x=0; $x&lt;@$vals; $x++) {
    push @L, $self-&gt;SM($$names[$x], $$vals[$x]);
  }
  return "&lt;TABLE cellspacing=10&gt;\n".$self-&gt;TR(\@L)."&lt;/TABLE&gt;\n";
}

####################################################################
####         gibt eine DropDownliste der Sprachen zurueck
####         Argumente  : -
####         Returnwert : HTMLstring
####################################################################
sub DDsprache {
  my ($self, $name, $sel) = @_;
  $self-&gt;log(4,"Entering: Baseq:DDsprache N=$name");
  return $self-&gt;DD($name,[0,1,2,3],$sel,\%Hsprache);
}

####################################################################
####         Gibt eine DropDownliste der Umfragen zurück
####         Argumente  : Text
####         Returnwert : -
####################################################################
sub DDumfrage {
    my ($self, $name, $sel, $status) = @_;
    my ( $umfid, $umfrage, %humf, @lumf, $sql, $sth );
	$self-&gt;log(4,"Entering: Baseq:DDumfrage");
	$status+=0;
	if ($self-&gt;{knr} eq "") {$self-&gt;{knr}=0;}
    $sql="select umfid, umfrage from umfragen where knr=$self-&gt;{knr} and status='$status' order by umfid";
    $sth=$self-&gt;sqlprepare($sql);
    while(($umfid, $umfrage)=$sth-&gt;fetchrow_array){
           $humf{$umfid}=$umfrage;
           push @lumf, $umfid;
    }
    return $self-&gt;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="";
	$self-&gt;log(4,"Entering: Baseq:DDtemp N=$name V=$val");
	if (shift()==0) {$knr="knr=0 or";}
	my ( $nr, $beschr, %htemp, @ltemp, $sql, $sth );
	if ($self-&gt;{knr} eq "") {$self-&gt;{knr}=0;}
        $sql="select nr, beschr from templatehtm where $knr knr=$self-&gt;{knr}";
        $sth=$self-&gt;sqlprepare($sql);
        while(($nr, $beschr)=$sth-&gt;fetchrow_array){
           $htemp{$nr}=$beschr;
           push @ltemp, $nr;
	}
        return $self-&gt;DD($name,\@ltemp,$val,\%htemp);
}


####################################################################
####         gibt eine Textfield zurueck
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub TF {
  my ($self, $name, $val, $size, $maxsize) = @_;
  $self-&gt;log(4,"Entering: Baseq:TF N=$name V=$val");
  if ($size&gt;0) {$size=" SIZE=\"$size\"";}
  if ($maxsize&gt;0) {$maxsize=" MAXSIZE=\"$maxsize\"";}	
  return "&lt;INPUT TYPE=\"text\" NAME=\"$name\" VALUE='$val'$size$maxsize&gt;";
}

####################################################################
####         gibt ein Hiddenfield zurueck
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub HD {
  my ($self, $name, $val) = @_;
  $self-&gt;log(4,"Entering: Baseq:HD N=$name V=$val");
  if ($val eq "") {return;}
  return "&lt;INPUT TYPE=\"hidden\" NAME=\"$name\" VALUE='$val'&gt;\n";
}

####################################################################
####         gibt ein A HREF zurueck
####         Argumente  : $name, $value
####         Returnwert : HTMLstring
####################################################################
sub AH {
  my ($self, $link, $name) = @_;
  $self-&gt;log(4,"Entering: Baseq:AH Link=$link");
  return "&lt;A HREF=\"$link\"&gt;$name&lt;/A&gt;\n";
}

####################################################################
####         gibt ein Image Tag zurueck
####         Argumente  : $img
####         Returnwert : HTMLstring
####################################################################
sub IMG {
  my ($self, $img) = @_;
  $self-&gt;log(4,"Entering: Baseq:IMG Bild=$img");
  return "&lt;IMG SRC=\"$img\" BORDER=0&gt;\n";
}

####################################################################
####         gibt ein Image Tag als &lt;submit&gt; zurueck
####         Argumente  : $img $name, $value
####         Returnwert : HTMLstring
####################################################################
sub IMGsubmit {
  my ($self, $img,$name) = @_;
  $self-&gt;log(4,"Entering: Baseq:IMG Bild=$img");
  return "&lt;INPUT TYPE=\"IMAGE\" SRC=\"$img\" BORDER=0 NAME=\"$name\"&gt;\n";
}

####################################################################
####         Gibt die locale Zeit aus
####         Argumente  :
####         Returnwert : -
####################################################################

sub getdate {

    @days   = ('Sonntag','Montag','Dienstag','Mittwoch',
               'Donnerstag','Freitag','Samstag');
    @months = ('Januar','Februar','März','April','Mai','Juni','Juli',
	         'August','September','Oktober','November','Dezember');

    ($sec,$min,$hour,$mday,$mon,$year,$wday) = (localtime(time))[0,1,2,3,4,5,6];
    $time = sprintf("%02d:%02d:%02d",$hour,$min,$sec);
    $year += 1900;
                                                   
    $date = "$days[$wday], $months[$mon] $mday, $year um $time";
	return $date;
}

####################################################################
####         gibt ein Datumseingabefeld (Tag, Monat, Jahr) zurück
####         Argumente  : Bezeichnung , 1999-09-23
####         Returnwert : HTMLstring
####################################################################
sub Datehtml {
  my ($self, $nr, $date) = @_;
  $self-&gt;log(4,"Entering: Baseq:Datehtml Nr=$nr, Date=$date");
  my ($j,$m,$t) = split /-/ , $self-&gt;{gdat};
  return $self-&gt;TF("bqtag".$nr,$t+0,2,2).$self-&gt;DDmonat("bqmonat".$nr,$m+0).
		 $self-&gt;TF("bqjahr".$nr,$j+0,4,4);
}

####################################################################
####         gibt ein Datumseingabefeld (1999-09-23) zurück
####         Argumente  : Bezeichnung 
####         Returnwert : 1999-09-23
####################################################################
sub getDatehtml {
  my ($self, $nr, $date) = @_;
  if(($VARS{"bqjahr".$nr}+0)&lt;100){$VARS{"bqjahr".$nr}+=1900;}
  my $date=$VARS{"bqjahr".$nr}."-".($VARS{"bqmonat".$nr}+0)."-".($VARS{"bqtag".$nr}+0);
  $self-&gt;log(4,"Entering: Baseq:getDatehtml Nr=$nr, Date=$date");
  return $date;
}

####################################################################
####         gibt Ticks ' und allen htmltags außer &lt;A HREF...&gt;
####         gereinigten String zurueck
####         Argumente  : Dreckiger String
####         Returnwert : Sauberer string
####################################################################
sub clean {
  my $self=shift;
  my $a=shift;
  $a=$self-&gt;tclean($a);
  $a=~s/&lt;([^aAbB\/][^rR&gt;]*)&gt;/[$1]/g;
  $a=~s/&lt;(\/[^aAbB][^&gt;]*)&gt;/[$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/&lt;/[/g;
  $a=~s/&gt;/]/g;
  $a=~s/[´`'"]/\*/g;
  return $a;
}

####################################################################
####         Gibt eine Login Maske aus
####         Argumente  : -
####         Returnwert : -
####################################################################
sub login {
   my $self = shift;
   $self-&gt;{buttonwidth}=9;
   $self-&gt;log(4,"Entering: Baseq:login");
   if ($self-&gt;{warntext} eq "") {$self-&gt;{warntext}=$self-&gt;trans("WA3");}
	my $HTML = "&lt;TABLE&gt;\n".
	        $self-&gt;TR([$self-&gt;sfont("PIN"),$self-&gt;TF('apin') ]) .
		$self-&gt;TR([$self-&gt;sfont($self-&gt;trans("HI18")), " &lt;INPUT TYPE='password' NAME='apass'&gt;" ]) .
		"&lt;/TABLE&gt;\n&lt;BR&gt;&lt;BR&gt;\n".
	    	$self-&gt;SMrow( ["lbut","lbut"] , ["BU12","BU11"] );

	$self-&gt;printhtml($self-&gt;trans("TI3"), $HTML);
}

####################################################################
####         Führt einen sicheren Redirect aus
####         Argumente  : -
####         Returnwert : -
####################################################################
sub redirect {
	my $self = shift;
    my $xexu=shift;
	my $exu="http://www.prorata.de";
	$self-&gt;log(4,"Entering: Baseq:redirect");
    if ($self-&gt;{exiturl}=~/^http:\/\/.+/i) {$exu=$self-&gt;{exiturl};}
    if ($xexu=~/^http:\/\/.+/i) {$exu=$xexu;}
	print "Status: 302 Moved\nLocation: $exu\n\n";
    $self-&gt;exit('Redirect to: $exu target=top');
}


####################################################################
####         Prüft das Passwort
####         Argumente  : pin und encrypted passwd
####         Returnwert : 0=OK, 1=Pass falsch,
####         2=userpass ok, aber nicht in umfidpin, 3=Statistik ok,
####	     4=Kunde ok		
####################################################################
sub checkpass {
	my $self = shift;
	my $pin = shift;
	my $pass = shift;
	$self-&gt;log(4,"Entering: Baseq:checkpass");
       	if ($pin eq "") {return 1;}
	
	# Statistikanmeldung
	if (($self-&gt;{uname} eq $pin) &amp;&amp; (crypt($self-&gt;{upass},"xy")) eq $pass){return 3;}
	$pin+=0;
	$self-&gt;log(4,"Testpin=$TESTPIN, Passwort=$pass");

	# Musteranmeldung
	if ( ($pin == $TESTPIN) &amp;&amp; ( $pass eq crypt($TESTPASS,"xy") ) ) {$self-&gt;log(4,"Musteranmeldung"); return 0;}

	# Benutzeranmeldung
	my $dbpass = $self-&gt;sqlselect("select pass from benutzer where pin=$pin");
   	$dbpass=crypt($dbpass,"xy");
        if ($dbpass ne $pass) {$self-&gt;log(2,"Falsches Benutzerpasswort von $pin");}
        else {
	  # Umfidpin ?
	  my $teil = $self-&gt;sqlselect("select pin from umfidpin where umfid=$self-&gt;{id} and pin=$pin");
          if ($teil&lt;1) {$self-&gt;log(2,"$pin war nicht in Umfidpin");return 2;}
          else {return 0;}
	}

	my $dbpass = $self-&gt;sqlselect("select pass from kunden where knr=$pin");
   	$dbpass=crypt($dbpass,"xy");
        if ($dbpass ne $pass) {$self-&gt;log(2,"Falsches Kundenpasswort von $pin");}
	else {return 4;}
	
	return 1;
}
</pre></body></html>