#    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::System;

use strict;

use Survey::Language;

if ($ENV{"_SURVEY_USEDBI"})
{
    require DBI;
}

sub new
{
    my ($crap, $doc, $arg) = @_;
    my $self = {};

    $self->{ERROR}     = 0;
    $self->{ERRORCODE} = 0;
    $self->{DOCUMENT}  = $doc;
    $self->{ARGUMENT}  = $arg;

    bless($self);

    if (($arg->ArgByName("action") eq "submit") && (!$arg->Error()))
    {
        if ($doc->GetOption("ASCIIFILE"))
        {
            $self->CheckAscii();
        }

        if ($doc->GetOption("DBITABLE"))
        {
            $self->CheckDbi();
        }
    }

    return ($self);
}

sub CheckAscii
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};
    my ($file) = $doc->GetOption("ASCIIFILE");

    my (@statarr, $outown);

    if (!(-e $file))
    {
        $self->{ERROR} =
          lprint("The export file (") . $file . lprint(") does not exist. I cowardly refuse to create it myself.");
        $self->{ERRORCODE} = 3;
    }
    else
    {
        if (!(-w $file))
        {
            $self->{ERROR}     = lprint("The export file (") . $file . lprint(") is not writable by the web user.");
            $self->{ERRORCODE} = 4;
        }
        else
        {
            @statarr = stat($doc->GetOption("FILE"));
            $outown  = $statarr[4];
            @statarr = stat($file);
            if (($outown ne $statarr[4]) && (!$doc->GetOption("ISAUTO")))
            {
                $self->{ERROR} =
                    lprint("The export file (") 
                  . $file
                  . lprint(") and the survey file (")
                  . $doc->GetOption("FILE")
                  . lprint(") are not owned by the same user.");
                $self->{ERRORCODE} = 5;
            }
        }
    }

    1;
}

sub CheckDbi
{
    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 ($cre) = $doc->GetOption("DBICREATE");
    my ($dbh, $sth);

    if (!$ENV{"_SURVEY_USEDBI"})
    {
        $self->{ERROR}     = lprint("DBI is switched off");
        $self->{ERRORCODE} = 10;

        return 1;
    }

    my ($exec) = "\$dbh = DBI->connect(\$dsn,\$usr,\$psw,{ PrintError => 0, AutoCommit => 1, RaiseError => 0})";
    eval $exec;

    if (!$dbh)
    {
        my ($errstr) = lprint("Malformed DSN. No such DBD driver ?");
        eval "\$errstr = \$DBI::errstr;";

        if (!$errstr) { $errstr = lprint("Malformed DSN. No such DBD driver ?"); }

        $self->{ERROR}     = lprint("Could not do a DBI connect. Error was : ") . $errstr;
        $self->{ERRORCODE} = 6;
    }
    else
    {
        if (!($sth = $dbh->prepare("SELECT * FROM " . $table)))
        {
            $self->{ERROR}     = lprint("Could not prepare a select. Error was : ") . $DBI::errstr;
            $self->{ERRORCODE} = 7;
        }
        else
        {
            if (!($sth->execute()))
            {
                $self->{ERROR}     = lprint("Could not execute a select. Error was : ") . $DBI::errstr;
                $self->{ERRORCODE} = 8;
            }
            else
            {
                $sth->finish;
            }
        }
        $dbh->disconnect;
    }

    1;
}

sub GetKey
{
    my ($self) = shift;
    return $self->{KEY};
}

sub CheckSetUser
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};
    my ($sb)   = $doc->GetOption("SYSBASE");

    if (   ($doc->GetOption("REQAUTH") ne "no")
        && (($doc->GetOption("UNIQUE") eq "yes") || ($doc->GetOption("UNIQUE") eq "auth")))
    {
        $sb .= $ENV{REMOTE_USER};

        open(FIL, ">" . $sb);
        close(FIL);
    }

    if ($doc->GetOption("UNIQUE") eq "ip")
    {
        $sb .= $ENV{REMOTE_ADDR};

        open(FIL, ">" . $sb);
        close(FIL);
    }

}

sub CreateKey
{
    my ($self) = shift;
    my ($i);
    my ($key);
    my ($doc) = $self->{DOCUMENT};
    my ($sb)  = $doc->GetOption("SYSBASE");

    umask 0077;

    my (@timecodes) = localtime(time);

    for ($i = 0 ; $i < @timecodes ; $i++)
    {
        if ($timecodes[$i] < 10)
        {
            $timecodes[$i] = "0" . $timecodes[$i];
        }
    }

    $timecodes[4]++;

    $key = 1900 + $timecodes[5];
    $key = $key . $timecodes[4];
    $key = $key . $timecodes[3] . "_";
    $key = $key . $timecodes[2];
    $key = $key . $timecodes[1];
    $key = $key . $timecodes[0];
    $key = $key . "_" . $$;

    $self->{KEY} = $key;

    # -- Start fix for avoiding key clash.
    # That a key clash would occur even without this is extremely
    # unlikely, but it doesn't really cost anything to have it
    # here, so why not?
    if (-e $sb . $key)
    {
        $i = int(rand(27)) + 65;
        my ($c) = chr($i);
        $key .= $c;
    }

    # -- end key clash fix

    open(FIL, ">" . $sb . $key);
    close(FIL);

    if (!(-e $sb . $key))
    {
        $self->{ERROR}     = lprint("Could not generate system key");
        $self->{ERRORCODE} = 2;
    }

    1;
}

sub CheckKey
{
    my ($self) = shift;
    my ($arg)  = $self->{ARGUMENT};
    my ($key)  = $arg->ArgByName("key");
    my ($doc)  = $self->{DOCUMENT};
    my ($sb)   = $doc->GetOption("SYSBASE");

    my ($dat, $tim, $prc) = split("_", $key, $3);

    if ((length($dat) != 8) || (length($tim) != 6) || ($prc < 1))
    {
        $self->{ERROR}     = lprint("Malformed key");
        $self->{ERRORCODE} = 9;
    }
    else
    {
        if (-e $sb . $key)
        {
            unlink $sb . $key;
        }
        else
        {
            $self->{ERROR}     = lprint("Invalid key");
            $self->{ERRORCODE} = 1;
        }
    }

    1;
}

sub Error
{
    my ($self) = shift;
    return $self->{ERROR};
}

sub PrintErrorDescription
{
    my $self = shift;

    my ($e)     = $self->{ERRORCODE};
    my ($found) = 0;

    my ($lb) = "<b>\&lt\;";
    my ($rb) = "\&gt\;</b>";

    print "    <br /><br />\n    ";

    if ($e)
    {
        if ($e eq 1)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 1, INVALID KEY") . "]</i></b> ";
            print lprint("The key for the submitted document was not valid. ");
            print lprint("A system key is generated each time a survey is viewed. ");
            print lprint("This key has to be the same when the survey is submitted. ");
            print lprint("This is a security measure aimed at attempts of overloading the system with junk data. ");
            print lprint(
'The sollution is to press "back" in your browser and reload the page containing the survey in order to generate a new system key. '
            );
            print lprint("If the problem persists, contact the system administrator.");
            $found = 1;
        }

        if ($e eq 2)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 2, COULD NOT GENERATE KEY") . "]</i></b> ";
            print lprint("The system key could not be written to the key database. ");
            print lprint("A system key is generated each time a survey is viewed. ");
            print lprint("This key has to be the same when the survey is submitted. ");
            print lprint("This is a security measure aimed at attempts of overloading the system with junk data. ");
            print lprint(
"The probable reason for the error is that the web user does not have permission to write where the key database is stored (by default in /tmp). "
            );
            $found = 1;
        }

        if ($e eq 3)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 3, EXPORT FILE DOES NOT EXIST") . "]</i></b> ";
            print lprint(
                   "The ASCIIFILE parameter is set in the survey file, but the location it points to does not exist. ");
            print lprint(
"Since allowing the web user too generous write permissions might be a security hazard, the program will not attempt to create the file. "
            );
            print lprint(
"You can create an empty file in the appropriate location by issuing the command <b>touch \&lt\; filename\&gt\;</b>. ");
            print lprint("You will also have to permit the web user write access to that file. ");
            print lprint(
                     "The quick and dirty way to do this is by issuing the command <b>chmod 777 \&lt\;filename\&gt\;.");
            $found = 1;
        }

        if ($e eq 4)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 4, EXPORT FILE IS NOT WRITABLE") . "]</i></b> ";
            print lprint(
"The ASCIIFILE parameter is set but points to a file to which the web user do not have write persmissions. ");
            print lprint(
                 "The quick and dirty way to correct this is by issuing the command <b>chmod 777 \&lt\;filename\&gt\;. "
            );
            print lprint("(Where filename is the location that ASCIIFILE points to)");
            $found = 1;
        }

        if ($e eq 5)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 5, NOT OWNED BY SAME USER") . "]</i></b> ";
            print lprint(
"As a security measure, the program will refuse to write to an ASCIIFILE which is not owned by the same user as the surveyfile that pointed to the ASCIIFILE. "
            );
            print lprint("This in order to prevent users from overwriting each other\'s files. ");
            print lprint(
"To solve this problem, set the same UID on both files, or create a new ASCIIFILE with the correct ownership.");
            $found = 1;
        }

        if ($e eq 6)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 6, COULD NOT CONNECT DBI DATABASE") . "]</i></b> ";
            print lprint("When connecting DBI databases, quite a lot of things might be wrong. ");
            print lprint("You will have to try to interpret the error description printed above.");
            $found = 1;
        }

        if ($e eq 7)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 7, COULD NOT PREPARE A DBI SELECT") . "]</i></b> ";
            print lprint("When using DBI databases, quite a lot of things might be wrong. ");
            print lprint("You will have to try to interpret the error description printed above.");
            $found = 1;
        }

        if ($e eq 8)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 8, COULD NOT EXECUTE A DBI SELECT") . "]</i></b> ";
            print lprint("When using DBI databases, quite a lot of things might be wrong. ");
            print lprint("You will have to try to interpret the error description printed above.");

            $found = 1;
        }

        if ($e eq 9)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 9, MALFORMED KEY") . "]</i></b> ";
            print lprint(
"The key handling routine expects the key to be formatted approximately YYYYMMDD_HHMMSS_PPPP (date, time and process number when the key was created. "
            );
            print lprint("For some reason the input key was malformed.");
            $found = 1;
        }

        if ($e eq 10)
        {
            print "<b><i>[" . lprint("SYSTEM ERROR 10, DBI IS SWITCHED OFF") . "]</i></b> ";
            print lprint(
"In the global configuration file, the flag which controls the use of DBI is set to zero, meaning that Mod_Survey should not try to access the DBI modules. "
            );
            print lprint("Therefore, it is not possible to use the DBITABLE export method.");
            $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 "<i>[" . lprint("SYSTEM ERROR 0, NO ERROR") . "]</i> ";
        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    <br /><br />\n";

    1;
}

1;