# This source code file is part of the "mod_survey" package.
#
# Copyright (C) 2004 Joel Palmius
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (probably in a file named "LICENSE.txt" or the like);
# if not, write to:
#
# Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#!/usr/bin/perl
package Survey::Data;
use strict;
use Survey::Slask;
use Survey::Statistics;
use Survey::DataEntry;
use Survey::Language;
use CGI qw/:standard/;
use CGI::Cookie;
sub new
{
my ($crap, $doc, $arg) = @_;
my $self = {};
$self->{ERROR} = 0;
$self->{ERRORCODE} = 0;
$self->{DOCUMENT} = $doc;
$self->{SESSION} = $doc->{SESSION};
$self->{ARGUMENT} = $arg;
bless($self);
# print "Content-type: text/plain\n\n";
my ($export) = $arg->ArgByName("export");
if ($doc->{SECURITY_DATA_LEVEL} eq "closed")
{
$self->{ERROR} = lprint("Access to the data module is switched off");
$self->{ERRORCODE} = 99;
}
if (!$self->{ERROR})
{
if ($export)
{
my ($exp) = $self->Translate($export);
$self->BuildMeta();
my ($isevent);
my ($call) = "\$isevent = " . $exp . "->IsEventBased();";
eval($call);
if ($@)
{
die "Data export produced error: " . $@ . "\nCall was: $call\nExp: $exp\nExport: $export";
}
if (!$isevent)
{
$self->ReadData();
}
my ($expobj);
$call = "\$expobj = " . $exp . "->new(\$doc,\$arg,\$self);";
eval($call);
if ($@)
{
die "Data export produced error: " . $@;
}
}
else
{
$self->PrintWelcome();
}
}
return ($self);
}
sub Translate
{
my ($self, $export) = @_;
return $ENV{"_SURVEY_EXPORT_$export"};
}
sub PrintWelcome
{
my ($self) = shift;
$self->{DOCUMENT}->{HANDLER}->content_type('text/html');
my ($urlbase) = $self->{DOCUMENT}->GetOption("URI");
$urlbase .= "?action=data&export=";
print "\n";
print " \n";
print " " . lprint("Data Module") . "\n";
print " \n";
print " \n";
print " \n";
print "
\n";
print lprint("In the data module, you can download the submitted data in a number of different formats.");
print " ";
print lprint("There are Core modules, which encompass common export formats suitable for importing in");
print " ";
print lprint("major statistics software. There are also (if any) optional modules, which either do more");
print " ";
print lprint("uncommon exports, or reformats the data somehow.");
print "\n";
print "
\n";
print " \n";
print "\n";
1;
}
sub CountOccur
{
my ($str, $chr) = @_;
$str =~ s/[^$chr]//g;
return length($str);
}
sub BuildMeta
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($i, @entries, $type, $tagno, $n);
my (@fake) = ();
my ($keyent) = Survey::DataEntry->new($self, "KEY", "srvkey", 0, undef, "[unique key]", undef, 0, 1, \@fake, 40);
push(@entries, $keyent);
for ($i = 0 ; $i < $doc->GetTagCount() ; $i++)
{
$type = $doc->GetTagParam($i, "TYPE");
$tagno = $i;
my ($tr) = $doc->Translate($type);
my ($num) = 0;
my ($call) = "\$num = " . $tr . "->NumberOfValues(\$doc,undef,undef,undef,\$i);";
eval($call);
if ($@) { die $@; }
if ($num > 0)
{
my ($v);
for ($v = 1 ; $v <= $num ; $v++)
{
my ($isnum);
my ($name);
my ($varcap) = "";
my ($valcap) = "";
my ($posval) = "";
my ($fieldlen) = "";
$call = "\$isnum = " . $tr . "->GetValueNumerical(\$doc,undef,undef,undef,\$i);";
eval($call);
if ($@) { die $@; }
$call = "\$name = " . $tr . "->GetValueName(\$doc,undef,undef,undef,\$i,\$v);";
eval($call);
if ($@) { die $@; }
$call = "\$varcap = " . $tr . "->GetVariableCaption(\$doc,undef,undef,undef,\$i,\$v);";
eval($call);
if ($@) { die $@; }
$call = "\$posval = " . $tr . "->GetPossibleValues(\$doc,undef,undef,undef,\$i);";
eval($call);
if ($@) { die $@; }
$call = "\$fieldlen = " . $tr . "->GetFieldLength(\$doc,undef,undef,undef,\$i,\$v);";
eval($call);
if ($@) { die $@; }
my ($entry) =
Survey::DataEntry->new($self, $type, $name, $isnum, undef, $varcap, undef, $i, $v, $posval,
$fieldlen);
push(@entries, $entry);
$n++;
}
}
}
$self->{META} = \@entries;
1;
}
sub ReadRawData
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my (@lines);
if ($doc->GetOption("ASCIIFILE"))
{
if ($ENV{"_SURVEY_USENEWAUTO"} && $doc->GetOption("ISAUTO"))
{
$self->ReadData_NEWAUTO;
}
else
{
$self->ReadData_ASCII;
}
}
else
{
$self->ReadData_DBI;
}
1;
}
sub MakeCase
{
my ($self, $caseno) = @_;
my ($doc) = $self->{DOCUMENT};
my (@data) = @{ $self->{DATA} };
my (@meta) = @{ $self->{META} };
if (scalar(@data) < 1) { return; }
my (@komps) = @{ $data[$caseno - 1] };
my (@entries);
my ($metaentry);
my ($n) = 0;
foreach $metaentry (@meta)
{
my ($type) = $metaentry->{TYPE};
my ($tagno) = $metaentry->{TAGNO};
my ($valno) = $metaentry->{ELEMENT};
my ($isnum) = $metaentry->{ISNUMERIC};
my ($name) = $metaentry->{NAME};
my ($varcap) = $metaentry->{VARIABLECAPTION};
my ($posval) = $metaentry->{POSSIBLEVALUES};
my ($fieldlen) = $metaentry->{FIELDLENGTH};
my ($tr) = $doc->Translate($type);
my ($value) = $komps[$n];
my ($valcap);
if ($tr)
{
my ($call) = "\$valcap = " . $tr . "->GetValueCaption(\$doc,undef,undef,undef,\$tagno,\$value);";
eval($call);
if ($@) { die $@; }
}
else
{
$valcap = undef;
}
my ($entry) =
Survey::DataEntry->new($self,
$type,
$name,
$isnum,
$value,
$varcap,
$valcap,
$tagno,
$valno,
$posval,
$fieldlen);
push(@entries, $entry);
$n++;
}
return \@entries;
}
sub ReadData
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my (@lines);
$self->ReadRawData();
if (!$self->{DATA}) { return; }
my (@data) = @{ $self->{DATA} };
my (@meta) = @{ $self->{META} };
if (scalar(@data) < 1) { return; }
my ($call, $tagno, $subtagno, $dat);
my ($time1) = time();
my (@valcapcache) = ();
foreach $dat (@data)
{
my (@komps) = @{$dat};
my (@entries);
my (@fake) = ();
my ($metaentry);
my ($n) = 0;
foreach $metaentry (@meta)
{
my ($type) = $metaentry->{TYPE};
my ($tagno) = $metaentry->{TAGNO};
my ($valno) = $metaentry->{ELEMENT};
my ($isnum) = $metaentry->{ISNUMERIC};
my ($name) = $metaentry->{NAME};
my ($varcap) = $metaentry->{VARIABLECAPTION};
my ($posval) = $metaentry->{POSSIBLEVALUES};
my ($fieldlen) = $metaentry->{FIELDLENGTH};
my ($tr) = $doc->Translate($type);
my ($value) = @{$dat}[$n];
my ($valcap);
if ($tr)
{
if (!$valcapcache[$tagno])
{
$valcapcache[$tagno] = {};
}
$valcap = $valcapcache[$tagno]->{$value};
if (!defined($valcap))
{
$call = "\$valcap = " . $tr . "->GetValueCaption(\$doc,undef,undef,undef,\$tagno,\$value);";
eval($call);
if ($@) { die $@; }
$valcapcache[$tagno]->{$value} = $valcap;
}
}
else
{
$valcap = undef;
}
my ($entry) =
Survey::DataEntry->new($self,
$type,
$name,
$isnum,
$value,
$varcap,
$valcap,
$tagno,
$valno,
$posval,
$fieldlen);
push(@entries, $entry);
$n++;
}
push(@lines, \@entries);
}
$self->{CASES} = \@lines;
my ($time2) = time();
$self->{TIME} = $time2 - $time1;
1;
}
sub ReadData_NEWAUTO
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($inlin);
my ($del) = "\x01";
my (@lines);
if (open(FIL, $doc->GetOption("ASCIIFILE")))
{
my ($tmp) = join('', );
my (@tmpfil) = split(/\x02/, $tmp);
foreach $inlin (@tmpfil)
{
my (@komps);
@komps = split($del, $inlin);
if (scalar(@komps) == CountOccur($inlin, $del)) { push(@komps, ""); }
push(@lines, \@komps);
$self->{NUMVAR} = scalar(@komps);
}
close(FIL);
$self->{DATA} = \@lines;
$self->{NUMCASE} = scalar(@lines);
}
else
{
$self->{ERROR} = lprint("Could not open ASCIIFILE for reading");
$self->{ERRORCODE} = 99;
}
1;
}
sub ReadData_ASCII
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($inlin);
my ($del) = $doc->GetOption("DELIMITER");
my (@lines);
if (open(FIL, $doc->GetOption("ASCIIFILE")))
{
while ($inlin = )
{
my (@komps);
chop($inlin);
if ($doc->GetOption("DOSBR") eq "yes")
{
chop($inlin);
}
@komps = split($del, $inlin);
if (scalar(@komps) == CountOccur($inlin, $del)) { push(@komps, ""); }
push(@lines, \@komps);
$self->{NUMVAR} = scalar(@komps);
}
close(FIL);
$self->{DATA} = \@lines;
$self->{NUMCASE} = scalar(@lines);
}
else
{
$self->{ERROR} = lprint("Could not open ASCIIFILE for reading");
$self->{ERRORCODE} = 99;
}
1;
}
sub ReadData_DBI
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($table) = $doc->GetOption("DBITABLE");
my ($dsn) = $doc->GetOption("DBIDSN");
$dsn =~ s/\x08/\;/g;
my ($usr) = $doc->GetOption("DBIUSER");
my ($psw) = $doc->GetOption("DBIPASSWD");
my ($dbh, $sth, $sql, @row, @lines, $inlin, $mail, $save, $var);
if ($dbh = DBI->connect($dsn, $usr, $psw, { PrintError => 0, AutoCommit => 1, RaiseError => 0 }))
{
$sql = "SELECT srvkey";
my (@data) = @{ $self->{META} };
foreach $var (@data)
{
if ($var->{NAME} ne "srvkey")
{
$sql .= "," . $var->{NAME};
}
}
$sql .= " FROM " . $doc->GetOption("DBITABLE") . " ORDER BY srvkey";
$sth = $dbh->prepare($sql);
if ($sth->execute())
{
while (@row = $sth->fetchrow())
{
my (@newrow) = @row;
push(@lines, \@newrow);
$self->{NUMVAR} = scalar(@row);
}
$sth->finish;
$self->{DATA} = \@lines;
$self->{NUMCASE} = scalar(@lines);
}
else
{
$self->{ERROR} = lprint("A DBI error occured") . " : " . $DBI::errstr;
$self->{ERRORCODE} = 7;
}
$dbh->disconnect();
}
else
{
$self->{ERROR} = lprint("A DBI error occured") . " : " . $DBI::errstr;
$self->{ERRORCODE} = 7;
}
1;
}
sub Error
{
my ($self) = shift;
return $self->{ERROR};
}
sub PrintErrorDescription
{
my $self = shift;
my ($e) = $self->{ERRORCODE};
my ($found) = 0;
my ($lb) = "\<\;";
my ($rb) = "\>\;";
print "
\n ";
if ($e)
{
if ($e eq 1)
{
print "[" . lprint("DATA ERROR 1, A data error occurred") . "] ";
print lprint("This is just a sample error. ");
$found = 1;
}
if (!$found)
{
print lprint("This error is not in the knowledge base, so I guess the programmer has made a mistake.");
}
}
else
{
print "[" . lprint("DARA ERROR 0, NO ERROR") . "] ";
print lprint(
"No error has occured, but the programmer has for some reason called PrintErrorDescription() anyway. ");
print lprint("I guess the programmer has again made a mistake, something that is a very common event indeed.");
}
print "\n