#    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::Display;
use strict;

use Survey::Document;

use Survey::Component::Component;
use Survey::Component::Env;
use Survey::Component::Geo;
use Survey::Component::Constant;
use Survey::Component::Calculated;
use Survey::Component::Lickert;
use Survey::Component::Choice;
use Survey::Component::List;
use Survey::Component::Matrix;
use Survey::Component::Boolean;
use Survey::Component::Text;
use Survey::Component::Memo;
use Survey::Component::Newline;
use Survey::Component::Custom;
use Survey::Component::Comment;

use Survey::Component::Ifroute;
use Survey::Component::Caseroute;
use Survey::Component::Randomroute;
use Survey::Component::Route;
use Survey::Component::Cati;
use Survey::Component::MailCopy;
use Survey::Component::Sequence;

use Survey::Language;

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

sub new
{

    # added in CRU patch (MJ/20020802)
    my ($crap, $doc, $arg, $sys, $retrieve, $user) = @_;
    my $self = {};
    my ($tid, @timestamp);

    $self->{DOCUMENT} = $doc;
    $self->{SESSION}  = $doc->{SESSION};
    $self->{ARGUMENT} = $arg;
    $self->{SYSTEM}   = $sys;

    # added in CRU patch (MJ/20020802)
    $self->{RETRIEVE}  = $retrieve;
    $self->{USER}      = $user;
    $self->{ERROR}     = 0;
    $self->{ERRORCODE} = 0;
    $self->{DEBUG}     = $doc->{DEBUG};

    bless($self);

    $self->{MAXLOOP} = 50;

    # added in CRU patch (MJ/20020802)
    if ($doc->GetOption("DBITABLE"))
    {
        my ($dsn) = $doc->GetOption("DBIDSN");
        my ($usr) = $doc->GetOption("DBIUSER");
        my ($psw) = $doc->GetOption("DBIPASSWD");
        if (!($self->{DBH} = DBI->connect($dsn, $usr, $psw, { PrintError => 0, AutoCommit => 1, RaiseError => 0 })))
        {
            $self->{ERROR}     = lprint("Could not connect to DBI database (error was ") . $DBI::errstr . ")";
            $self->{ERRORCODE} = 99;
        }
    }

    if ($ENV{"_SURVEY_USEDBI"})
    {
        eval "use Survey::Component::Import";
        if ($@)
        {
            $self->{ERROR}     = lprint("Could not include IMPORT") . " " . $@;
            $self->{ERRORCODE} = 99;
        }
    }

    if (!$self->{ERROR} && ($doc->GetOption("UNIQUE") ne "no"))
    {
        my ($sb) = $doc->GetOption("SYSBASE");

        # Uniqueness based on auth, "yes" for backwards compatibility
        if (($doc->GetOption("UNIQUE") eq "yes") || ($doc->GetOption("UNIQUE") eq "auth"))
        {
            my ($ru) = $ENV{REMOTE_USER};
            if ($ru && (-e $sb . $ru))
            {
                $self->{ERROR}     = "\'" . $ru . "\' " . lprint("has already answered this survey");
                $self->{ERRORCODE} = 4;
                return $self;
            }
        }

        # IP-based uniqueness checking
        if ($doc->GetOption("UNIQUE") eq "ip")
        {
            my ($ru) = $ENV{REMOTE_ADDR};
            if ($ru && (-e $sb . $ru))
            {
                $self->{ERROR}     = lprint("This survey has already been answered from this computer");
                $self->{ERRORCODE} = 99;
                return $self;
            }

        }

        # Cookie-based uniqueness checking
        if ($doc->GetOption("UNIQUE") eq "cookie")
        {

            # TODO
        }
    }

    # Refuse to display if previous part was not answered (JP/20020524)
    if (($doc->GetOption("MULTIPAGE") > 1) && (!$arg->ArgByName("ismultipagesequence")))
    {
        $self->{ERROR}     = lprint("This is a part of a MULTIPAGE sequence. Answer the previous page first.");
        $self->{ERRORCODE} = 5;
        return $self;
    }

    @timestamp = localtime(time);
    $tid       = $timestamp[2] * 3600 + $timestamp[1] * 60 + $timestamp[0];

    $self->{DEBUG}->AddDebugMsg("DISPLAY", "Creating key...");
    if ($doc->GetOption("CHECKKEY") eq "no")
    {
        if ($doc->GetOption("MULTIPAGE") == 1) { $sys->CreateKey(); }
    }
    else { $sys->CreateKey(); }

    # added in CRU patch (MJ/20020806)
    if ($self->{RETRIEVE})
    {
        $self->{BASETABLE} = $doc->GetOption("DBITABLE");
        $self->{BASETABLE} =~ s/$self->{USER}//;
    }

    if (!$sys->Error())
    {
        $self->{DEBUG}->AddDebugMsg("DISPLAY", "Created key " . $sys->GetKey());
        $self->PrintHead();
        if ($doc->GetOption("ACCESSFUN"))
        {
            print "  <body onLoad=\"document.onkeypress = " . $doc->GetOption("ACCESSFUN") . "\">\n";
        }
        else
        {
            print "  <body>\n";
        }
        $self->PrintTags();
    }
    else
    {
        $self->{ERROR}     = lprint("A system error (") . $sys->Error() . lprint(") has occured");
        $self->{ERRORCODE} = 1;
    }

    @timestamp = localtime(time);
    $tid       = ($timestamp[2] * 3600 + $timestamp[1] * 60 + $timestamp[0]) - $tid;
    $self->{DEBUG}->AddDebugMsg("DISPLAY", "Display took " . $tid . " seconds.");

    return ($self);
}


sub ParsePerl
{
    my ($self, $out, $doc, $ses) = @_;
    my ($ml)  = $self->{MAXLOOP};
    my ($rep) = 0;

    my ($start) = -1;
    my ($end)   = 0;

    while (($rep < $ml) && (($start = index($out, "{\\")) >= 0) && (!$self->{ERROR}))
    {
        my ($contents) = "";
        $rep++;
        $end = index($out, "\\}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);

            $substr =~ s/\x0d//g;
            my (@ops) = split(/\x0a/, $substr);
            my ($cell, $reval);
            $reval = "\$output = \"\";\n";

            foreach $cell (@ops)
            {
                $cell =~ s/^[\x09\ ]+//g;
                $cell =~ s/^print\ /\$output\ \.\=\ /;
                if ($cell)
                {
                    $reval .= $cell . "\n";
                }
            }

            my ($output);

            $reval .= "\$output;\n";

            my ($compartment) = new Safe("Tempo");

            my(%cook) = fetch CGI::Cookie;
            my($cookies) = {};
            my($c);
            
            foreach $c (keys %cook)
            {
              $cookies->{$c} = $cook{$c}->value;
            }

            $Tempo::self     = $self;
            $Tempo::cookies  = $cookies;
            $Tempo::document = $self->{DOCUMENT};
            $Tempo::argument = $self->{ARGUMENT};
            $Tempo::session  = $self->{SESSION};

            if ($ENV{_SURVEY_DISABLE_SAFE} eq 1)
            {
                $compartment->deny_only(qw(:dangerous));
            }
            else
            {
                $compartment->permit(qw(time localtime crypt :browse));
            }

            $output = $compartment->reval($reval);
            if ($@)
            {
                $self->{ERROR}     = lprint("Security exception: " . $@);
                $self->{ERRORCODE} = 99;
            }

            my ($contents) = $output;

            $contents = substr($out, 0, $start) . $contents;
            $contents .= substr($out, $end + 2);

            $out = $contents;

        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{\\\" without \"\\}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseVariables
{
    my ($self, $out, $doc, $ses) = @_;
    my ($ml)  = $self->{MAXLOOP};
    my ($rep) = 0;

    my ($start) = -1;
    my ($end)   = 0;

    while (($rep < $ml) && (($start = index($out, "{\$")) >= 0) && (!$self->{ERROR}))
    {
        my ($contents) = "";
        $rep++;
        $end = index($out, "\$}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);

            if (defined($ses->getValue("SUBMITTED_$substr")))
            {
                $contents = $ses->getValue("SUBMITTED_$substr");

                $contents = substr($out, 0, $start) . $contents;
                $contents .= substr($out, $end + 2);

                $out = $contents;
            }
            else
            {
                $self->{ERROR}     = lprint("The variable") . " \"$substr\" " . lprint("has not been submitted");
                $self->{ERRORCODE} = 99;
            }
        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{\$\" without \"\$}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseSession
{
    my ($self, $out, $doc, $ses) = @_;
    my ($ml)  = $self->{MAXLOOP};
    my ($rep) = 0;

    my ($start) = -1;
    my ($end)   = 0;

    while (($rep < $ml) && (($start = index($out, "{_")) >= 0) && (!$self->{ERROR}))
    {
        my ($contents) = "";
        $rep++;
        $end = index($out, "_}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);

            if (defined($ses->getValue($substr)))
            {
                $contents = $ses->getValue($substr);

                $contents = substr($out, 0, $start) . $contents;
                $contents .= substr($out, $end + 2);

                $out = $contents;
            }
            else
            {
                $self->{ERROR}     = lprint("The session variable") . " \"$substr\" " . lprint("is not defined.");
                $self->{ERRORCODE} = 99;
            }
        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{_\" without \"_}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseCaptions
{
    my ($self, $out, $doc, $ses) = @_;
    my ($ml)  = $self->{MAXLOOP};
    my ($rep) = 0;

    my ($start) = -1;
    my ($end)   = 0;

    while (($rep < $ml) && (($start = index($out, "{\%")) >= 0) && (!$self->{ERROR}))
    {
        my ($contents) = "";
        $rep++;
        $end = index($out, "\%}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);

            if (defined($ses->getValue("CAPTION_$substr")))
            {
                $contents = $ses->getValue("CAPTION_$substr");

                $contents = substr($out, 0, $start) . $contents;
                $contents .= substr($out, $end + 2);

                $out = $contents;
            }
            else
            {
                $self->{ERROR}     = lprint("The variable") . " \"$substr\" " . lprint("have not produced a caption");
                $self->{ERRORCODE} = 99;
            }
        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{\%\" without \"\%}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseSelections
{
    my ($self, $out, $doc, $ses) = @_;
    my ($ml)  = $self->{MAXLOOP};
    my ($rep) = 0;

    my ($start) = -1;
    my ($end)   = 0;

    while (($rep < $ml) && (($start = index($out, "{\!")) >= 0) && (!$self->{ERROR}))
    {
        my ($contents) = "";
        $rep++;
        $end = index($out, "\!}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);
            my ($var, $sel) = split(/\//, $substr, 2);

            if (defined($ses->getValue("SUBMITTED_$var")))
            {
                my ($submitted) = $ses->getValue("SUBMITTED_$var");

                my (@cases) = split(/\,/, $sel);
                my ($cell, %values);

                foreach $cell (@cases)
                {
                    my ($val, $cap) = split(/\:/, $cell, 2);
                    $values{$val} = $cap;
                }

                $contents = $values{$submitted};

                $contents = substr($out, 0, $start) . $contents;
                $contents .= substr($out, $end + 2);

                $out = $contents;
            }
            else
            {
                $self->{ERROR}     = lprint("The variable") . " \"$var\" " . lprint("has not been submitted");
                $self->{ERRORCODE} = 99;
            }

        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{\!\" without \"\!}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseDynamics
{
    my ($self, $out) = @_;

    my ($doc) = $self->{DOCUMENT};
    my ($ses) = $doc->{SESSION};

    $out = $self->ParseSession($out,    $doc, $ses);
    $out = $self->ParsePerl($out,       $doc, $ses);
    $out = $self->ParseSelections($out, $doc, $ses);
    $out = $self->ParseCaptions($out,   $doc, $ses);
    $out = $self->ParseVariables($out,  $doc, $ses);

    # Progress bar, patch from Martin Ertl, 2004-10-28
    $self->ParseProgress(\$out, $doc, $ses);

    return $out;
}

# Progress bar, patch from Martin Ertl, 2004-10-28
# (accepted fully minus white-space, some changes in indentation
# /JP 2004-10-28 )
sub ParseProgress
{
    my $this   = shift;
    my $OutPtr = shift;
    my $Doc    = shift;
    my $Ses    = shift;

    # this sub is called more than once on a single survey page
    # -> calculate values only on first call
    if (exists $this->{__progressCache__})
    {
        my $fraction = $this->{__progressCache__}->{fraction};
        my $maxWidth = $this->{__progressCache__}->{maxWidth};

        $$OutPtr =~ s/<!--\%progress\%-->/$fraction/g;
        $$OutPtr =~ s/<!--\%maxWidth\%-->/$maxWidth/g;

        return;
    }

    # get the number of still answered questions from the session
    my $numAnswered = $Ses->getValue("__numAnswered__") || 0;

    # get a string to identify current file
    my $currentFile = $ENV{SCRIPT_NAME};

    # check if current file is already on the stack
    # if this is true delete everything above and set
    # $numAnswered to the value where current file was found on the stack
    for (my $i = 0 ; $i < $numAnswered ; $i++)
    {
        my $stackFile = $Ses->getValue("__progressStack" . $i . "__", 1, __LINE__);

        if ($currentFile eq $stackFile)
        {
            my $temp = $numAnswered;
            $numAnswered = $i;

            while ($i < $temp)
            {
                $Ses->setValue("__progressStack" . $i . "__", "");
                $i++;
            }
            last;
        }
    }

    # save some values to session
    $Ses->setValue("__numAnswered__", $numAnswered + 1);
    $Ses->setValue("__progressStack" . $numAnswered . "__", $currentFile);

    # get the progress information from PROGRES-parameter of SURVEY tag
    my $progresOption = $Doc->GetOption("PROGRES");

    my ($questionsLeft, $maxWidth) = split(/\//, $progresOption);

    # calculate the progress
    my $divisor = $numAnswered + $questionsLeft;
    my $fraction = ($divisor) ? $numAnswered / $divisor : 0;

    $fraction *= $maxWidth;

    # set some variables to remember the values on next call of this sub
    $this->{__progressCache__}->{fraction} = $fraction;
    $this->{__progressCache__}->{maxWidth} = $maxWidth;

    # set variables in the survey file
    $$OutPtr =~ s/<!--\%progress\%-->/$fraction/g;
    $$OutPtr =~ s/<!--\%maxWidth\%-->/$maxWidth/g;
}

sub ParseStyles
{
    my ($self, $out) = @_;

    $out =~ s/\{b\}/\<b\>/g;
    $out =~ s/\{\/b\}/\<\/b\>/g;
    $out =~ s/\{i\}/\<i\>/g;
    $out =~ s/\{\/i\}/\<\/i\>/g;
    $out =~ s/\{u\}/\<u\>/g;
    $out =~ s/\{\/u\}/\<\/u\>/g;

    return $out;
}

sub ParseSpecial
{
    my ($self, $out) = @_;

    $out =~ s/\{\-\}/\=/g;
    $out =~ s/\{\:\}/\;/g;
    $out =~ s/\{\'\}/\"/g;
    $out =~ s/\{\[\}/\</g;
    $out =~ s/\{\]\}/\>/g;
    $out =~ s/\{\A\}/\&/g;

    return $out;
}

sub ParseColors
{
    my ($self, $out) = @_;

    $out =~ s/\{red\}/\<span\ style\=\"color\:\ red\;\"\>/g;
    $out =~ s/\{green\}/\<span\ style\=\"color\:\ green\;\"\>/g;
    $out =~ s/\{blue\}/\<span\ style\=\"color\:\ blue\;\"\>/g;
    $out =~ s/\{yellow\}/\<span\ style\=\"color\:\ yellow\;\"\>/g;
    $out =~ s/\{purple\}/\<span\ style\=\"color\:\ purple\;\"\>/g;
    $out =~ s/\{cyan\}/\<span\ style\=\"color\:\ cyan\;\"\>/g;
    $out =~ s/\{black\}/\<span\ style\=\"color\:\ black\;\"\>/g;
    $out =~ s/\{white\}/\<span\ style\=\"color\:\ white\;\"\>/g;

    $out =~ s/\{\/red\}/\<\/span\>/g;
    $out =~ s/\{\/green\}/\<\/span\>/g;
    $out =~ s/\{\/blue\}/\<\/span\>/g;
    $out =~ s/\{\/yellow\}/\<\/span\>/g;
    $out =~ s/\{\/purple\}/\<\/span\>/g;
    $out =~ s/\{\/cyan\}/\<\/span\>/g;
    $out =~ s/\{\/black\}/\<\/span\>/g;
    $out =~ s/\{\/white\}/\<\/span\>/g;

    return $out;
}

sub ParseLinks
{
    my ($self, $out) = @_;

    my ($start) = -1;
    my ($end)   = 0;

    while (($start = index($out, "{\¤")) >= 0)
    {
        my ($contents) = "";
        $end = index($out, "\¤}");
        if ($end > $start)
        {
            my ($substr) = substr($out, $start + 2, $end - $start - 2);
            if (!-e $substr)
            {
                my ($path, $file) = $self->{DOCUMENT}->{FILE} =~ m/(.*)\/(.*)/;
                my ($delim) = "/";
                if (!$ENV{"_SURVEY_SENSIBLE"}) { $delim = "\\"; }

                $file = $path . $delim . $substr;
                if (-e $file)
                {
                    $substr = $file;
                }
            }

            if (!-r $substr)
            {
                $self->{ERROR}     = lprint("Could not open") . " $substr " . lprint("for reading");
                $self->{ERRORCODE} = 99;
            }
            else
            {
                open(FIL, $substr);
                my (@fil) = <FIL>;
                $contents = join('', @fil);
                close(FIL);

                $contents = substr($out, 0, $start) . $contents;
                $contents .= substr($out, $end + 2);

                $out = $contents;
            }
        }
        else
        {
            $self->{ERROR}     = lprint("Found \"{\¤\" without \"\¤}\"");
            $self->{ERRORCODE} = 99;
        }
    }

    return $out;
}

sub ParseMisc
{
    my ($self, $out) = @_;

    $out =~ s/\{image\}/\<img src\=\"/g;
    $out =~ s/\{\/image\}/\" \/\>/g;

    return $out;
}

sub ParseContent
{
    my ($self, $out) = @_;

    $out = $self->ParseDynamics($out);
    $out = $self->ParseStyles($out);
    $out = $self->ParseSpecial($out);
    $out = $self->ParseColors($out);
    $out = $self->ParseMisc($out);
    $out = $self->ParseLinks($out);

    return $out;
}

sub PrintTags
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};
    my ($sys)  = $self->{SYSTEM};
    my ($arg)  = $self->{ARGUMENT};
    my ($ses)  = $doc->{SESSION};

    my ($i, $n, $type, $found, $crap, $parse, $out);
    my (@data);

    $out   = "";
    $parse = 0;

    my($enc) = $ENV{"_SURVEY_ENCODING"} || "UTF-8";

    print "  <div id=\"mdsbody\">\n";
    print "    <form accept-charset=\"$enc\" id=\"mdsform\" method=\"post\" action=\"" . $doc->GetOption("URI") . "\">\n";
    print "      <p><input type=\"hidden\" name=\"action\" value=\"submit\"/>\n";

    # Contingency for when cookies do not work
    if ($ses->{SESSION_ID})
    {
        print "      <input type=\"hidden\" name=\"session-id\" value=\"" . $ses->{SESSION_ID} . "\"/>\n";
    }

    # knit in answers from previous pages if they exist (JP/20020524)
    if ($self->{ARGUMENT}->ArgByName("multisofar"))
    {
        print "      <input type=\"hidden\" name=\"multisofar\" value=\""
          . $self->{ARGUMENT}->ArgByName("multisofar")
          . "\" />\n";
    }
    if ($doc->GetOption("CHECKKEY") eq "yes")
    {
        print "      <input type=\"hidden\" name=\"key\" value=\"" . $sys->GetKey() . "\" /></p>\n";
    }
    else
    {
        if ($doc->GetOption("MULTIPAGE") > 1)
        {
            print "      <input type=\"hidden\" name=\"key\" value=\"" . $arg->ArgByName("key") . "\" /></p>\n";
        }
        else
        {
            print "      <input type=\"hidden\" name=\"key\" value=\"" . $sys->GetKey() . "\" /></p>\n";
        }
    }

    my ($err, $r);

    my ($random) = $doc->GetOption("RANDOM");
    my ($subset) = $doc->GetOption("SUBSET");
    my (@kompnr);

    srand(time);

    if (($random eq "yes") || ($subset))
    {
        for ($r = 0 ; $r < $doc->GetTagCount() ; $r++)
        {
            push(@kompnr, $r);
        }
    }

    if ($subset)
    {
        my ($totallen) = scalar(@kompnr);
        my ($remove)   = $totallen - $subset;

        if ($remove > 0)
        {
            for ($r = 0 ; $r < $remove ; $r++)
            {
                my ($rpos) = int(rand(scalar(@kompnr)));
                $i = splice(@kompnr, $rpos, 1);
            }
        }
    }

    if ($doc->GetTagCount() > 0)
    {
        for ($r = 0 ; ($r < $doc->GetTagCount()) && (!$self->{ERROR}) ; $r++)
        {
            $i = $r;
            if ($random eq "yes")
            {
                if (scalar(@kompnr) < 1)
                {
                    last;
                }
                my ($rpos) = int(rand(scalar(@kompnr)));
                $i = splice(@kompnr, $rpos, 1);
            }
            else
            {
                if ($subset)
                {
                    if (scalar(@kompnr) < 1)
                    {
                        last;
                    }
                    $i = splice(@kompnr, 0, 1);
                }
            }
            $type  = $doc->GetTagParam($i, "TYPE");
            $found = 0;
            $err   = 0;

            if ($type)
            {
                my ($tr) = $doc->Translate($type);
                if ($tr)
                {
                    my ($out);
                    my ($call) = "\$out = " . $tr . "->PrintComponent(\$self,\$i); \$found=1;";
                    eval($call);

                    if ($@)
                    {
                        $err               = $@;
                        $self->{ERROR}     = lprint("Display of a tag caused exception:") . " " . $err;
                        $self->{ERRORCODE} = 99;
                    }

                    print Survey::Slask->LangHack($self->ParseContent($out));
                }

                if (!$found && !$err)
                {
                    $self->{ERROR}     = lprint("Unknown tag type ") . $type;
                    $self->{ERRORCODE} = 3;
                    $i                 = $doc->GetTagCount();
                }

                if (!grep(/^$type$/,
                          ("CUSTOM",
                           "COMMENT",
                           "NEWLINE",
                           "ENV",
                           "GEO",
                           "CONSTANT",
                           "CALCULATED",
                           "SEQUENCE",
                           "MAILCOPY",
                           "IMPORT",
                           "CATI",
                           "SECURITY",
                           "IFROUTE",
                           "CASEROUTE",
                           "SUBMIT",
                           "SUBMITERROR",
                           "ROUTE",
                           "RANDOMROUTE"
                            )))
                {
                    if ($doc->GetOption("AUTONEWLINES") > 0)
                    {
                        $out = "\n\n      <p>";
                        for $n (1 .. $doc->GetOption("AUTONEWLINES"))
                        {
                            $out .= "<br />";
                        }
                        $out .= "</p>\n\n";
                        print $out;
                    }
                    else
                    {
                        print "<div class=\"componentspc\"></div>\n\n";
                    }
                }
                if ($type eq "IMPORT")
                {
                    if ($doc->GetTagParam($i, "VISIBLE") eq "yes")
                    {
                        if ($doc->GetOption("AUTONEWLINES") > 0)
                        {
                            $out = "\n\n      <p>";
                            for $n (1 .. $doc->GetOption("AUTONEWLINES"))
                            {
                                $out .= "<br />";
                            }
                            $out .= "</p>\n\n";
                            print $out;
                        }
                        else
                        {
                            print "<div class=\"componentspc\"></div>\n\n";
                        }
                    }
                }
            }
        }
    }

    if ($doc->GetTagCount() < 1)
    {
        $self->{ERROR}     = lprint("No tags to print");
        $self->{ERRORCODE} = 2;
    }

    # DIV additions 2002-01-10, suggested by jgramlich
    # Control of text on buttons, added by me 2002-01-10
    print "      <div class=\"mdssubmit\">\n";
    print "        <p><input class=\"mdsbutton\" id=\"SUBMITbutton\" type=\"submit\" value=\""
      . $doc->GetOption("SUBMITTEXT")
      . "\" name=\"submitbtn\" />\n";
    ($doc->GetOption("SHOWCLEAR") ne "no")
      and print "        <input class=\"mdsbutton\" id=\"CLEARbutton\" type=\"reset\" value=\""
      . $doc->GetOption("CLEARTEXT")
      . "\" name=\"clearbtn\" />\n";

    # added in CRU patch (MJ/20020802)
    ($doc->GetOption("SHOWSAVE") ne "no")
      and print "        <input class=\"mdsbutton\" id=\"SAVEbutton\" type=\"submit\" value=\""
      . $doc->GetOption("SAVETEXT")
      . "\" name=\"save\" />\n";

    # added in CRU patch (MJ/20020802)
    print "      </p></div>\n ";

    # added by bugant 4 persistance
    if ($doc->GetOption("PERSIST") eq "yes")
    {
        print "      <div class=\"mdssubmit\">\n";
        print "      <p><input type=\"hidden\" name=\"realaction\" value=\"persistance\"/>\n";
        print "         <input type=\"hidden\" name=\"saveit\" value=\"oooooook\"/>\n";
        print "        <input class=\"mdsbutton\" id=\"PERSISTbutton\" type=\"submit\" value=\""
          . $doc->GetOption("PERSISTTEXT")
          . "\" name=\"saveitb\" /></p>\n";
        print "      </div>\n ";
    }

    # added by bugant 4 persistance

    print "    </form>\n";

    # added by bugant 4 persistance
    if ($doc->GetOption("PERSIST") eq "yes")
    {
        print "    <form method=\"post\" action=\"" . $doc->GetOption("URI") . "\">\n";
        print "      <div class=\"mdssubmit\">\n";
        print "      <p><input type=\"hidden\" name=\"action\" value=\"submit\"/>\n";
        print "         <input type=\"hidden\" name=\"realaction\" value=\"persistance\"/>\n";
        print "         <input class=\"mdsbutton\" id=\"SAVEbutton\" type=\"submit\" value=\""
          . $doc->GetOption("RETRIVETEXT")
          . "\" name=\"retriveitb\" /></p>\n";
        print "      </div>\n ";
        print "    </form>\n";
    }

    print "  </div>\n";

    1;
}

sub ThemeBasic
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};

    $self->{ERROR}     = "The Basic theme is deprecated";
    $self->{ERRORCODE} = 99;

    1;
}

sub ThemeCleanHtml
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};

    print "#mdsbody { color: " . $doc->GetOption("TEXTCOLOR") . " }\n";
    print ".CHOICErb { clear: none; float: left; }\n";
    print ".CHOICEcb { clear: none; float: left; }\n";
    print ".CHOICEother { clear: none; float: left; }\n";
    print ".LICKERTleftcap { clear: none; float: left; }\n";
    print ".LICKERTrb { clear: none; float: left; }\n";

    1;
}

sub ThemeCommon
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};
    print "      body     { color: " . $doc->GetOption("TEXTCOLOR") . "; ";
    print "background-color: " . $doc->GetOption("BGCOLOR") . "; ";

    if ($doc->GetOption("BACKGROUND"))
    {
        print "background-image: url(" . $doc->GetOption("BACKGROUND") . "); ";
    }

    print "}\n";
    print "      :link    { color: " . $doc->GetOption("LINKCOLOR") . "; }\n";
    print "      :visited { color: " . $doc->GetOption("VLINKCOLOR") . "; }\n";

    1;
}

sub PrintHead
{
    my ($self) = shift;
    my ($doc)  = $self->{DOCUMENT};
    if ($doc->GetOption("DESCRIPTION"))
    {
        print "    <meta name=\"description\" content=\"" . $doc->GetOption("DESCRIPTION") . "\" />\n";
    }
    if ($doc->GetOption("KEYWORDS"))
    {
        print "    <meta name=\"keywords\" content=\"" . $doc->GetOption("KEYWORDS") . "\" />\n";
    }
    print "    <title>" . $doc->GetOption("TITLE");

    if ($doc->GetOption("MULTIPAGE") && ($doc->GetOption("PROGRES") eq "yes"))
    {
        print " (MULTIPAGE, part " . $doc->GetOption("MULTIPAGE") . " of " . $doc->GetOption("LASTPAGE") . ")";
    }

    print "</title>\n";

    if ($doc->GetOption("SYSTEMSS"))    # include system stylesheet before custom stylesheet
    {
        my ($ssb) = $doc->GetOption("SYSTEMSS");
        my ($ra)  = $ENV{_SURVEY_ROOT_ALIAS};
        print "    <link rel=\"stylesheet\" href=\"" . $ra . $ssb . "\" />\n";
    }
    if ($doc->GetOption("STYLESHEET"))    # custom system stylesheet overrides parts in SYSTEMSS
    {
        print "    <link rel=\"stylesheet\" href=\"" . $doc->GetOption("STYLESHEET") . "\" />\n";
    }
    if ($doc->GetOption("THEME") eq "cleanhtml")
    {
        print "    <style type=\"text/css\"><!--\n";
        $self->ThemeCommon();

        #    if($doc->GetOption("THEME") eq "basic") { $self->ThemeBasic(); }
        if ($doc->GetOption("THEME") eq "cleanhtml") { $self->ThemeCleanHtml(); }
        print "    --></style>\n";
    }
    print "  </head>\n";

    if ($doc->GetOption("ACCESSJS"))
    {
        print "    <script type=\"text/javascript\" src=\"" . $doc->GetOption("ACCESSJS") . "\"></script>";
    }

    1;
}

sub PrintCaption
{
    my ($self, $tagno) = @_;
    my ($doc) = $self->{DOCUMENT};
    my ($out) = "";
    my ($sp)  = "      ";

    if ($doc->GetOption("THEME") eq "cleanhtml")
    {
        $out .= $sp . "<table width=\"";
        $out .= int($doc->GetOption("CAPTWIDTH")) + 450;
        $out .= "\" cellspacing=\"2\" cellpadding=\"2\" border=\"0\">\n";
        $out .= $sp . "<tr><td valign=\"top\" width=\"" . $doc->GetOption("CAPTWIDTH") . "\"";

        # modified to include the MULTICHOICE tag
        # P. Sweatman Nov 01
        if ($doc->GetTagParam($tagno, "TYPE") eq "CHOICE")
        {
            my ($eno) = $doc->GetTagParam($tagno, "ELEMENTS");
            if ($doc->GetTagParam($tagno, "OTHERFIELD") ne "-1") { $eno++; }
            $out .= " rowspan=\"" . $eno . "\"";
        }
        $out .= "><div id=\"mdsquestion\" class=\"" . $doc->GetTagParam($tagno, "CAPTSTYLE") . "\">";
        $out .= $doc->GetTagParam($tagno,                                       "CAPTION");
        $out .= "</div></td>\n";
    }
    else
    {
        $out .= $sp;
        $out .= "<div id=\"mdsquestion\" class=\"" . $doc->GetTagParam($tagno, "CAPTSTYLE") . "\">";
        $out .= $doc->GetTagParam($tagno, "CAPTION") . "</div>\n";
    }

    return $out;
}

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("DISPLAY ERROR 1, A SYSTEM ERROR HAS OCCURED") . "]</i></b> ";
            print lprint(
"You should never have to see this, since the system error should be printed before display was called. ");
            $found = 1;
        }

        if ($e eq 2)
        {
            print "<b><i>[" . lprint("DISPLAY ERROR 2, NO TAGS TO PRINT") . "]</i></b> ";
            print lprint("There are no component tags in the document, therefore display is impossible. ");
            $found = 1;
        }

        if ($e eq 3)
        {
            print "<b><i>[" . lprint("DISPLAY ERROR 3, UNKOWN TAG TYPE") . "]</i></b> ";
            print lprint(
                "This error should never happen. The display module encountered a tag it did not know how to handle. ");
            print lprint("(this should have been taken care of by the document parser)");
            $found = 1;
        }
        if ($e eq 4)
        {
            print "<b><i>[" . lprint("DISPLAY ERROR 4, HAS ALREADY ANSWERED") . "]</i></b> ";
            print lprint(
                 "The UNIQUE parameter is set in the SURVEY tag. This means each user can only answer the survey once. "
            );
            print lprint("A user authenticated as you has already answered the survey. ");
            $found = 1;
        }
        if ($e eq 5)
        {
            print "<b><i>[" . lprint("DISPLAY ERROR 5, PART OF MULTIPAGE SEQUENCE") . "]</i></b> ";
            print lprint("The system expected to have gotten data from a previous page in a multipage sequence. ");
            print lprint(
                       "The survey file you tried to access cannot be answered without going through the whole chain.");
            $found = 1;
        }
        if ($e eq 6)
        {
            print "<b><i>[" . lprint("DISPLAY ERROR 5, THEME IS DEPRECATED") . "]</i></b> ";
            print lprint("The theme engine has been reworked. Theme can either be \"cleanhtml\" which will do a ");
            print lprint("table layout, or \"external\" for layouting with a custom stylesheet.");
            $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("DISPLAY 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;