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

use template;
use antwort;
use grafikm;
#use strict;

@ISA = qw ( template );


####################################################################
####         Konstruktor der Fragenklasse
####         Argumente  : parent, umfid, Fragentext, Fragentyp
####         Returnwert : -
####################################################################
sub init {
	my $that = shift;
	my $class = ref($that) || $that;
	my $self = template-&gt;init(@_);
    if (! defined $self-&gt;{parent}) { $self-&gt;log(1,"Frage bitte mit parent initialisieren");}
	my @V=qw/umfid id name typ bild nextfid grafik incent gschmuck sort minant maxant showstat qtface qtsize qtcolor atface atsize atcolor/;
	bless $self, $class;	
	$self-&gt;{umfid}    = $self-&gt;{parent}-&gt;{id};
    $self-&gt;{name}     = "";
	$self-&gt;{typ}      = "E";
	$self-&gt;{bild}     = "";	
	$self-&gt;{ant}      = [];
	$self-&gt;{nextfid}  = 0;
	$self-&gt;{template} = $self-&gt;{parent}-&gt;{template};
    $self-&gt;{grafik}   ="BAS";
	$self-&gt;{incent}	  = 1;
	$self-&gt;{gschmuck} = 1;  # 3D grafiken
	$self-&gt;{sort}	  = 0;  #Sortierung ( 0=nach Antwortnummer )
	$self-&gt;loadtmp();
	$self-&gt;{minant}=0;
	$self-&gt;{maxant}=0;
	$self-&gt;{showstat}=1;
	$self-&gt;{stfcace}=$self-&gt;{parent}-&gt;{stface};
	$self-&gt;{stsize}=$self-&gt;{parent}-&gt;{stsize};
	$self-&gt;{stcolor}=$self-&gt;{parent}-&gt;{stcolor};
	$self-&gt;{exportvars}=\@V;
	$self-&gt;{ordernum}="neu";
	return $self;
}

####################################################################
####         Konstruktor der Fragenklasse
####         Argumente  : parent, umfid, fid
####         Returnwert : -
####################################################################
sub load {
	my $self = shift;
    $self-&gt;log(4,"Entering: frage:load");
	my $sql = "select typ,frage,nextfid,bild,qtface,qtsize,qtcolor,atface,atsize,atcolor,grafik,incent,gschmuck,sort,minant,maxant,showstat,ordernum ".
		      " from fragen where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id} ";
	($self-&gt;{typ}, $self-&gt;{name}, $self-&gt;{nextfid}, $self-&gt;{bild}, $self-&gt;{qtface}, $self-&gt;{qtsize}, $self-&gt;{qtcolor},
	 $self-&gt;{atface}, $self-&gt;{atsize}, $self-&gt;{atcolor}, $self-&gt;{grafik}, $self-&gt;{incent}, $self-&gt;{gschmuck},
	 $self-&gt;{sort},$self-&gt;{minant},$self-&gt;{maxant},$self-&gt;{showstat},$self-&gt;{ordernum}) = $self-&gt;sqlselect($sql);
	if (! defined $self-&gt;{nextfid}) {return;}
	if ($self-&gt;{ordernum} eq "") {$self-&gt;{ordernum}=$self-&gt;{id} }	
	$self-&gt;loadantw;
	$self-&gt;{grafik}=substr($self-&gt;{grafik},0,2);
	return $self;
}

####################################################################
####         Saug die Eigenschaften von woanders
####         Argumente  : array der Eigenschaften
####         Returnwert : -
####################################################################
sub getpreloaded {
	my $self = shift;
	($self-&gt;{umfid}, $self-&gt;{id}, $self-&gt;{name}, $self-&gt;{typ}, $self-&gt;{bild}, $self-&gt;{nextfid}, 
	 $self-&gt;{qtface}, $self-&gt;{qtsize}, $self-&gt;{qtcolor}, $self-&gt;{atface}, $self-&gt;{atsize}, $self-&gt;{atcolor}, 
	 $self-&gt;{grafik}, $self-&gt;{incent}, $self-&gt;{gschmuck}, $self-&gt;{sort}, $self-&gt;{minant}, $self-&gt;{maxant}, $self-&gt;{showstat}, $self-&gt;{ordernum} ) = @_;
	if ($self-&gt;{ordernum} eq "") {$self-&gt;{ordernum}=$self-&gt;{id} }	
	$self-&gt;loadantw;
}

####################################################################
####         Antworten zur Frage laden und in $self-&gt;{ant} speichern
####         Argumente  : umfid, fid
####         Returnwert : -
####################################################################
sub loadantw {
	my $self = shift;
    $self-&gt;log(4,"Entering: frage:loadantw");
	my (@y, $x);
	my $sql = "select * from antworten where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id}";
	my $sth = $self-&gt;sqlprepare($sql);
	$self-&gt;{ant}=\@y;
	while (my @ant = $sth-&gt;fetchrow_array) {
	   my $a = antwort-&gt;init($self,1); 
	   $a-&gt;getpreloaded(@ant);
	   push @y, $a;  #existierende Fragen ins Array packen
	}
	return;
}

####################################################################
####         Ermittelt eine neue fid und speichert sich
####         Argumente  : -
####         Returnwert : -
####################################################################
sub new {
	my $self = shift;
	my $sql1 = "select max(fid) from fragen where umfid=$self-&gt;{umfid} ";
	my $a;
	$self-&gt;log(4,"Entering: frage:new");
	$self-&gt;sqldo("lock table fragen write");
	$self-&gt;{id} = ($self-&gt;sqlselect($sql1))+1;
	while ($self-&gt;sqldo("select fid from fragen where umfid='$self-&gt;{umfid}' and ordernum='$self-&gt;{ordernum}' and fid!='$self-&gt;{id}'") &gt; 0) {
		$self-&gt;{ordernum}.="x";
	}
	my $sql2 = "insert into fragen set umfid=$self-&gt;{umfid}, fid=$self-&gt;{id}, frage='$self-&gt;{name}', ".
		   "typ='$self-&gt;{typ}', bild='$self-&gt;{bild}', nextfid='$self-&gt;{nextfid}', ".
		   "qtface='$self-&gt;{qtface}', qtsize='$self-&gt;{qtsize}', qtcolor='$self-&gt;{qtcolor}', ".
		   "atface='$self-&gt;{atface}', atsize='$self-&gt;{atsize}', atcolor='$self-&gt;{atcolor}', ".
		   "grafik='$self-&gt;{grafik}', incent='$self-&gt;{incent}', gschmuck='$self-&gt;{gschmuck}', ".
		   "sort='$self-&gt;{sort}', minant='$self-&gt;{minant}', maxant='$self-&gt;{maxant}', ".
		   "showstat='$self-&gt;{showstat}', ordernum='$self-&gt;{ordernum}' ";
	$self-&gt;sqldo($sql2);
	$self-&gt;sqldo("unlock tables");
	foreach $a (@{$self-&gt;{ant}}) {$a-&gt;{umfid}=$self-&gt;{umfid}; $a-&gt;{fid}=$self-&gt;{id}; $a-&gt;new;}
}

####################################################################
####         Speichert sich mit Update
####         Argumente  : evtl Fragentext und Fragentyp
####         Returnwert : -
####################################################################
sub store {
	my $self = shift;
        $self-&gt;log(4,"Entering: frage:store");
	if (@_[0]) { $self-&gt;{name} = @_[0]; }
	if (@_[1]) { $self-&gt;{typ} = @_[1]; }
	while ($self-&gt;sqldo("select fid from fragen where umfid='$self-&gt;{umfid}' and ordernum='$self-&gt;{ordernum}' and fid!='$self-&gt;{id}'") &gt; 0) {
		$self-&gt;{ordernum}.="x";
	}
	my $sql = "update fragen set frage='$self-&gt;{name}', typ='$self-&gt;{typ}', nextfid='$self-&gt;{nextfid}', bild='$self-&gt;{bild}', ".
		  "qtface='$self-&gt;{qtface}', qtsize='$self-&gt;{qtsize}', ".
		  "qtcolor='$self-&gt;{qtcolor}', atface='$self-&gt;{atface}', atsize='$self-&gt;{atsize}', atcolor='$self-&gt;{atcolor}', ".
		  "grafik='$self-&gt;{grafik}', incent='$self-&gt;{incent}', gschmuck='$self-&gt;{gschmuck}', ".
 		  "sort='$self-&gt;{sort}', minant='$self-&gt;{minant}', maxant='$self-&gt;{maxant}', showstat='$self-&gt;{showstat}', ordernum='$self-&gt;{ordernum}' ".
		  "where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id}";
	$self-&gt;sqldo($sql);
	my $a; 
	foreach $a ( @{$self-&gt;{ant}} ) {$a-&gt;store}
}

####################################################################
####         Löscht sich und alle seine Antworten der Probanden
####	     aus der DB
####         Argumente  : -
####         Returnwert : -
####################################################################
sub delete {
	my $self = shift;
        $self-&gt;log(4,"Entering: frage:delete");
	my $sql  = "delete from fragen where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id} ";
        my $sql1 = "update fragen set nextfid=$self-&gt;{nextfid} where umfid=$self-&gt;{umfid} and nextfid=$self-&gt;{id}";
        my $sql2 = "update antworten set nextfid=$self-&gt;{nextfid} where umfid=$self-&gt;{umfid} and nextfid=$self-&gt;{id}";
        my $sql3 = "select pin from ergebnis where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id}";
	my $antw = $self-&gt;sqldo($sql3);
	if ($antw&gt;1) {return $self-&gt;trans("WA15a")." ".$self-&gt;{id}." ".$self-&gt;trans("WA15c");}
	$self-&gt;sqldo($sql);
 	my $f=frage-&gt;init($self-&gt;{parent}, $self-&gt;{nextfid}); $f=$f-&gt;load;
 	if (defined $f) {             # Die nextfids nur updaten
	   $self-&gt;sqldo($sql1);
	   $self-&gt;sqldo($sql2);       # wenn es meine nextfid-Frage gibt
	}
	my $x=$self-&gt;{id};
	$self-&gt;{id} = undef;
	my $a; 
	foreach $a (@{$self-&gt;{ant}}) {$a-&gt;delete}
    return $self-&gt;trans("WA15a")." ".$x." ".$self-&gt;trans("WA15b");
}

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

####################################################################
####         Liefert einen eindeutigen identifikationsstring
####         Argumente  : -
####         Returnwert : Identifikationsstring
####################################################################
sub IDstr {
	my $self = shift;	
	return "U" . $self-&gt;{umfid} . "F" . $self-&gt;{id}  ;
}

####################################################################
####         Liefert den Fragentext mit Nummer davor in ()
####         Argumente  : -
####         Returnwert : Fullname
####################################################################
sub fullname {
	my $self = shift;	
	return "(" . $self-&gt;{ordernum} . ") " . $self-&gt;{name}  ;
}

####################################################################
####         Erstellt eine neue Antwort zur Frage
####         Argumente  : Antworttext
####         Returnwert : AntwortID
####################################################################
sub newant {
	my $self = shift;	
	my $a;
	my $L=$self-&gt;{ant};
        $self-&gt;log(4,"Entering: frage:newant");
	$a = antwort-&gt;init($self); $a-&gt;new();
	if ($a) {push (@$L, $a);}  #existierende Fragen ins Array packen
	return $a-&gt;{id};
}

####################################################################
####         Aendert die FID der Frage
####         Argumente  : neue FID
####         Returnwert : -
####################################################################
sub changefid {
	my $self = shift;
	my $neue = shift()+0;
	$self-&gt;log(4,"Entering: frage:changefid");
	if ($neue == $self-&gt;{id} ) { return $neue; }
	my $sql = "select fid from fragen where umfid=$self-&gt;{umfid} and fid=$neue";	
	if ($neue != 0){
        my $tst = $self-&gt;sqlselect($sql);                        # gibts diese Antw.ID schon ?
		if ($tst == 0) {
			$self-&gt;sqldo("update fragen set fid=$neue where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id}");                    
			if ($self-&gt;{nextfid}==$self-&gt;{id}) {$self-&gt;{nextfid}=$neue; $self-&gt;store;}
            my $sql1 = "update fragen set nextfid=$neue where umfid=$self-&gt;{umfid} and nextfid=$self-&gt;{id}";
            my $sql2 = "update antworten set nextfid=$neue where umfid=$self-&gt;{umfid} and nextfid=$self-&gt;{id}";
			$self-&gt;sqldo($sql1);
			$self-&gt;sqldo($sql2);
			$self-&gt;{id}=$neue;									# wenn nicht, dann speichern
			foreach (@{$self-&gt;{ant}}) {$_-&gt;changefid($self-&gt;{id});}
		}	
			
	}
	return $neue;                                                    # neue ID zurückgeben
}

####################################################################
####         Gibt Zeiger auf die nächste Frage zurück
####         Argumente  : die PIN und 1 damit auch sichselbst als nächste Frage gibt, sonst nicht
####                 oder bei 2 gibt er immer die nächste , ob beantwortet oder nicht !    										
####         Returnwert : Zeiger auf nächste Frage oder kein Zeiger, wenn letzte
####################################################################
sub nextfrage {
	my $self = shift;	
        my $pin= shift;                               # Benutzerpin
	my $selftoo= shift;                           # Steuervariable
	my $firstfid= shift;			      # erstefid gegen loopings.....	
        $self-&gt;log(4,"Entering: frage:nextfrage");
	if ($firstfid==0){$firstfid=$self-&gt;{id};}
	my $nf; my $fra;  my $nextf; my $acnt;
	foreach (@{$self-&gt;{ant}}) {
	  if ( defined ($nf=$_-&gt;getnextfid($pin))) {
		$nextf=$nf;								 # Von allen beantworteten Fragen die Nextfid holen
		$acnt++;
	  } 
        }                                             # Und in nextf speichern
	if (! defined $nextf) {                       # nicht def., bzw 0  =  nicht beantwortet
	    if ($selftoo == 1) {return $self;}        # bei "ichauch" gebe ich mich zurück
	    $nextf=$self-&gt;{nextfid};                  # sonst die Standardnextfid der Frage
        }
        if ($nextf == 0) {$nextf=$self-&gt;sqlselect("select fid from fragen where umfid='$self-&gt;{umfid}' and ordernum &gt; '$self-&gt;{ordernum}' order by ordernum");}
        if ($nextf == -1) {return;}                   # Fragebogen zuende !!
	if ($nextf == $self-&gt;{id}) {
		$self-&gt;log(4,"Ich bin Nextfid von mir selbst !"); 
		if ($self-&gt;{warntext} eq "") {
			$self-&gt;{warntext} = $self-&gt;trans("WA5");
		}
		return $self; 
	}
					 	       # bin ich selbst meine nächste ? , Dann halt mich zurück um endlosschl. zu verh.
    if ($nextf == $firstfid) {$self-&gt;log(2,"Aaargh, Antwortlooping entdeckt !"); return;}    # Wenn die Anfangsfrage wieder auftaucht:  Loopinggefahr!!! und ENDE !
    $fra=frage-&gt;init($self-&gt;{parent}, $nextf); $fra=$fra-&gt;load;     # nächste Frage fragen !!!
	if (! defined $fra) {return;}                   # wenn nicht definiert dann ende
	if ($selftoo == 2) {return $fra;}             # unbedingt nächste Frage, dann nächste zurück !
	return $fra-&gt;nextfrage($pin,1,$firstfid);     # rekursiv die nächste mit "ichauch" aufrufen

}

####################################################################
####         Nummeriert die Antworten neu durch
####         Argumente  : -
####         Returnwert : -
####################################################################
sub renumant {
	my $self = shift;
	my $a=undef; my $x=1; 
        $self-&gt;log(4,"Entering: frage:renumant");
	foreach $a ( @{$self-&gt;{ant}}) { $a-&gt;changeaid($x++) }
}

####################################################################
####         Loescht die Antwort mit der angegebenen ID
####         Argumente  : Aid der Antwort
####         Returnwert : -
####################################################################
sub delant {
	my $self = shift;
	my $a; 
	my $aid = shift;  my @L=();
    $self-&gt;log(4,"Entering: frage:delant");
	foreach $a (@{$self-&gt;{ant}}) {
		if ($a-&gt;{id} == $aid) {$a-&gt;delete;}
		else {push (@L, $a); }
	}	
	$self-&gt;{ant}=\@L;
}

####################################################################
####         Speichert die Antworten der Panelisten
####         Argumente  : Zeiger auf Variablen
####         Returnwert : -
####################################################################
sub enterant {
	my $self = shift;
	my ($a,$gd,$acnt);
    my $ID=$self-&gt;IDstr;
	my $sql1= "select pin from ergebnis where umfid=$baseq::VARS{umfid} and fid=$baseq::VARS{fid} and pin=$baseq::VARS{pin}";
    $self-&gt;log(4,"Entering: frage:enterant");
	if ( defined $self-&gt;sqlselect($sql1) ) { 
		$self-&gt;{warntext}=$self-&gt;trans("WA4");
		return ;
	}
	foreach (keys %baseq::VARS) {
		next unless /^$ID/;
		if ($baseq::VARS{$_} ne "") {$acnt++ }
	}
	$self-&gt;log(4,"acnt=$acnt");
	if ($acnt&gt;$self-&gt;{maxant} &amp;&amp; $self-&gt;{maxant}&gt;0) {	# Wenn zuviel angeklickt wurde.....	
		$self-&gt;{warntext}=$self-&gt;trans("WA5b")." ".$self-&gt;{maxant}." ".$self-&gt;trans("WA5c");
		$self-&gt;log(4,"Zuviel angeklickt !");
		return;
	}
	if ($acnt&lt;$self-&gt;{minant} &amp;&amp; $self-&gt;{minant}&gt;0) {   # Wenn zuwenig angeklickt wurde.....	
		$self-&gt;{warntext}=$self-&gt;trans("WA5a")." ".$self-&gt;{minant}." ".$self-&gt;trans("WA5c");
		$self-&gt;log(4,"Zuwenig angeklickt !");
		return; 
	}
	
	foreach (@{$self-&gt;{ant}}) { $_-&gt;enterant; }	
    return;
}

####################################################################
####         Uebernimmt Textattribute des Parent
####         Argumente  : Zeiger auf Variablen
####         Returnwert : -
####################################################################
sub settext {
	my $self = shift;
    $self-&gt;log(4,"Entering: frage:settext");
	$self-&gt;{qtface} = $self-&gt;{parent}-&gt;{qtface};
 	$self-&gt;{qtsize} = $self-&gt;{parent}-&gt;{qtsize};
 	$self-&gt;{qtcolor} = $self-&gt;{parent}-&gt;{qtcolor};
	$self-&gt;{atface} = $self-&gt;{parent}-&gt;{atface};
 	$self-&gt;{atsize} = $self-&gt;{parent}-&gt;{atsize};
 	$self-&gt;{atcolor} = $self-&gt;{parent}-&gt;{atcolor};
    $self-&gt;store;
}


####################################################################
####         Gibt die Frage als html für Panelisten aus
####         Argumente  : -
####         Returnwert : HTML-text der Frage
####################################################################
sub htmlfra {
	my $self = shift;
	my ($BILD, $ordernum);
    $self-&gt;log(4,"Entering: frage:htmlfra");
	if ($self-&gt;{bild} ne "") { $BILD=$self-&gt;IMG($self-&gt;{bild}); } else {$BILD="&amp;nbsp;"}
	if ($self-&gt;{warntext} eq "") {$self-&gt;{warntext}=$self-&gt;{parent}-&gt;{warntext};}
	$self-&gt;{helpkontext}="frage_".substr $self-&gt;{typ},0,1;
	$TITLE=$self-&gt;trans("TI6");
    	$HTML= $self-&gt;qfont($self-&gt;fullname());
    	if ($self-&gt;{typ} eq "H") {$HTML=$self-&gt;qfont($self-&gt;{name});}
	$HTML.="\n&lt;BR&gt;\n&lt;TABLE&gt;\n".
 	$self-&gt;TR([ $self-&gt;htmlant , $BILD ]).
	"&lt;/TABLE&gt;\n&lt;BR&gt;&lt;BR&gt;\n";
	my @L1=("but","but","but","but"); my @L2=("BU25","BU3","BU2","BU24");
	if (! $self-&gt;{parent}{uspringen}) {@L1=("but","but","but"); @L2=("BU25","BU2","BU24");}  # Überspringen
	if ($self-&gt;{typ} eq "H")  {@L1=("but","but"); @L2=("BU25","BU24");}  # Nur Weiter
	$HTML.=$self-&gt;SMrow(\@L1,\@L2);
    $self-&gt;printhtml("prorata.web: internet market research", $HTML)
}

####################################################################
####         Gibt die Antworten als html für Probanden zurück
####         Argumente  : -
####         Returnwert : Antworten als HTML
####################################################################
sub htmlant {
	my $self = shift;
	my ($a, $ret, $me );
	my @L=@{$self-&gt;{ant}} ;
 	my @LI=("&amp;nbsp;","&amp;nbsp;");
	my $typ = $self-&gt;{typ};
    (my $typ1, my $menge) = $typ =~/^(.)(.*)/;
	my $me=0;
	my $Start="&lt;TABLE size=100% &gt;\n";
	my $End="&lt;/TABLE&gt;\n";
    $self-&gt;log(4,"Entering: frage:htmlant");
	if ($typ1 eq "D" ) {$Start="&lt;SELECT name='".$self-&gt;IDstr."'&gt;\n"; $End="&lt;/SELECT&gt;\n";}
	if ($typ1 eq "S" ) {
		for ($me=1; $me&lt;=$menge; $me++) { @Li[$me+1] = $self-&gt;afont($me); }
       	$Start.=$self-&gt;TR(\@Li);
    }
    $ret .= $Start;
	while ($a=shift @L) { $ret .= $a-&gt;htmlant;  }	
    $ret .= $End;

	return $ret
}	
			
####################################################################
####         Gibt sich und die Antworten zur Bearbeitung
####		durch den Kunden aus
####         Argumente  : -
####         Returnwert : HTML-string
####################################################################
sub htmlbearb {
	my $self = shift;
	my ( $a, $ret, @merk, $x, $fid, @fidl, @freefids  );
	my $TITLE=$self-&gt;trans("TI6")." ".$self-&gt;{id};
	$self-&gt;log(4,"Entering: frage:htmlbearb");
	my $typ=substr($self-&gt;{typ},0,1);
		
	$ret=$self-&gt;TF("ordernum", $self-&gt;{ordernum},5 )."\n".
	"&lt;TEXTAREA NAME=\"frage\" cols=80 rows=8
	&gt;".$self-&gt;{name}."&lt;/TEXTAREA&gt;".
	"\n&lt;BR&gt;&lt;BR&gt;\n";

        $ret.="&lt;TABLE&gt;\n".
                $self-&gt;TR([ $self-&gt;sfont($self-&gt;trans("HI25")),
                            $self-&gt;sfont($self-&gt;trans("HI26")),
                            $self-&gt;sfont($self-&gt;trans("HI27")),
                            $self-&gt;sfont($self-&gt;trans("HI28")) ]).
                $self-&gt;TR([ $self-&gt;sfont($self-&gt;trans("HI24")),
                            $self-&gt;DDfface("qtface",$self-&gt;{qtface}),
                            $self-&gt;TF("qtsize",$self-&gt;{qtsize},5),
                            $self-&gt;DDfcolor("qtcolor",$self-&gt;{qtcolor})  ]).
                $self-&gt;TR([ $self-&gt;sfont($self-&gt;trans("HI29")),
                            $self-&gt;DDfface("atface",$self-&gt;{atface}),
                            $self-&gt;TF("atsize",$self-&gt;{atsize},5),
                            $self-&gt;DDfcolor("atcolor",$self-&gt;{atcolor})  ]).
	      "&lt;/TABLE&gt;\n&lt;BR&gt;&lt;BR&gt;\n";	

    	$ret.="&lt;TABLE&gt;\n".
	      $self-&gt;TR([
				$self-&gt;sfont($self-&gt;trans("HI31c")),
				$self-&gt;sfont($self-&gt;trans("HI30")),
				$self-&gt;sfont($self-&gt;trans("HI31")),
				$self-&gt;sfont($self-&gt;trans("HI31a")),
				$self-&gt;sfont($self-&gt;trans("HI31j")) ]).
					
		  $self-&gt;TR([
				$self-&gt;CB("incent", 1, $self-&gt;{incent}) ,
				$self-&gt;TF("bild",$self-&gt;{bild},30),
				$self-&gt;DDordernum("nextfid",$self-&gt;{nextfid}),
				$self-&gt;DD("typ", $self-&gt;{ltyp}, $self-&gt;{typ}, $self-&gt;{htyp} ),
				$self-&gt;CB("showstat", 1, $self-&gt;{showstat}) ]).

		  $self-&gt;TR([
				$self-&gt;sfont($self-&gt;trans("HI31b")),
				$self-&gt;sfont($self-&gt;trans("HI31d")),
				$self-&gt;sfont($self-&gt;trans("HI31f")), 
				$self-&gt;sfont($self-&gt;trans("HI31g")) ]).		 
		  
		  $self-&gt;TR([
				$self-&gt;DD("grafik",$self-&gt;{lgrafik}{$typ}, $self-&gt;{grafik}, $self-&gt;{hgrafik}{$typ}),
				$self-&gt;DD("gschmuck",$self-&gt;{lschmuck}, $self-&gt;{gschmuck}, $self-&gt;{hschmuck}),
				$self-&gt;DD("sort", $self-&gt;{lsort},$self-&gt;{sort}, $self-&gt;{hsort}),
				$self-&gt;sfont($self-&gt;trans("HI31h").$self-&gt;TF("minant",$self-&gt;{minant},3,3).$self-&gt;trans("HI31i").$self-&gt;TF("maxant",$self-&gt;{maxant},3,3)) ]).	
		  "&lt;/TABLE&gt;\n";
	



        $ret.="&lt;TABLE&gt;\n".$self-&gt;TR([
                $self-&gt;sfont($self-&gt;trans("HI37")),
                $self-&gt;sfont($self-&gt;trans("HI38")),
                $self-&gt;sfont($self-&gt;trans("HI44")),
                $self-&gt;sfont($self-&gt;trans("HI45")),
                $self-&gt;sfont($self-&gt;trans("HI106")),
				$self-&gt;sfont($self-&gt;trans("HI31")),
				]);

        for ($x=1;$x&lt;6;$x++){ push (@merk, $self-&gt;newant); }     # 5 neue Antworten bauen
	my @L=@{$self-&gt;{ant}};
	while ($a=shift @L) { $ret.=$a-&gt;htmlbearb; }                     # alle Antworten ausgeben
	while ($a=shift @merk) {$self-&gt;delant($a);}                      # und die 5 wieder löschen....
        $ret.="&lt;/TABLE&gt;\n&lt;BR&gt;\n".
      	$self-&gt;SMrow(["but","but","but","but","but","but"] , ["BU1","BU5","BU10","BU8","BU4","BU24"]); 

        $self-&gt;{helpkontext}="fragebearbeiten";
        $self-&gt;printhtml($TITLE, $ret);
        return;
}

####################################################################
####         nimmt die Änderungen aus dem Formular an
####         Argumente  : Zeiger auf Variablen
####         Returnwert : -
####################################################################
sub getbearb {
	my $self = shift;
	my ( $a, $gd, $good, @L, @L1, $x );
        $self-&gt;log(4,"Entering: frage:getbearb");
	$self-&gt;{name}=$self-&gt;clean($baseq::VARS{frage});
	$self-&gt;{bild}=$self-&gt;fclean($baseq::VARS{bild});	
	$self-&gt;{nextfid}=$baseq::VARS{nextfid}+0;
	$self-&gt;{typ}=$self-&gt;fclean($baseq::VARS{typ});
	$self-&gt;{qtface}=$self-&gt;fclean($baseq::VARS{qtface});	
	$self-&gt;{qtsize}=$self-&gt;fclean($baseq::VARS{qtsize});	
	$self-&gt;{qtcolor}=$self-&gt;fclean($baseq::VARS{qtcolor});	
	$self-&gt;{atface}=$self-&gt;fclean($baseq::VARS{atface});	
	$self-&gt;{atsize}=$self-&gt;fclean($baseq::VARS{atsize});	
	$self-&gt;{atcolor}=$self-&gt;fclean($baseq::VARS{atcolor});
	$self-&gt;{grafik}=$self-&gt;fclean($baseq::VARS{grafik});
	$self-&gt;{incent}=$baseq::VARS{incent}+0;
	$self-&gt;{gschmuck}=$baseq::VARS{gschmuck}+0;
	$self-&gt;{sort}=$baseq::VARS{sort}+0;
	$self-&gt;{minant}=$baseq::VARS{minant}+0;
	$self-&gt;{maxant}=$baseq::VARS{maxant}+0;
	$self-&gt;{showstat}=$baseq::VARS{showstat}+0;
	$self-&gt;{ordernum}=$self-&gt;fclean($baseq::VARS{ordernum});
	my $newfid=$baseq::VARS{newfid}+0;
	for ($x=1;$x&lt;6;$x++){  $self-&gt;newant; }           # 5 neue Antworten bauen
	@L=@{$self-&gt;{ant}};
	foreach $a (@L) { $a-&gt;getbearb($#L+2); }            # Werte einlesen
	foreach $a (@L) {if ( $a-&gt;{name} eq "") {$self-&gt;delant($a-&gt;{id});};} # alle leeren Antworten loeschen
		$self-&gt;loadantw;
		$self-&gt;renumant;
		$self-&gt;store;
	# if ($newfid != $self-&gt;{id}) {$self-&gt;changefid($newfid);}	# ist mit den neuen Nummern nicht mehr nötig !!!
}
	
####################################################################
####         Listet die Fragen auf zur Anzeige für den Kunden
####         Argumente  : -
####         Returnwert : HTML-text
####################################################################
sub fragenliste {
	my $self = shift;
	my $ret=""; my $a; my @L=@{$self-&gt;{ant}}; my $next;
	my $umf=$self-&gt;{parent};
	my $warn="&amp;nbsp;";
        $self-&gt;log(4,"Entering: frage:fragenliste");
	if ($self-&gt;{nextfid} == $self-&gt;{id}) {$warn=$self-&gt;trans("LW5");}
	if (! ($self-&gt;{qtsize}=~/^\+{0,1}[0-9]$/)) {$warn=$self-&gt;trans("LW6");}
	if (! ($self-&gt;{atsize}=~/^\+{0,1}[0-9]$/)) {$warn=$self-&gt;trans("LW7");}
	if ($self-&gt;{typ} eq "" ) {$warn=$self-&gt;trans("LW8");}
	if ($self-&gt;{nextfid} != 0) {
		 $next=$self-&gt;sfont("&gt;".$baseq::RHordernums-&gt;{$self-&gt;{nextfid}});
	}
	$ret.=$self-&gt;TR([
	        $self-&gt;RB("radio",$self-&gt;{id}),
	      	$self-&gt;{ordernum}.")",
	      	$self-&gt;sfont("[".$self-&gt;{typ}."]") . $self-&gt;qfont($self-&gt;{name}),
	      	$next,
	      	$self-&gt;sfont($warn)  ]);
	$self-&gt;log(4,"Jetzt in die Antwortenliste");      	
	while ($a=shift @L) { $ret.=$a-&gt;antwortenliste; }
	$ret.=$self-&gt;TR(["&amp;nbsp","&amp;nbsp;","&amp;nbsp;","&amp;nbsp;"]);  # Eine Leerzeile......
	return $ret;
}
	
####################################################################
####         Strickt die Grafik für Live statistik
####         Argumente  : -
####         Returnwert : HTML-text
####################################################################
sub makegrafik {
	my ($self, $grafik) = @_;
	$self-&gt;log(4,"Entering: frage:makegrafik");

	my ($X)=$self-&gt;{typ}=~/^S(\d{1,2})$/;    # $X=5 oder 7 wenn Skalenantwort 	      	
	# $self-&gt;{olda}=0;                   ######### Nochn OTTO-HACK (siehe antwort.pm-&gt;grafikdataset)
    my $N=$self-&gt;{countpin};
	my %grdata;
	$self-&gt;log(4,"OTTO HACK: ".$self-&gt;{parent}-&gt;{knr}." | ".$self-&gt;{id});

	########################### OTTO HACK :-)
	#if ( ($self-&gt;{parent}-&gt;{knr}==4) &amp;&amp; ($self-&gt;{id}==1) ) {
	#	$N=$self-&gt;sqlselect("select count(pin) from umfidpin where umfid=$self-&gt;{umfid}");
	#}
	########################### OTTO Hack Ende.....

	if ($X&gt;0) {$N=$X;}
	$grdata{N}=$N;
	$grafik-&gt;setdata(\%grdata);
	foreach ( @{$self-&gt;{ant}} ) {$grafik-&gt;newdataset($_-&gt;grafikdataset($X));}
	$grafik-&gt;createimg;
    return;
}

####################################################################
####         Strickt die Grafik für Live statistik
####         Argumente  : -
####         Returnwert : HTML-text
####################################################################
sub htmlgrafik {
	my $self = shift;
	my $IMG="";
    $self-&gt;log(4,$self-&gt;{details}." -- ".$self-&gt;IDstr);
    if ($self-&gt;{details} ne "" &amp;&amp; $self-&gt;IDstr ne $self-&gt;{details}) {return $self-&gt;grafikhtml;}
	$self-&gt;{grpid}=$self-&gt;{parent}-&gt;{grpid};
	$self-&gt;{grplfd}=$self-&gt;{parent}-&gt;{grplfd};
	$self-&gt;log(4,"Entering: frage:htmlgrafik");
	if ($self-&gt;{typ} eq "H" || (! $self-&gt;{showstat}) ) {return;}
	if ($self-&gt;{countpin}){
	   if ($self-&gt;{typ} ne "T") {	
		   $IMG=$self-&gt;grafikhtml;			
		}
        else {
		  if ($self-&gt;IDstr eq $self-&gt;{details}) {
				$IMG=$self-&gt;grafikdetails.
				$self-&gt;SM("stbut","BU58"); 
		  }
		  $IMG.=$self-&gt;SM("stbut".$self-&gt;IDstr,"BU59");
		} 
	}	
	
	else {$IMG=$self-&gt;afont($self-&gt;trans("HI40"));}
	return $self-&gt;qfont($self-&gt;fullname()) ."&lt;BR&gt;\n". $IMG . "\n&lt;HR&gt;\n"; 	
}

####################################################################
####         Fragenstatistik
####         Argumente  : -
####         Returnwert : Zeiger auf Datensatz
####################################################################
sub createantarrayref {
	my $self = shift;
	my @ret;
	foreach ( @{$self-&gt;{ant}} ) {
		$ret[$_-&gt;{id}]=$_;
    		$self-&gt;log(2,"FID:".$self-&gt;{id}." AID:".$_-&gt;{id});
	}
	return ($self-&gt;{id}, \@ret);
}

####################################################################
####         Erstellt HTML-Datei mit Textantworten
####         Argumente  : -
####         Returnwert : Link auf HTML-Datei
####################################################################
sub grafikdetails {
	my $self = shift;
    $self-&gt;log(4,"Entering: frage:htmltextant");
	if ($self-&gt;{typ}=~/^S\d+$/ ) {return $self-&gt;grafikdetailskala();}
	my $ret="";
    if ($self-&gt;{showstat}) {
    	foreach  (@{$self-&gt;{ant}}) {$ret .= $_-&gt;htmltextant; }
	}
	return $ret;
}

####################################################################
####         Erstellt HTML-Datei mit Textantworten
####         Argumente  : -
####         Returnwert : Link auf HTML-Datei
####################################################################
sub grafikdetailskala {
	my $self = shift;
    $self-&gt;log(4,"Entering: frage:htmltextant");

	my $HTML="";

	# fid, aid anzahl der Antworten und Textantworten selektieren
	@where=@{$self-&gt;{parent}-&gt;{whereref}}; @table=@{$self-&gt;{parent}-&gt;{tableref}}; 
	push @where, ("a.umfid=$self-&gt;{umfid}","a.fid=$self-&gt;{id}"); push @table, "ergebnis a";
	($table, $where) = $self-&gt;{parent}-&gt;jointables(\@table, \@where);
	my $sth=$self-&gt;sqlprepare("select a.aid, a.text from $table where $where ");
	while ( my ($aid, $txt) = $sth-&gt;fetchrow_array ) {
		$ants[$aid][$txt]++  # Mitzaehlen wieviel
	}
	$sth-&gt;finish;
	
    my $grafik=grafikm-&gt;init($self-&gt;{parent});
    $grdata{GRA}="BA";      
    $grdata{pid}=$self-&gt;{parent}-&gt;{grpid};
    $grdata{plfd}=$self-&gt;{parent}-&gt;{grplfd};
    $grdata{schmuck}=1;
    $grdata{sorttype}="lfd";
    $grdata{shadowcolor}=$self-&gt;{shadowcolor};
    $grdata{textformath}="&amp;T - &amp;P%";
    $grdata{textformatv}="Nr.&amp;L (&amp;Z) ";
    $grdata{nachkomma}=0;
	my @names;
	foreach (@{$self-&gt;{ant}}) {$names[$_-&gt;{id}]=$_-&gt;{name} }
	foreach $aid (1...$#ants) {
                my $zufz=int(rand 10000000)+1;
		my $filename=$baseq::UMFIMG."U".$self-&gt;{umfid}."F".$self-&gt;{id}."C".$self-&gt;{countpin}."-".$self-&gt;{parent}-&gt;{grpid}."x".$self-&gt;{parent}-&gt;{grplfd}."x".$aid.$zufz.".gif";		
	    $self-&gt;log(4,"DETAILS Grafikdatei = $baseq::PATH.$filename / X=$X, IDG=$IDG, IDS=$IDS IDV=$IDV");
		$grafik-&gt;imgreset;
		$grdata{filename}=$baseq::PATH.$filename;
	    $grafik-&gt;setdata(\%grdata);
	    @anz=@{$ants[$aid]};
		foreach (1...$#anz) {
			$name=$self-&gt;{name};
			$name=~s/&lt;[^&gt;]+[&gt;\$]//g;
			$grafik-&gt;newdataset({"lfd" =&gt; $_,
			 				     "txt" =&gt; "Antworten mit $_",
							     "num" =&gt; $ants[$aid][$_],
							     "tabl"=&gt; "ergebnis",
			 			         "wher"=&gt; "umfid='$self-&gt;{umfid}' fid='$self-&gt;{id}' aid='$aid' text=$_",
							     "descr"=&gt;$name.": ".$names[$aid]." - Antwort=$_"});
								 
		}	
		$grafik-&gt;createimg;
		$HTML.= $self-&gt;qfont($names[$aid])."&lt;BR&gt;\n".$self-&gt;IMGsubmit($filename, "stbut".$grafik-&gt;{id})."&lt;BR&gt;\n";
	}
    return $HTML;
}

####################################################################
####         liefert ein Array der Antworttexte zurueck
####         Argumente  : -
####         Returnwert : das Array
####################################################################

sub antwortarray {
	my $self = shift;
	my @erg=();
	foreach (@{$self-&gt;{ant}}) {$erg[$_-&gt;{id}]=$_-&gt;{name};}
	$self-&gt;log(4,join (" - ", @erg) );
	return @erg;
}

####################################################################
####         liefert den fuer diese Frage verdienten Betrag
####		 in Eurocent
####         Argumente  : -
####         Returnwert : Link auf HTML-Datei
####################################################################

sub verdient {
	my $self = shift;
	my $pin = shift;
	if ($pin==0) {$self-&gt;log(1, "frage-&gt;verdient : PIN wurde nicht übergeben !"); }
	my $sql="select aid from ergebnis where umfid=$self-&gt;{umfid} and fid=$self-&gt;{id} and pin=$pin";
	if ($self-&gt;sqlselect($sql)){return $self-&gt;{incent};}
	return 0;
}

####################################################################
####         Pivotiert die Ergebnistabelle
####		 in Eurocent
####         Argumente  : -
####         Returnwert : Zeiger auf Hash und TextString
####################################################################

sub pivot {
	  my $self=shift;
	  my $hash=shift;
	  my $num=$self-&gt;{id};
	  if ($num&lt;10) {$num="0".$num;}
	  my $beschr="\n\nFRAGE ".$self-&gt;{id}."\n========\n";
	  my $zah=10000; my %bes; my $key="";my $txt="";my $aid; my $pin;
	  my $sql="select distinct a.pin,a.aid,a.text,b.ID from ergebnis a left join pivot b using(umfid,fid,aid,pin) where a.umfid=$self-&gt;{umfid} and a.fid=$self-&gt;{id} order by b.ID";
	  my $sth=$self-&gt;sqlprepare($sql);
	  while (($pin,$aid,$txt,$grpid)=$sth-&gt;fetchrow_array) {
	  if ($grpid) {$txt=$grpid}
		$txt=~s/ä/ae/g;
		$txt=~s/ö/oe/g;
		$txt=~s/ü/ue/g;
		$txt=~s/Ä/ae/g;
		$txt=~s/Ö/oe/g;
		$txt=~s/Ü/ue/g;
		$txt=~s/ß/ss/g;
		$txt=~s/[^a-z,\.@\d]/ /gi;
		$txt=~s/\s*(.*)\s*/$1/;
        $txt=~s/,/\./g;		
		if ($txt eq "" ){$txt="1";}		#Anklickantworten
		if ( $txt =~ /[^\d\.]/) {	    #Textantworten als Zahl
     		$txt=~s/\./,/g;		
			$txt=lc($txt);
			if ($bes{$txt} == 0) {$bes{$txt}=++$zah; }
			$self-&gt;log(4,$bes{$txt}."  ||  ".$txt);
			$txt=$bes{$txt};
		}
		my $col ="F".$num."A".$aid;
		$$hash{$pin}{$col}=$txt;
		$$hash{$pin}{-pin}=$pin;
		$$hash{0}{$col}=$col;			# Den Beschreibungstext in der ersten Zeile.....
		$txt="";
	  }
	  foreach $key (sort {$bes{$a} &lt;=&gt; $bes{$b} } keys %bes) {
		$beschr.=$bes{$key}."\t".$key."\n";
	  }
	  
	  if ($zah==10000) {$beschr="";}
	  
	  return $beschr;
}	  	

####################################################################
####         Exportieren der Frage
####         Argumente  : -
####         Returnwert : string
####################################################################
sub export {
      my $self = shift;
	  my $exp="   [frage]\n";
	  foreach  (@{$self-&gt;{exportvars}}) {
		  $exp.=sprintf("   %-13s = %s\n", $_, $self-&gt;{$_} );
	  }
  	  $exp.="\n";
	  foreach (@{$self-&gt;{ant}}) {
		$exp.=$_-&gt;export;
	  }
      return $exp;
}

####################################################################
####         Exportieren der Frage
####         Argumente  : -
####         Returnwert : string
####################################################################
sub exportxls {
      my ($self,$fragen, $antworten,$row,$antrow) = @_;
	  my $cnt=0;
	  foreach  (@{$self-&gt;{exportvars}}) {
		  $fragen-&gt;write_string(0,$cnt, $_);
  		  $fragen-&gt;write_string($row,$cnt++, $self-&gt;{$_});
	  }
	  foreach (@{$self-&gt;{ant}}) {
		$_-&gt;exportxls($antworten,$antrow++);
	  }
	  return $antrow;
}
</pre></body></html>