"Fossies" - the Fresh Open Source Software archive

Member "modsurvey-3.2.6/Survey/Component/List.pm" of archive modsurvey-3.2.6.tgz:

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

@Survey::Component::List::ISA = qw(Survey::Component::Component);

use Survey::Language;
use Text::ParseWords;
use Survey::Debug;
use Survey::Template;
use CGI;

sub FillParams
{
    my ($crap, $self) = @_;
    @{ $self->{"ALLOWED_LIST"} } =
      ("NAME", "VISIBLELEN", "MUSTANSWER", "NUMERICAL", "CAPTION", "CAPTSTYLE", "STYLE", "ILLEGALVAL", "RANDOM");
    @{ $self->{"ALL_LIST"} } = (@{ $self->{"ALLOWED_LIST"} }, "RAW", "MAXLEN", "ELEMENTS", "TYPE", "MAXLEN", "FILE");

    @{ $self->{"ALLOWED_LISTELEMENT"} } = ("SELECTED", "CAPTION", "VALUE");
    @{ $self->{"ALL_LISTELEMENT"} } = (@{ $self->{"ALLOWED_LISTELEMENT"} });

    1;
}

sub FillDefaults
{
    my ($crap, $self) = @_;

    $self->{"LIST_TYPE"}       = "LIST";
    $self->{"LIST_NAME"}       = "";
    $self->{"LIST_MAXLEN"}     = "80";
    $self->{"LIST_VISIBLELEN"} = "5";
    $self->{"LIST_MUSTANSWER"} = "no";
    $self->{"LIST_NUMERICAL"}  = "no";
    $self->{"LIST_CAPTION"}    = "";
    $self->{"LIST_CAPTSTYLE"}  = "";       #"LISTcap";
    $self->{"LIST_STYLE"}      = "";       #"LISTelm";
    $self->{"LIST_ILLEGALVAL"} = "-1";
    $self->{"LIST_RANDOM"}     = "no";

    1;
}

sub PlaceComponent
{
    my ($crap, $self, $paramstr) = @_;

    my ($tn) = "TAG" . $self->{NUMTAGS} . "_";

    my (%params, %epara, $cell, $name, $value, @pararr, $work, $tag, $s, $e, $elems);

    %params = $self->GetDefaults("LIST");

    @pararr = @{$paramstr};

    foreach $cell (@pararr)
    {
        ($name, $value) = split(/=/, $cell);
        $params{$name} = $value;
        $self->CheckParam($name, "LIST");
    }

    #bugant: fix for session loading values
    $params{FILE} = $self->{FILE};

    if ($params{empty} eq "yes")
    {
        $self->{ERROR}     = lprint("A LIST tag cannot be immediately terminated (in ") . $self->{FILE} . ")";
        $self->{ERRORCODE} = 10;
    }

    if ((!$self->{ERROR}) && (!$params{NAME}))
    {
        $self->{ERROR}     = lprint("A LIST tag must have a name (in ") . $self->{FILE} . ")";
        $self->{ERRORCODE} = 12;
    }

    if ((!$self->{ERROR}) && (length($params{NAME}) > 8))
    {
        $self->{ERROR}     = lprint("A LIST tag name can only be 8 characters wide (in ") . $self->{FILE} . ")";
        $self->{ERRORCODE} = 21;
    }

    if (!$self->{ERROR}) { $self->CheckName($params{NAME}, "LIST"); }

    if (!$self->{ERROR})
    {
        my ($endtag) = index($self->{WORK}, "</LIST>");
        if ($endtag eq 0)
        {
            $self->{ERROR}     = lprint("A LIST tag must contain at least one LISTELEMENT (in ") . $self->{FILE} . ")";
            $self->{ERRORCODE} = 17;
        }
        else
        {
            if ($endtag > 0)
            {
                $params{"RAW"} = substr($self->{WORK}, 0, $endtag - 1);
                $self->{WORK} = substr($self->{WORK}, 0 - length($self->{WORK}) + length($params{"RAW"}) + 8);
            }
            else
            {
                $self->{ERROR}     = lprint("A LIST tag must have an end tag (in ") . $self->{FILE} . ")";
                $self->{ERRORCODE} = 14;
            }
        }
    }

    if (!$self->{ERROR})
    {
        $elems = 0;
        $work  = $params{"RAW"};
        $s     = index($work, "<");
        $e     = index($work, ">");

        $params{"MAXLEN"} = 0;

        while (($s ne -1) && ($e ne -1) && (!$self->{ERROR}))
        {
            if ($s) { $e = $e - $s }
            $tag = substr($work, $s, $e + 1);
            if ($s)
            {
                $work = substr($work, 0 - length($work) + $s);
            }
            $work = substr($work, 0 - length($work) + length($tag));
            ($cell, $tag) = $self->CleanUpTag($tag);

            if (($cell ne "LISTELEMENT") && ($cell ne "DBLISTELEMENT"))
            {
                $self->{ERROR}     = lprint("A LIST block can only contain LISTELEMENTs (in ") . $self->{FILE} . ")";
                $self->{ERRORCODE} = 18;
            }

            if ($cell eq "LISTELEMENT")
            {
                $epara{"VALUE"}    = "";
                $epara{"SELECTED"} = "no";
                $epara{"CAPTION"}  = "";

                @pararr = @{$tag};
                foreach $cell (@pararr)
                {
                    ($name, $value) = split(/=/, $cell);
                    $epara{$name} = $value;
                }

                if ($epara{"empty"} eq "no")
                {
                    $self->{ERROR} =
                      lprint("A LISTELEMENT tag must be terminated immediately (in ") . $self->{FILE} . ")";
                    $self->{ERRORCODE} = 11;
                }
                if ($epara{"CAPTION"} eq "")
                {
                    $self->{ERROR}     = lprint("A LISTELEMENT must be given a caption (in ") . $self->{FILE} . ")";
                    $self->{ERRORCODE} = 19;
                }
                if (($params{"NUMERICAL"} eq "yes") && (int($epara{"VALUE"}) ne $epara{"VALUE"}))
                {
                    $self->{ERROR} =
                      lprint("A LISTELEMENT must be given a numerical value when NUMERICAL is yes in LIST.");
                    $self->{ERRORCODE} = 31;
                }
                else
                {
                    if ($epara{"VALUE"} eq "") { $epara{"VALUE"} = $epara{"CAPTION"}; }
                }

                if (!$self->{ERROR})
                {
                    $s = $tn . "LE" . $elems . "_";

                    if (length($epara{"CAPTION"}) > $params{"MAXLEN"})
                    {
                        $params{"MAXLEN"} = length($epara{"CAPTION"});
                    }

                    $self->{ $s . "CAPTION" }  = $epara{"CAPTION"};
                    $self->{ $s . "SELECTED" } = $epara{"SELECTED"};
                    $self->{ $s . "VALUE" }    = $epara{"VALUE"};

                    $elems++;
                }
            }

            if ($cell eq "DBLISTELEMENT")
            {
                $epara{"VALUEARRAY"}   = "";
                $epara{"CAPTIONARRAY"} = "";

                @pararr = @{$tag};
                foreach $cell (@pararr)
                {
                    ($name, $value) = split(/=/, $cell);
                    $epara{$name} = $value;
                }

                if ($epara{"empty"} eq "no")
                {
                    $self->{ERROR}     = lprint("A DBLISTELEMENT tag must be terminated immediately.");
                    $self->{ERRORCODE} = 11;
                }

                if (!$self->{ERROR})
                {
                    my ($ses) = $self->{SESSION};

                    if (!$epara{"CAPTIONARRAY"})
                    {
                        $self->{ERROR}     = lprint("CAPTIONARRAY is a required parameter in DBLISTELEMENT.");
                        $self->{ERRORCODE} = 99;
                    }

                    my ($cpt) = $ses->getArrayValue($epara{"CAPTIONARRAY"});

                    if (!$cpt)
                    {
                        $self->{ERROR}     = lprint("No such array: ") . $epara{"CAPTIONARRAY"};
                        $self->{ERRORCODE} = 50;
                    }

                    my ($vals, @vala);

                    if ($epara{"VALUEARRAY"})
                    {
                        my ($vals) = $ses->getArrayValue($epara{"VALUEARRAY"});

                        if (!$vals)
                        {
                            $self->{ERROR}     = lprint("No such array: ") . $epara{"VALUEARRAY"};
                            $self->{ERRORCODE} = 50;
                        }
                        else
                        {
                            @vala = @{$vals};
                        }
                    }

                    # iterate over contents of array
                    if ($cpt && !$self->{ERROR})
                    {
                        my (@cpta) = @{$cpt};
                        if ((scalar(@cpta) < 1) && defined($cpt))
                        {
                            $self->{ERROR}     = lprint("Array has zero length: ") . $epara{"CAPTIONARRAY"};
                            $self->{ERRORCODE} = 99;
                        }

                        if (@vala)
                        {
                            if ((scalar(@vala) < 1) && defined($vals))
                            {
                                $self->{ERROR}     = lprint("Array has zero length: ") . $epara{"VALUEARRAY"};
                                $self->{ERRORCODE} = 99;
                            }
                            else
                            {
                                if (scalar(@vala) != scalar(@cpta))
                                {
                                    $self->{ERROR} =
                                        lprint("Lengths of arrays differ: ")
                                      . $epara{"VALUEARRAY"} . " != "
                                      . $epara{"CAPTIONARRAY"};
                                    $self->{ERRORCODE} = 99;
                                }
                            }
                        }

                        for (my ($i) = 0 ; $i < scalar(@cpta) ; $i++)
                        {
                            $epara{"CAPTION"} = $cpta[$i];

                            if (!@vala)
                            {
                                $epara{"VALUE"} = $cpta[$i];
                            }
                            else
                            {
                                $epara{"VALUE"} = $vala[$i];
                            }

                            $s = $tn . "LE" . $elems . "_";

                            if (length($epara{"CAPTION"}) > $params{"MAXLEN"})
                            {
                                $params{"MAXLEN"} = length($epara{"CAPTION"});
                            }

                            $self->{ $s . "CAPTION" }  = $epara{"CAPTION"};
                            $self->{ $s . "SELECTED" } = "no";
                            $self->{ $s . "VALUE" }    = $epara{"VALUE"};

                            $elems++;
                        }
                    }
                }
            }

            $s = index($work, "<");
            $e = index($work, ">");
        }
        $params{"ELEMENTS"} = $elems;
    }

    if (($elems eq 0) && (!$self->{ERROR}))
    {
        $self->{ERROR}     = lprint("A LIST tag must contain at least one LISTELEMENT (in ") . $self->{FILE} . ")";
        $self->{ERRORCODE} = 17;
    }

    $name = "TAGNAME_" . $params{"NAME"};
    $name = "\U$name";

    if (defined($self->{$name}))
    {
        $self->{ERROR}     = lprint("A LIST tag must have unique name (in ") . $self->{FILE} . ")";
        $self->{ERRORCODE} = 20;
    }
    else
    {
        $self->{$name} = $self->{NUMTAGS};
    }

    $self->PlaceParams("LIST", $tn, %params);

    $self->{NUMTAGS}++;

    1;
}

sub PrintComponent
{
    my ($crap, $self, $tagno) = @_;
    my ($doc) = $self->{DOCUMENT};
    my ($eno) = $doc->GetTagParam($tagno, "ELEMENTS");
    my $ses   = $doc->{SESSION};

    $doc->SetVisited($doc->GetTagParam($tagno, "NAME"));

    my $tmpl = new Survey::Template($ENV{_SURVEY_HOME} . "/templates/default/List.tmpl");

    my $thistagname = $doc->GetTagParam($tagno, "NAME");
    my $valueErrorDescription = $ses->getValue("VALUE_ERROR_DESCRIPTION_$thistagname");

    if ($valueErrorDescription)
    {
        $tmpl->setVar("errorDescription", $valueErrorDescription);

        $ses->setValue("VALUE_ERROR_$thistagname",             "");
        $ses->setValue("VALUE_ERROR_DESCRIPTION_$thistagname", "");
    }

    $tmpl->setVar("captStyle", $doc->GetTagParam($tagno, "CAPTSTYLE"));
    $tmpl->setVar("caption",   $doc->GetTagParam($tagno, "CAPTION"));

    $tmpl->setVar("style", $doc->GetTagParam($tagno, "STYLE"));

    $tmpl->setVar("name", $doc->GetTagParam($tagno, "NAME"));
    $tmpl->setVar("size", $doc->GetTagParam($tagno, "VISIBLELEN"));

    #bugant persist ;)
    my ($chkpersist) = ($doc->{SESSION}->getValue("SUBMITTED_$thistagname"));

    #bugant persisted ;)

    # added in CRU patch (MJ/20020802)
    my $numSelected;

    if ($self->{RETRIEVE})
    {
        my $tablenum = $tagno + 1;
        my $sql = "SELECT " . $doc->GetTagParam($tagno, "NAME") . " FROM " . $doc->GetOption("DBITABLE");
        $sql .= " WHERE mail=\'";

        if ($doc->GetOption("REQAUTH") eq "soap")
        {
            $sql .= $doc->{EMAIL};
        }
        else
        {
            $sql .= $doc->{REMOTE_USER};
        }
        $sql .= "\' AND save_partial=\'1\'";
        my $sth = $self->{DBH}->prepare($sql);
        $sth->execute;
        ($numSelected) = $sth->fetchrow_array();
    }

    # added in CRU patch (MJ/20020802)

    if ($doc->GetTagParam($tagno, "RANDOM") eq "yes") { $tmpl->enterLoop("LOOP", "random"); }

    else { $tmpl->enterLoop("LOOP"); }

    for (my $i = 0 ; $i < $eno ; $i++)
    {

        #bugant persist ;)
        if ($chkpersist eq $doc->GetListElementParam($tagno, $i, "VALUE"))
        {
            $tmpl->setVar("selected", 1);
        }
        else
        {
            if ($doc->GetListElementParam($tagno, $i, "SELECTED") eq "yes")
            {
                $tmpl->setVar("selected", 1);
            }
        }

        #bugant persisted ;)

        $tmpl->setVar("value",   $doc->GetListElementParam($tagno, $i, "VALUE"));
        $tmpl->setVar("caption", $doc->GetListElementParam($tagno, $i, "CAPTION"));

        $tmpl->nextLoop();    # LOOP
    }
    $tmpl->exitLoop();        # LOOP

    return $tmpl->get();
}

sub NumberOfValues
{
    my ($self, $doc, $sub, $arg, $ses, $tagno) = @_;
    return 1;
}

sub GetValueNumerical
{
    my ($self, $doc, $sub, $arg, $ses, $tagno) = @_;
    if ($doc->GetTagParam($tagno, "NUMERICAL") eq "yes")
    {
        return 1;
    }
    else
    {
        return 0;
    }
}

sub GetCaptionByValue
{
    my ($s, $doc, $sub, $arg, $ses, $tagno, $value) = @_;

    my ($cap) = "";
    my ($i);

    for ($i = 0 ; $i < $doc->GetTagParam($tagno, "ELEMENTS") ; $i++)
    {
        my ($val) = $doc->GetListElementParam($tagno, $i, "VALUE");
        if ($val eq $value)
        {
            $cap = $doc->GetListElementParam($tagno, $i, "CAPTION");
        }
    }

    return $cap;
}

sub GetCheckValue
{
    my ($s, $doc, $sub, $arg, $ses, $tagno, $valuenumber) = @_;

    my ($value) = {};
    my ($name) = $doc->GetTagParam($tagno, "NAME");

    my ($visited) = $doc->CheckVisited($name);

    if ($visited)
    {
        if   (defined($arg->ArgByName($name))) { $value->{VALUE} = $arg->ArgByName($name); }
        else                                   { $value->{VALUE} = ""; }
    }
    else
    {
        $value->{VALUE} = $doc->GetOption("NOTDISPLAYEDVAL");
    }

    if ($value->{VALUE} eq "")
    {
        if (($doc->GetTagParam($tagno, "MUSTANSWER") eq "yes") && (!$sub->{SAVE}))
        {
            $sub->{ERROR} =
                lprint("The question with caption") 
              . " <i>\""
              . $doc->GetTagParam($tagno, "CAPTION")
              . "\"</i> "
              . lprint("must be answered.");
            $sub->{ERRORCODE} = 2;
        }
        else
        {
            $value = $doc->GetTagParam($tagno, "ILLEGALVAL");
        }
    }

    $value->{NAME}      = $name;
    $value->{NUMERICAL} = Survey::Component::List->GetValueNumerical($doc, $sub, $arg, $ses, $tagno);
    $value->{CAPTION}   = Survey::Component::List->GetCaptionByValue($doc, $sub, $arg, $ses, $tagno, $value->{VALUE});

    return $value;
}

sub GetValueCaption
{
    my ($s, $doc, $sub, $arg, $ses, $tagno, $value) = @_;

    my ($caption) = "[illegal]";

    my ($elems) = $doc->GetTagParam($tagno, "ELEMENTS");
    for (my ($i) = 0 ; $i < $elems ; $i++)
    {
        my ($evalue) = $doc->GetListElementParam($tagno, $i, "VALUE");
        if ($evalue eq $value)
        {
            $caption = $doc->GetListElementParam($tagno, $i, "CAPTION");
        }
    }

    return $caption;
}

sub GetPossibleValues
{
    my ($s, $doc, $sub, $arg, $ses, $tagno) = @_;
    my (@arr) = ();

    my ($elems) = $doc->GetTagParam($tagno, "ELEMENTS");
    for (my ($i) = 0 ; $i < $elems ; $i++)
    {
        my ($evalue) = $doc->GetListElementParam($tagno, $i, "VALUE");
        if (defined($evalue) && ($evalue ne ""))
        {
            my ($entha) = {};
            $entha->{VALUE} = $evalue;
            $entha->{CAPTION} = $doc->GetListElementParam($tagno, $i, "CAPTION");

            push(@arr, $entha);
        }
    }

    return \@arr;
}

sub MakeXML
{
    my ($s, $doc, $tagno) = @_;

    my ($out) = $s->MakeTagOpener($doc, $tagno);

    my ($elems) = $doc->GetTagParam($tagno, "ELEMENTS");
    for (my ($i) = 0 ; $i < $elems ; $i++)
    {
        my ($evalue) = $doc->GetListElementParam($tagno, $i, "VALUE");
        my ($ecapt)  = $doc->GetListElementParam($tagno, $i, "CAPTION");
        my ($echeck) = $doc->GetListElementParam($tagno, $i, "SELECTED");

        my ($val, $cap, $check);
        $val = "VALUE=\"$evalue\"";
        $cap = "CAPTION=\"$ecapt\"";
        if ($echeck ne "no")
        {
            $check = "SELECTED=\"yes\"";
        }
        else
        {
            $check = "";
        }
        $out .= "  <LISTELEMENT $cap $val $check />\n";
    }

    $out .= $s->MakeTagCloser($doc, $tagno);

    return $out;
}

1;