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

use template;
#use strict;

@ISA = qw ( template );

$Htyp={"0","Kein","1","Normal","2","Zahl","3","Datum"};

####################################################################
####         Konstuktor der Antwortenklasse
####         Argumente  : Umfid , fid , Antworttext
####         Returnwert : Referenz auf das neue Antwortobjekt
####################################################################
sub init {
	my $that = shift;
	my $class = ref($that) || $that;
	my $self = template-&gt;init(@_);
    my @V=qw/umfid fid id name nextfid typ tlang gcolor/;
	if (! defined $self-&gt;{parent}){ $self-&gt;log(1, "Antwort bitte mit Parent initialisieren"); }
	bless $self, $class;	
	$self-&gt;{umfid}   = $self-&gt;{parent}-&gt;{umfid};
	$self-&gt;{fid}     = $self-&gt;{parent}-&gt;{id};
    	$self-&gt;{name}    = "";
	$self-&gt;{nextfid} = 0;
	$self-&gt;{tlang}   = 0;		
	$self-&gt;{typ}     = 0;		
	$self-&gt;{gcolor}	 = 0;
	$self-&gt;{template}= $self-&gt;{parent}-&gt;{template};
	$self-&gt;{textant} = [];
	$self-&gt;loadtmp;
	$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;{qtface}=$self-&gt;{parent}-&gt;{qtface};
	$self-&gt;{qtsize}=$self-&gt;{parent}-&gt;{qtsize};
	$self-&gt;{qtcolor}=$self-&gt;{parent}-&gt;{qtcolor};
	$self-&gt;{stface}=$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;
	return $self;
}

####################################################################
####         Konstuktor der Antwortenklasse
####         Argumente  : Umfid , fid , aid
####         Returnwert : Referenz auf das neue Antwortobjekt
####################################################################
sub load {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:load");
        my $sql = "select antwort, nextfid, typ, tlang, gcolor from antworten where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$self-&gt;{id} ";
        ($self-&gt;{name}, $self-&gt;{nextfid}, $self-&gt;{typ}, $self-&gt;{tlang}, $self-&gt;{gcolor}) = $self-&gt;sqlselect($sql);
	if (! defined $self-&gt;{nextfid}) { $self-&gt;log(2, "Konnte Antwort nicht laden"); return;}
	return $self;
}
####################################################################
####         select * from antwort array übergeben
####         Argumente  : Umfid , fid , aid
####         Returnwert : Referenz auf das neue Antwortobjekt
####################################################################
sub getpreloaded {
	my $self = shift;
	($self-&gt;{umfid}, $self-&gt;{fid}, $self-&gt;{id}, $self-&gt;{name}, 
	 $self-&gt;{nextfid}, $self-&gt;{typ}, $self-&gt;{tlang}, $self-&gt;{gcolor}) = @_;
}

####################################################################
####         ermittelt eine neue ID und speichert die Antwort mit dieser
####         Argumente  -
####         Returnwert -
####################################################################
sub new {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:new");
	$self-&gt;sqldo("lock tables antworten write");
	my $sql1 = "select max(aid) from antworten where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid}";
	$self-&gt;{id} = ($self-&gt;sqlselect($sql1))+1;                # größte ID+1
    my $sql2 = "insert into antworten set umfid=$self-&gt;{umfid}, fid=$self-&gt;{fid}, aid=$self-&gt;{id}, antwort='$self-&gt;{name}', ".
		       "nextfid='$self-&gt;{nextfid}', typ='$self-&gt;{typ}', tlang='$self-&gt;{tlang}', gcolor='$self-&gt;{gcolor}'";
	$self-&gt;sqldo($sql2);	                           # gleich in die Datenbank speichern !!
	$self-&gt;sqldo("unlock tables");
}

####################################################################
####         Speichert die Antwort mit "Update" in der DB
####         Argumente  : evtl eine neue ID
####         Returnwert : -
####################################################################
sub store {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:store");
	my $sql = "update antworten set antwort='$self-&gt;{name}', nextfid=$self-&gt;{nextfid}, ".
              "typ=$self-&gt;{typ}, tlang=$self-&gt;{tlang},  gcolor='$self-&gt;{gcolor}' ".
			  "where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$self-&gt;{id}";
	$self-&gt;sqldo($sql);
    return;
}

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

####################################################################
####         Löscht sich aus der Datenbank und setzt seine ID auf UNDEF
####         Argumente  : -
####         Returnwert : -
####################################################################
sub delete {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:delete");
	my $sql = "delete from antworten where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$self-&gt;{id} ";
	$self-&gt;sqldo($sql);
        $self-&gt;{id} = undef;
}

####################################################################
####         Ermittelt einen eindeutigen Identifikationsstring
####         Argumente  : -
####         Returnwert : Identifikationsstring
####################################################################
sub IDstr {
	my $self = shift;	
	my $tring = "U" . $self-&gt;{umfid} . "F" . $self-&gt;{fid} . "A" . $self-&gt;{id} ;
	return $tring;
}
sub IDFstr {
	my $self = shift;	
	return $self-&gt;{parent}-&gt;IDstr;
}

####################################################################
####         Aendert die AID der Antwort
####         Argumente  : -
####         Returnwert : -
####################################################################
sub changeaid {
	my $self = shift;
	my $neue = shift()+0;
	$self-&gt;log(4,"Entering: antwort:changeaid");
	if ($neue == $self-&gt;{id} ) { return $neue; }
	my $sql = "select aid from antworten where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$neue";	
	if ($neue != 0){
        my $tst = $self-&gt;sqlselect($sql);                        # gibts diese Antw.ID schon ?
	if ($tst == 0) {
	$self-&gt;sqldo("update antworten set aid=$neue where umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$self-&gt;{id}");}                    
	$self-&gt;{id}=$neue;									# wenn nicht, dann speichern
	}
	return $neue;                                                    # neue ID zurückgeben
}

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


####################################################################
####         Liest die von Probanden beantwortete Antwort ein
####         Argumente  : -
####         Returnwert : 1, wenn alles ok, sonst 0
####################################################################
sub enterant {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:enterant");
        my $IDString = $self-&gt;IDstr;
	my $key=""; my $val=""; my $return;
	my $antw=0;  my $antwt="";                                      # antwortnummer, antworttext
	
	while ( ($key,$val) = each( %baseq::VARS) )  {                  # den ganzen Hash durchackern
	  if ($val eq $IDString)     {$antw=$self-&gt;{id};}               # Anklickantwort
	  if ($key eq $IDString."T") {$antwt=$val;}   # Textantwort bei anklickantwort
	  if ($key eq $IDString."S") {$antw=$self-&gt;{id}; $antwt=$val;}  # Skalenantwort
	}
        if (($self-&gt;{parent}-&gt;{typ} eq "T") and ($antwt ne "")) {$antw=$self-&gt;{id};}
	if ($antwt ne "") {$antwt=$self-&gt;fclean($antwt); }
	if ($self-&gt;{typ}==2) {$antwt=~s/^\D*([\d,\.]*)\D*$/$1/;}
	if ($self-&gt;{typ}==3) {
		($t,$m,$j)=$antwt=~/(\d{1,2}).(\d{1,2}).(\d{2,4})/;
		if ($m&lt;10) {$m="0".$m;}
		if ($t&lt;10) {$t="0".$t;}
		if ($j&lt;70) {$j+=2000;}
		if ($j&lt;100) {$j+=1900;}
		$antwt="$j-$m-$t";
	}


##########     ORIGINAL   #############################################################
#
#	my $sql=  "insert into ergebnis values ( $baseq::VARS{pin}, $self-&gt;{umfid}, $self-&gt;{fid}, $antw, '$antwt', NULL )";
#	$self-&gt;log(4,"enterant: antw=$antw");
#	if ($antw != 0) {                                           # Wenn diese Antwort angeklickt wurde, oder eingetippt
#	  $self-&gt;sqldo($sql) ;
#         $return=1;	                                            # Ich war dabei !!!
#	}
#
#########    ORIGINAL ENDE  #############################################################	
######################## Test Fressnapf: zur Befragung weiterleitren.... ################################
	
	if ($self-&gt;{umfid} == 167){
		if($self-&gt;{fid} == 1) {
			if($antw == 2)
			{
	                 $antwt = "Wurde weitergeleiteit";
	                 $self-&gt;log(2,"$antwt");

			my $sql=  "insert into ergebnis values ( $baseq::VARS{pin}, $self-&gt;{umfid}, $self-&gt;{fid}, $antw, '$antwt', NULL )";
			$self-&gt;log(2,"enterant: antw=$sql");
				if ($antw != 0) {
				$self-&gt;sqldo($sql) ;

				my $subsid = $baseq::VARS{pin};

				$self-&gt;log(2,"Doppelte Befragung, Teilnehemer $subsid wurde weitergeleitet");

				#   WEITERLEITUNG
				$location = "https://ssl.prorata.de/cgi/ausfullen?umfid=168&amp;pin=$subsid";
				$self-&gt;log(2,"Weiterleitung zur: $location");
				print "Status: 302 Found\n";
				print "Location: $location\n";
				print "URI: &lt;$location&gt;\n";
				print "Content-type: text/html\r\n\r\n";
				$return=1;}
				return $return;
			}
			else
			{
                         $antwt = "Bleibt in der Studie";
                         $self-&gt;log(2,"$antwt");

			my $sql=  "insert into ergebnis values ( $baseq::VARS{pin}, $self-&gt;{umfid}, $self-&gt;{fid}, $antw, '$antwt', NULL )";
			$self-&gt;log(2,"enterant: antw=$sql");
			if ($antw != 0) { $self-&gt;sqldo($sql) ;$return=1;}
			return $return;

			}
		}
		if($self-&gt;{fid} != 1){
		my $sql=  "insert into ergebnis values ( $baseq::VARS{pin}, $self-&gt;{umfid}, $self-&gt;{fid}, $antw, '$antwt', NULL )";
		$self-&gt;log(4,"enterant: antw=$antw");
		if ($antw != 0) {                                           # Wenn diese Antwort angeklickt wurde, oder eingetippt
		 $self-&gt;sqldo($sql) ;
		 $return=1;                                                # Ich war dabei !!!
		}
       }	
	}

######################## Test Fressnapf: zur Befragung weiterleitren.... ################################
########################################################################################################

##########     ORIGINAL   #############################################################

else{

        my $sql=  "insert into ergebnis values ( $baseq::VARS{pin}, $self-&gt;{umfid}, $self-&gt;{fid}, $antw, '$antwt', NULL )";
        $self-&gt;log(4,"enterant: antw=$antw");
        if ($antw != 0) { # Wenn diese Antwort angeklickt wurde, oder eingetippt
	         $self-&gt;sqldo($sql) ;
		 $return=1;  # Ich war dabei !!!
	}

	 #########    ORIGINAL ENDE  #############################################################
	}
    return $return;  # oder ich wurde nicht geklickt...  :-(
	
}

####################################################################
####         gibt die nächste fid
####         Argumente  : pin des Benutzers
####         Returnwert : nextfid oder undefiniert
####################################################################
sub getnextfid {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:getnextfid");
	my $pin = shift;
        if (! defined $pin){$self-&gt;log(1,"Antwort-&gt;getnextfid : Die pin muß uebergeben werden !");}
	my $sql="select pin from ergebnis where pin=$pin and umfid=$self-&gt;{umfid} and fid=$self-&gt;{fid} and aid=$self-&gt;{id}";
	if ($pin == $self-&gt;sqlselect($sql)) {
            $self-&gt;log(4,"getnextfid: Gefunden!");
            return $self-&gt;{nextfid};
        }                                                    	# nextfid , der mit dieser pin geklickten Antwort
        return;                                                # oder undef zurück !
}


####################################################################
####         gibt sich als HTML zurück, damit Probanden die
####         Frage beantworten können
####         Argumente  : -
####         Returnwert : HTML-Text &lt;input type........&gt;
####################################################################
sub htmlant {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:htmlant");
	my $art = $self-&gt;{parent}-&gt;{typ};
	(my $typ, my $menge)=$art=~/(.)(.*)/ ;
	my $txt=""; my $me=0; my @FIE=();
	my $maxlen=""; my $size=50;
	$self-&gt;{parent}-&gt;{helpkontext}="frage_".$typ;
	if ( $self-&gt;{name}=~/\{(\d{1,3})\.(\d{1,3})\.(\d{1,3})\}/ )      {
		if ($1&gt;0 &amp;&amp; $2&gt;0 &amp;&amp; $3&gt;0) {
			my $text=$self-&gt;sqlselect("select text from ergebnis where umfid=$1 and fid=$2 and aid=$3 and pin=".$baseq::VARS{pin});
			$self-&gt;{name}=~s/\{[\d\.]{5,11}\}/$text/;	
			if ($text eq "") {return }
		}
	}
	if ($self-&gt;{tlang}&gt;0) {$size=$self-&gt;{tlang}; $maxlen=$self-&gt;{tlang};}
	if ($self-&gt;{tlang}&gt;50) {$size=50; $maxlen=$self-&gt;{tlang};}
	@FIE=("&amp;nbsp;", $FIE[1]=$self-&gt;afont($self-&gt;{name}), "&amp;nbsp;");
	if ($typ eq "E") { $FIE[0] = $self-&gt;RB($self-&gt;IDFstr, $self-&gt;IDstr,($baseq::VARS{$self-&gt;IDstr} ne "")); }
	if ($typ eq "M") { $FIE[0] = $self-&gt;CB($self-&gt;IDstr,$self-&gt;IDstr,($baseq::VARS{$self-&gt;IDstr} ne "")); }
    if ($self-&gt;{typ}&gt;0 ) {
		$FIE[2]=$self-&gt;TF($self-&gt;IDstr."T", $baseq::VARS{$self-&gt;IDstr."T"}, $size, $maxlen);
		$self-&gt;{parent}-&gt;{helpkontext}.="T";
	}
	if ($typ eq "S") {                                                                                 # Skalenantwort
		for ($me=1; $me&lt;=$menge; $me++) {
	          $FIE[$me+1] = $self-&gt;RB($self-&gt;IDstr."S", $me,($baseq::VARS{"{$self-&gt;IDstr}S"}==$me));
		}
	}
	if ($typ eq "D") {return "&lt;OPTION VALUE='".$self-&gt;IDstr."'&gt;".$FIE[1]."\n";}
	return $self-&gt;TR(\@FIE);
}


####################################################################
####         gibt sich als HTML zurück, damit die Kunden die Antwort
####         bearbeiten können
####         Argumente  : -
####         Returnwert : HTML-Text
####################################################################
sub htmlbearb {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:htmlbearb");
	my $ID = $self-&gt;IDstr;
        my ($typ)=$self-&gt;{parent}-&gt;{typ}=~/^(\S)\d*/;
        my $Ltyp=[0,1,2,3];
	if ($typ eq "T") {$Ltyp=[1,2,3];}
	if ( ($typ eq "S") || ($typ eq "D") ) {$Ltyp=[0];}
	return $self-&gt;TR([
                 $self-&gt;TF($ID."I",$self-&gt;{id},4),
                 $self-&gt;TF($ID."N",$self-&gt;{name},40),
		         $self-&gt;sfont($self-&gt;DD($ID."T", $Ltyp, $self-&gt;{typ}, $Htyp)),
		         $self-&gt;TF($ID."L",$self-&gt;{tlang},4),	
			     $self-&gt;sfont($self-&gt;DDfcolor($ID."G", $self-&gt;{gcolor}, "grafik")),
                 $self-&gt;DDordernum($ID."F",$self-&gt;{nextfid},4)    ]);
 }

####################################################################
####         nimmt die Änderungen des Kunden an der Antwort an
####         Argumente  : POST-Variablen-zeiger
####         Returnwert : -
####################################################################
sub getbearb {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:getbearb");
 	my $antzahl=shift;
    my $ID = $self-&gt;IDstr;
    my $IDN=$ID."N";my $IDI=$ID."I";my $IDF=$ID."F"; 
	my $IDT=$ID."T"; my $IDL=$ID."L";my $IDG=$ID."G";
 	
    $self-&gt;{name}=$self-&gt;clean($baseq::VARS{$IDN});
	$self-&gt;{nextfid}=$baseq::VARS{$IDF}+0;       	
    $self-&gt;{typ}=$baseq::VARS{$IDT}+0;
    $self-&gt;{tlang}=$baseq::VARS{$IDL}+0;
	$self-&gt;{gcolor}=$self-&gt;fclean($baseq::VARS{$IDG});
	$self-&gt;changeaid($baseq::VARS{$IDI}+$antzahl);
	$self-&gt;store;
	return
}

####################################################################
####         Listet die Antworten in der Fragenliste für die Kunden
####         Argumente  : -
####         Returnwert : HTML-text
####################################################################

sub antwortenliste {
	my $self = shift;
	$self-&gt;log(4,"Entering: antwort:antwortenliste");
	my $fnfid= $self-&gt;{parent}-&gt;{nextfid};   # nextfid der Frage
	my $ret=""; my $next;
	my $warn="&amp;nbsp;";
	if ($self-&gt;{nextfid} == $self-&gt;{fid}) {$warn=$self-&gt;trans("LW3");}
	if ($self-&gt;{nextfid} != 0) {
		 $next=$self-&gt;sfont("&gt;".$baseq::RHordernums-&gt;{$self-&gt;{nextfid}});
	}
	$ret.=$self-&gt;TR([
	        "&amp;nbsp;",
	        $self-&gt;{parent}-&gt;{ordernum}.".".$self-&gt;{id}.")",
	        $self-&gt;afont($self-&gt;{name}),
	      	$next,
	      	$self-&gt;sfont($warn)   ]);
       	return $ret;
}

####################################################################
####         Liefert einen String für die Grafik
####         Argumente  : -
####         Returnwert : String für Grafik
####################################################################

sub grafikdataset {
	my $self = shift;
	my %ret;
	my $olda=0;
	$self-&gt;log(4,"Entering: antwort:grafikstring");
	my ($A, $B)=($self-&gt;{countpin}, $self-&gt;{avgtext} );
	if (shift() &gt; 0 ) {$A=$B;}  # Wenn eine Zahl &gt;0 übergeben, dann den Durchschnittswert für Skala
	$self-&gt;log(4,"OTTO-HACK: ".$self-&gt;{parent}-&gt;{parent}-&gt;{knr}." | ".$self-&gt;{fid} );

	########################### OTTO HACK :-)
	if ( ($self-&gt;{parent}-&gt;{parent}-&gt;{knr}==4) &amp;&amp; ($self-&gt;{fid}==1) ) {
		$self-&gt;{parent}-&gt;{olda}+=$A;
		$A=$self-&gt;{parent}-&gt;{olda};
		$self-&gt;log(4,"OLDA=$A");	
	}
	########################### OTTO Hack Ende.....
	$ret{lfd}=$self-&gt;{id};
	$ret{num}=$A;
	$ret{txt}=$self-&gt;{name};
    $ret{tabl}="ergebnis";
	$ret{wher}="umfid='$self-&gt;{umfid}' fid='$self-&gt;{fid}' aid='$self-&gt;{id}'";  
	if ($self-&gt;{gcolor}) {$ret{color}=$self-&gt;{gcolor};}
	$ret{descr}=$self-&gt;{parent}-&gt;fullname.": ".$self-&gt;{name};
	$ret{descr}=~s/&lt;[^&gt;]+[&gt;\$]//g;
	return \%ret;
}
####################################################################
####         saugt sich die Textantworten rein
####         Argumente  : hashref mit {pin} und {text}
####         Returnwert : -
####################################################################
sub slurptextant {
	my ($self, $pin, $txt) = @_;
	my $ref = { "pin" =&gt; $pin , "text" =&gt; $txt };
	push @{$self-&gt;{textant}} , $ref;
}

####################################################################
####         gibt sich als HTML - Textantwort zurück
####         Argumente  : -
####         Returnwert : HTML-Text  12345: Blablabla
####################################################################
sub htmltextant {
	my $self = shift;
	my ($HTML, $text, $ret, $pin);
	my $ID=$self-&gt;IDstr;
	$self-&gt;log(4,"Entering: antwort:htmltextant");
	if (($self-&gt;{typ}&gt;0) || ($self-&gt;{parent}-&gt;{typ} eq "T")) {
	  $HTML=$self-&gt;afont($self-&gt;{name}). "&lt;BR&gt;\n";
	  foreach (@{$self-&gt;{textant}}) {
	   my $IDX=$ID."PIN".$_-&gt;{pin};
	   $ret.=$self-&gt;CB($IDX,1, $baseq::VARS{$IDX}).$_-&gt;{pin}.": ".$_-&gt;{text}."&lt;BR&gt;\n";}
	}
    if ($ret) {  return $HTML.$self-&gt;sfont($ret)."&lt;BR&gt;\n";}
	return;
}

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

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