# 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::Admin;
use strict;
use Survey::Slask;
use Survey::Statistics;
use Survey::Language;
use Survey::Upload;
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->{ARGUMENT} = $arg;
bless($self);
my (%cookies) = fetch CGI::Cookie;
my ($passwd);
if (!$self->{ERROR})
{
if ($cookies{'password'})
{
$passwd = $cookies{'password'}->value;
}
if ($arg->ArgByName("password"))
{
my ($c) = new CGI::Cookie(-name => 'password', -value => $arg->ArgByName("password"));
$doc->{HANDLER}->headers_out->{'Set-Cookie'} = $c;
# "print"ing Set-Cookie is deprecated in mp2, use headers_out instead
# print "Set-Cookie: " . $c . "\n";
$passwd = $arg->ArgByName("password");
}
if (($doc->GetOption("PASSWORD")) && ($doc->GetOption("PASSWORD") ne $passwd))
{
$self->ReqPassword();
}
else
{
if (!($arg->ArgByName("admin")))
{
$self->Base();
}
else
{
if ($arg->ArgByName("admin") eq "debug") { $self->ShowDebug(); }
if ($arg->ArgByName("admin") eq "source") { $self->ShowSource(); }
if ($arg->ArgByName("admin") eq "flush") { $self->ShowFlush(); }
# if($arg->ArgByName("admin") eq "test") { $self->TestBed(); }
}
}
}
return ($self);
}
sub GoodContentType
{
my ($self, $ct) = @_;
$self->{DOCUMENT}->{HANDLER}->content_type($ct);
}
sub CountOccur
{
my ($str, $chr) = @_;
$str =~ s/[^$chr]//g;
return length($str);
}
sub int2str
{
my ($i) = @_;
my ($b24) = 256 * 256 * 256;
my ($b16) = 256 * 256;
my ($b8) = 256;
my ($a, $b, $c, $d) = (0, 0, 0, 0);
if ($i >= 0)
{
$a = int($i / $b24);
$i = $i % $b24;
$b = int($i / $b16);
$i = $i % $b16;
$c = int($i / $b8);
$i = $i % $b8;
$d = $i;
}
else
{
$i = abs($i) - 1;
$a = 255 - int($i / $b24);
$i = $i % $b24;
$b = 255 - int($i / $b16);
$i = $i % $b16;
$c = 255 - int($i / $b8);
$i = $i % $b8;
$d = 255 - $i;
}
return chr($d) . chr($c) . chr($b) . chr($a);
}
sub PadZero
{
my ($str, $len) = @_;
if ($len > length($str))
{
$str .= chr(0) x ($len - length($str));
}
return $str;
}
sub Pad
{
my ($self, $str, $len) = @_;
if ($len > length($str))
{
$str .= " " x ($len - length($str));
}
return $str;
}
sub ObjType
{
my ($self, $obj) = @_;
my ($objname, $crap);
($objname, $crap) = split(/=/, $obj, 2);
($crap, $objname) = split("::", $objname, 2);
return $objname;
}
sub TestBed
{
my ($self) = shift;
1;
}
sub ReqPassword
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($arg) = $self->{ARGUMENT};
$self->BaseHead();
print "
" . lprint("Password is incorrect or missing") . "
\n";
print " "
. lprint("The author of the survey document has put a password restriction on the use of the administration part")
. ". \n";
print " "
. lprint(
"In order to continue you have to write the correct password in the text box below and click the submit button")
. ".
";
$any = 0;
}
if ($any)
{
print " ("
. lprint("Unfortunately it seems like the author of the document has disallowed all administrative tasks")
. ")";
}
print " " . lprint("More Info") . "
\n";
print " "
. lprint("Do the above not look as expected ? Try reading the documentation, available from") . "\n";
print
" http://gathering.itm.mh.se/modsurvey.
\n";
print " \n\n";
print " \n";
print "\n";
# Survey::Slask->HtmlFoot();
1;
}
sub ShowSource
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($arg) = $self->{ARGUMENT};
my ($inlin);
if ($doc->GetOption("ALLOWSOURCE") eq "yes")
{
if ($arg->ArgByName("source") eq "raw")
{
$self->GoodContentType('text/plain');
if (open(FIL, $doc->GetOption("FILE")))
{
while ($inlin = ) { print $inlin; }
close(FIL);
}
else
{
$self->{ERROR} = lprint("Could not open source file");
$self->{ERRORCODE} = 10;
}
}
if ($arg->ArgByName("source") eq "html")
{
if (open(FIL, $doc->GetOption("FILE")))
{
Survey::Slask->HtmlHead();
print " " . lprint("Source of survey ") . $doc->GetOption("TITLE") . "\n";
Survey::Slask->BodyTag();
print "
\n";
close(FIL);
Survey::Slask->HtmlFoot();
}
else
{
$self->{ERROR} = lprint("Could not open source file");
$self->{ERRORCODE} = 10;
}
}
}
else
{
$self->{ERROR} = lprint("ALLOWSOURCE is not set to yes");
$self->{ERRORCODE} = 1;
}
1;
}
sub ShowStats
{
my ($self) = shift;
print "
" . lprint("Descriptive Statistics") . "
\n";
print " " . lprint("This part of the admin interface is deprecated. The new approach for getting ");
print lprint('descriptive statistics (and a lot of other stuff), is to use ".presentation" files.') . "\n";
1;
}
sub ShowDebug
{
my ($self) = shift;
my ($doc) = $self->{DOCUMENT};
my ($debug) = $doc->{DEBUG};
my ($a, $b, $c, $d, $e);
if ($doc->GetOption("ALLOWDEBUG") eq "yes")
{
print " " . lprint("SURVEY : Function not implemented") . "\n";
Survey::Slask->BodyTag();
print "
\n";
}
if ($arg->ArgByName("flush") ne "download")
{
Survey::Slask->HtmlFoot();
}
}
else
{
$self->{ERROR} = lprint("ALLOWFLUSH is not set to yes");
$self->{ERRORCODE} = 4;
}
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("ADMIN ERROR 1, ALLOWSOURCE IS NOT SET TO YES") . "] ";
print lprint(
"The requested administrative task (to view the source of the survey) is not permitted, since the parameter ALLOWSOURCE (in the SURVEY tag) is not explicitly set to yes. "
);
print lprint(
"All administrative tasks are disallowed per default and has to be explicitly permitted to be available.");
$found = 1;
}
if ($e eq 2)
{
print "[" . lprint("ADMIN ERROR 2, ALLOWSTATS IS NOT SET TO YES") . "] ";
print lprint(
"The requested administrative task (to view statistics about the data) is not permitted, since the parameter ALLOWSTATS (in the SURVEY tag) is not explicitly set to yes. "
);
print lprint(
"All administrative tasks are disallowed per default and has to be explicitly permitted to be available.");
$found = 1;
}
if ($e eq 3)
{
print "[" . lprint("ADMIN ERROR 3, ALLOWDEBUG IS NOT SET TO YES") . "] ";
print lprint(
"The requested administrative task (to view debug info about the survey) is not permitted, since the parameter ALLOWDEBUG (in the SURVEY tag) is not explicitly set to yes. "
);
print lprint(
"All administrative tasks are disallowed per default and has to be explicitly permitted to be available.");
$found = 1;
}
if ($e eq 4)
{
print "[" . lprint("ADMIN ERROR 4, ALLOWFLUSH IS NOT SET TO YES") . "] ";
print lprint(
"The requested administrative task (clear all data) is not permitted, since the parameter ALLOWFLUSH (in the SURVEY tag) is not explicitly set to yes. "
);
print lprint(
"All administrative tasks are disallowed per default and has to be explicitly permitted to be available.");
$found = 1;
}
if ($e eq 5)
{
print "[" . lprint("ADMIN ERROR 5, ALLOWDATA IS NOT SET TO YES") . "] ";
print lprint(
"The requested administrative task (to view te data of the survey) is not permitted, since the parameter ALLOWDATA (in the SURVEY tag) is not explicitly set to yes. "
);
print lprint(
"All administrative tasks are disallowed per default and has to be explicitly permitted to be available.");
$found = 1;
}
if ($e eq 6)
{
print "[" . lprint("ADMIN ERROR 6, COULD NOT OPEN ASCIIFILE FOR READING") . "] ";
print lprint(
"Something went wrong when the program tried to access the ASCIIFILE (set in the SURVEY tag). ");
print lprint("Please check that it exists and that it is readable by the web user.");
$found = 1;
}
if ($e eq 7)
{
print "[" . lprint("ADMIN ERROR 7, A DBI ERROR OCCURED") . "] ";
print lprint("An error occured while trying to interact with the DBI database. ");
print lprint(
"Quite a lot of things can go wrong here, so you will have to try to interpret the error message printed above.");
$found = 1;
}
if ($e eq 8)
{
print "[" . lprint("ADMIN ERROR 8, NO DATA") . "] ";
print lprint("There is no data submitted, so the administrative task requested is not applicable.");
$found = 1;
}
if ($e eq 9)
{
print "[" . lprint("ADMIN ERROR 9, NOT EXPORTING TO ASCIIFILE") . "] ";
print lprint("The ASCIIFILE parameter is not set, so the administrative task requested is not applicable.");
$found = 1;
}
if ($e eq 10)
{
print "[" . lprint("ADMIN ERROR 10, COULD NOT OPEN SOURCE FILE") . "] ";
print lprint(
"The program could not open the survey source file. This is one of the errors that should never occur. "
);
print lprint("If it does anyway, please check ownership and persmissons on the source file.");
$found = 1;
}
if ($e eq 11)
{
print "[" . lprint("ADMIN ERROR 11, IS NOT ADMINUSER") . "] ";
print lprint(
"When ADMINUSER is set as a parameter in the SURVEY tag, you have to authenticate (through Apache's \"Basic\" authentication) as that user. "
);
print lprint(
"If you have authenticated as another user alredy, you will probably have to close your browser, re-open it and try again."
);
$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("ARGUMENT 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