#    This source code file is part of the "mod_survey" package.
#
#    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::Persistance;
use strict;

use Survey::PersistanceArg;
use Survey::Language;

use CGI qw/:standard/;
use CGI::Cookie;

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

    $self->{PARGUMENT} = Survey::PersistanceArg->new();

    $self->{ERROR}        = 0;
    $self->{ERRORCODE}    = 0;
    $self->{REPOSITORY}   = $ENV{"_SURVEY_SYSBASE"} . "persistance/";    # May need to be fixed for windows compat
    $self->{VALUES}       = {};
    $self->{CREATIONTIME} = localtime();
    $self->{PAGELEFT}     = $r->filename();
    $self->{ACCESS_FORM}  = 0;

    bless($self);

    if (!-e $self->{REPOSITORY})
    {
        system "mkdir " . $self->{REPOSITORY};                           # May need windows compat fix
    }

    if (!-r $self->{REPOSITORY})
    {
        $self->{ERROR}     = lprint("Persistance repository does not exist, and was not possible to create it");
        $self->{ERRORCODE} = 1;
    }

    # See if user already got a session id
    my (%cookies) = parse CGI::Cookie($ENV{HTTP_COOKIE});

    my ($csid) = undef;
    my ($cpid);
    if (defined($cookies{"persistance-id"}))
    {
        $cpid = $cookies{"persistance-id"}->value;
    }

    # Let's see if there are any valid argument string
    my ($qsid) = $self->{PARGUMENT}->ArgByName("persistance-id");

    # cookies got precedence...
    my ($peid) = $cpid || $qsid;

    if ($peid)
    {
        $self->{PERSISTANCE_ID} = $peid;
        my ($filename) = $self->{REPOSITORY} . $self->{PERSISTANCE_ID};
        if (-e $filename)
        {

            #if persistance file exists... let's read it
            #we're here if we want to read a persistance
            #object that we've saved before...so I think
            #we just want to finish a survey :)

            $self->readFromDisk();

            #persistance instance now is available to you
            #so now you can "automatic fill-in" pre-answered
            #questions and going on with other stuffs.
        }
        else
        {
            $self->htmlPerForm();
            $self->{ACCESS_FORM} = 1;
        }
    }
    else
    {
        if ($self->{PARGUMENT}->ArgByName("saveit"))
        {

            #otherwise we've to "invent" a persistance
            #so we're here to write down a new persistance
            #object

            $self->{PERSISTANCE_ID} = $self->getAKey();

            #now... we could popolate this persistance
            #istance calling popolate() method and writing
            #it to the disk with writeToDisk();
        }
        else
        {
            $self->htmlPerForm();
            $self->{ACCESS_FORM} = 1;
        }
    }

    # We want to update the cookie no matter what
    my ($persistanceCookie) = new CGI::Cookie(
                                            -name    => 'persistance-id',
                                            -value   => $self->{PERSISTANCE_ID},
                                            -expires => '+3M',                     # setting the expire time to 3 months
    );

    $r->headers_out->{'Set-Cookie'} = $persistanceCookie;

    $self->setValue("PERSISTANCE_ID", $self->{PERSISTANCE_ID}, 0);
    $self->setValue("CREATIONTIME",   $self->{CREATIONTIME},   0);
    $self->setValue("PAGELEFT",       $self->{PAGELEFT},       0);

    return ($self);
}

# Set a value in the persistance hash
sub setValue()
{
    my ($self, $name, $value, $issession) = @_;
    if ($issession != 1)
    {
        $self->{VALUES}->{$name} = $value;
    }
    else
    {
        $self->{SESSION}->{VALUES}->{$name} = $value;
    }
}

# Get a value from the persistance hash
sub getValue()
{
    my ($self, $key, $issession) = @_;

    if ($issession != 1)
    {
        return $self->{VALUES}->{$key};
    }
    else
    {
        return $self->{SESSION}->{VALUES}->{$key};
    }
}

# insert a new array variable. Expected input for
# $value is an array *reference*, ie \@arr
sub setArrayValue()
{
    my ($self, $name, $value) = @_;

    $self->{ARRAYS}->{$name} = $value;
}

# retrieve array variable. Returns an array reference
sub getArrayValue()
{
    my ($self, $name) = @_;
    return $self->{ARRAYS}->{$name};
}

# insert a new hash varible.
sub setHashValue()
{
    my ($self, $name, $value) = @_;
    $self->{HASHES}->{$name} = $value;
}

# retrieve a hash variable.
sub getHashValue()
{
    my ($self, $name) = @_;
    return $self->{HASHES}->{$name};
}

#fill-in this persistance object with
#all answer the user has just type-in.
#I need the document and session objects.
sub popolate()
{
    my ($self, $doc, $ses) = @_;

    my ($value, $key, $arr);

    #All stuffs that I need...

    my (@data) = @{ $doc->{DATA} };
    my ($sesv) = $ses->{VALUES};
    my ($sesh) = $ses->{HASHES};
    my ($sesa) = $ses->{ARRAYS};

    #Let's start persisting :)
    # 1) data
    # 2) session
    #  2.1) session values
    #  2.2) session arrays
    #  2.3) session hashes

    # 1) data

    foreach $value (@data)
    {
        $self->setValue($value->{NAME}, $value->{VALUE}, 0);
    }

    # 2.1) session values
    foreach $key (keys(%{ $ses->{VALUES} }))
    {

        # add $key and $ses->{VALUES}->{$key} to the persistance obj

        $self->setValue($key, $ses->{VALUES}->{$key}, 1);
    }

    # 2.2) session arrays
    if ($ses->{ARRAYS})
    {
        foreach $key (keys(%{ $self->{ARRAYS} }))
        {

            # We have an array to work with
            my (@arr) = @{ $self->{ARRAYS}->{$key} };

            $self->setArrayValue($key, $arr);
        }
    }

    # 2.3) session hashes
    if ($ses->{HASHES})
    {
        foreach $key (keys(%{ $self->{HASHES} }))
        {

            # We have an hash to work with
            my ($hsh) = $self->{HASHES}->{$key};

            $self->setHashValue($key, $hsh);
        }
    }
}

# Populate persistance hash
sub readFromDisk()
{
    my ($self) = shift;

    my ($persistanceFileName) = $self->{REPOSITORY} . $self->{PERSISTANCE_ID};
    if (open(PERFILE, $persistanceFileName))
    {
        my ($file, $pair, $key, $value);

        # This is needed if a value contains \n
        my (@allfile) = <PERFILE>;
        $file = join("", @allfile);

        my (@pairs) = split("\x00", $file);
        foreach $pair (@pairs)
        {
            if ($pair)
            {
                ($key, $value) = split("\x01", $pair, 2);
                if ($key)
                {
                    $self->{VALUES}->{$key} = $value;
                }
            }
        }

        close(PERFILE);
    }
    else
    {
        $self->{ERROR}     = lprint("Could not open persistance file for reading. Maybe you've lost your code.");
        $self->{ERRORCODE} = 2;
        return;
    }

    # Do it all again, but this time try opening the persistance sessionfile

    my ($persesFileName) = $persistanceFileName . ".session";
    if (open(PERFILE, $persesFileName))
    {
        my ($file, $pair, $key, $value);

        # This is needed if a value contains \n
        my (@allfile) = <PERFILE>;
        $file = join("", @allfile);

        my (@pairs) = split("\x00", $file);
        foreach $pair (@pairs)
        {
            if ($pair)
            {
                ($key, $value) = split("\x01", $pair, 2);
                if ($key)
                {
                    $self->{SESSION}->{VALUES}->{$key} = $value;
                }
            }
        }

        close(PERFILE);
    }
    else
    {
        $self->{ERROR}     = lprint("Could not open persistance session file for reading");
        $self->{ERRORCODE} = 2;
    }

    # Do it all again, but this time try opening the array/blob file
    # Currently it only understands arrays and hashes, but I'm preparing
    # this for expansion so it can understand, for example, large data
    # objects.
    $persistanceFileName .= ".blob";
    if (open(PERFILE, $persistanceFileName))
    {
        my ($file, $blob, $type, $name, $data);

        # This is needed if a value contains \n
        my (@allfile) = <PERFILE>;
        $file = join("", @allfile);

        my (@blobs) = split("\x00", $file);
        foreach $blob (@blobs)
        {
            if ($blob)
            {

                # Format of file (top-level) is
                #
                #   record \x00 record \x00 record ...
                #
                # Format of record is:
                #
                #   type \x01 name \x01 data
                #
                # type can be
                #
                #   A = array
                #   H = hash

                ($type, $name, $data) = split("\x01", $blob, 3);

                if ($type eq "A")
                {

                    # Data contains an array of values. Values are
                    # delimited with \x02
                    @{ $self->{ARRAYS}->{$name} } = split("\x02", $data);
                }

                if ($type eq "H")
                {

                    # Data contains an array of key/value pairs, in
                    # the form
                    #
                    #   key \x03 value \x02 key \x03 value ...
                    my (@pairs) = split("\x02", $data);
                    my ($key, $value, $pair);

                    # new anonymous hash
                    $self->{HASHES}->{$name} = {};

                    foreach $pair (@pairs)
                    {
                        ($key, $value) = split("\x03", $pair, 2);
                        $self->{HASHES}->{$name}->{$key} = $value;
                    }
                }
            }
        }

        close(PERFILE);
    }
    else
    {

        # no error. Blob file won't exist unless there are blobs.
    }
}

# Flush session hash to disk
sub writeToDisk()
{
    my ($self) = shift;
    my ($key);

    # (open persistance file for writing)
    my ($persistanceFileName) = $self->{REPOSITORY} . $self->{PERSISTANCE_ID};
    if (open(PERFILE, ">$persistanceFileName"))
    {
        my ($numwritten) = 0;
        foreach $key (keys(%{ $self->{VALUES} }))
        {

            # add $key and $self->{VALUES}->{$key} to the file we're writing
            # Format is key \x01 value \x00 to avoid conflicts with important
            # character values
            print PERFILE $key . "\x01" . $self->{VALUES}->{$key} . "\x00";
            $numwritten++;
        }
        close(PERFILE);

        # If persistance was empty it must have been cleared, and thus we can
        # remove it. This is necessary in order to not overload persistance
        # directory.
        if (!$numwritten)
        {
            unlink $persistanceFileName;
        }
    }
    else
    {
        $self->{ERROR}     = lprint("Could not open persistance file in writing mode");
        $self->{ERRORCODE} = 2;
    }

    my ($persesFileName) = $persistanceFileName . ".session";

    if (open(PERFILE, ">$persesFileName"))
    {
        my ($numwritten) = 0;
        foreach $key (keys(%{ $self->{SESSION}->{VALUES} }))
        {

            # add $key and $self->{VALUES}->{$key} to the file we're writing
            # Format is key \x01 value \x00 to avoid conflicts with important
            # character values
            print PERFILE $key . "\x01" . $self->{SESSION}->{VALUES}->{$key} . "\x00";
            $numwritten++;
        }
        close(PERFILE);

        # If persistance was empty it must have been cleared, and thus we can
        # remove it. This is necessary in order to not overload persistance
        # directory.
        if (!$numwritten)
        {
            unlink $persesFileName;
        }
    }
    else
    {
        $self->{ERROR}     = lprint("Could not open persistance-session file in writing mode");
        $self->{ERRORCODE} = 2;
    }

    if ($self->{ARRAYS} || $self->{HASHES})
    {

        # someone has set array/hash in persistance, we need to write it
        # to separate file. Name it persistance + ".blob".
        $persistanceFileName .= ".blob";

        if (open(PERFILE, ">$persistanceFileName"))
        {
            my ($numwritten) = 0;

            # Avoid null values by setting up empty hash/array if needed
            if (!$self->{ARRAYS}) { @{ $self->{ARRAYS} } = (); }
            if (!$self->{HASHES}) { $self->{HASHES} = {}; }

            # iterate through arrays, won't happen if empty
            foreach $key (keys(%{ $self->{ARRAYS} }))
            {

                # We have an array to write
                my (@arr) = @{ $self->{ARRAYS}->{$key} };

                # Type is array, and name is $key
                print PERFILE "A\x01$key\x01";

                my ($cell);
                my ($isfirst) = 1;

                # iterate through array and print values
                foreach $cell (@arr)
                {
                    if (!$isfirst)
                    {
                        print PERFILE "\x02";
                    }
                    else
                    {
                        $isfirst = 0;
                    }
                    print PERFILE $cell;
                }

                # end of record
                print PERFILE "\x00";

                $numwritten++;
            }

            # iterate through hashes, won't happen if empty
            foreach $key (keys(%{ $self->{HASHES} }))
            {

                # We have a hash to write
                my ($hsh) = $self->{HASHES}->{$key};

                # Type is hash, and name is $key
                print PERFILE "H\x01$key\x01";

                my ($name);
                my ($isfirst) = 1;

                # iterate through hash keys and print name/values
                foreach $name (keys(%{$hsh}))
                {
                    if (!$isfirst)
                    {
                        print PERFILE "\x02";
                    }
                    else
                    {
                        $isfirst = 0;
                    }

                    my ($value) = $self->{HASHES}->{$key}->{$name};

                    print PERFILE "$name\x03$value";
                }

                # end of record
                print PERFILE "\x00";

                $numwritten++;
            }

            close(PERFILE);

            # If persistance was empty it must have been cleared, and thus we can
            # remove it. This is necessary in order to not overload persistance
            # directory.
            if (!$numwritten)
            {
                unlink $persistanceFileName;
            }
        }
        else
        {
            $self->{ERROR}     = lprint("Could not open blob persistance file in writing mode");
            $self->{ERRORCODE} = 2;
        }
    }
}

sub clear()
{
    my ($self) = shift;
    $self->{VALUES}            = {};
    $self->{SESSION}->{VALUES} = {};
    $self->{SESSION}           = {};
    $self->{ARRAYS}            = {};
    $self->{HASHES}            = {};

    my (%cookies) = parse CGI::Cookie($ENV{HTTP_COOKIE});

    if (defined($cookies{"persistance-id"}))
    {
        $cookies{"persistance-id"}->expires('now');
    }
    1;
}

sub getAKey ()
{
    my ($self) = shift;

    my ($remote)    = $ENV{REMOTE_ADDR};
    my (@timecodes) = localtime(time);

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

    $timecodes[4]++;

    my ($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 . "_" . $$;
    $key .= $remote;

    return $key;
}

sub htmlPerForm()
{
    print "<h1>Persistance Access Dialog</h1>\n";
    print "<form method=\"post\" action=\"\">\n";
    print "Type your code here: ";
    print "<input name=\"persistance-id\" type=\"password\"/>\n";
    print "<input type=\"hidden\" name=\"realaction\" value=\"persistance\"/>\n";
    print "<input type=\"hidden\" name=\"action\" value=\"submit\"/>\n";
    print "<br/><br/>\n";
    print "<input type=\"submit\" name=\"persist\" value=\"Continue my survey\"/>\n";
    print "</form><br/>\n";
    print "<div>\n<p>\n";
    print "You're here because you're trying to finish a survey you've previously\n";
    print "started. Please type-in your code to finish it.\n";
    print "</p></div>\n";
}

sub htmlPerCode()
{
    my ($crap, $c) = @_;
    print "<h1>Persistance Access Code</h1>\n";
    print "<div><p>\n";
    print "Your code is: $c";
    print "\n";
    print "</p></div>\n";
}

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

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

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

    unless ($e)
    {
        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.");
    }

    if ($e eq 1)
    {
        print "<b><i>[" . lprint("SYSTEM ERROR 1, NO SESSION") . "]</i></b> ";
        print lprint("The directory where the persistance are stored was not found and could not be created.")
          . "<br/>\n";
        print lprint("Please ask the server administrator to fix this.") . "<br/>";
        print lprint("The persistance directory is set to: ") . $self->{REPOSITORY};
        $found = 1;
    }

    if ($e eq 2)
    {
        print "<b><i>[" . lprint("SYSTEM ERROR 2, COULD NOT OPEN PERSISTANCE FILE") . "]</i></b> ";
        print lprint("The persistance directory is set to: ") . $self->{REPOSITORY};
        $found = 1;
    }

    if (!$found)
    {
        print lprint("This error is not in the knowledge base, so I guess the programmer has made a mistake.");
    }
    print "\n    <br /><br />\n";

    1;
}

1;