953 lines
31 KiB
Perl
953 lines
31 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
|
||
|
|
package LJ::Poll;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use HTML::TokeParser ();
|
||
|
|
|
||
|
|
require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
|
||
|
|
|
||
|
|
sub clean_poll
|
||
|
|
{
|
||
|
|
my $ref = shift;
|
||
|
|
if ($$ref !~ /[<>]/) {
|
||
|
|
LJ::text_out($ref);
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $poll_eat = [qw[head title style layer iframe applet object]];
|
||
|
|
my $poll_allow = [qw[a b i u strong em img]];
|
||
|
|
my $poll_remove = [qw[bgsound embed object caption link font]];
|
||
|
|
|
||
|
|
LJ::CleanHTML::clean($ref, {
|
||
|
|
'wordlength' => 40,
|
||
|
|
'addbreaks' => 0,
|
||
|
|
'eat' => $poll_eat,
|
||
|
|
'mode' => 'deny',
|
||
|
|
'allow' => $poll_allow,
|
||
|
|
'remove' => $poll_remove,
|
||
|
|
});
|
||
|
|
LJ::text_out($ref);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub contains_new_poll
|
||
|
|
{
|
||
|
|
my $postref = shift;
|
||
|
|
return ($$postref =~ /<lj-poll\b/i);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub parse
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
my ($postref, $error, $iteminfo) = @_;
|
||
|
|
|
||
|
|
$iteminfo->{'posterid'} += 0;
|
||
|
|
$iteminfo->{'journalid'} += 0;
|
||
|
|
|
||
|
|
my $newdata;
|
||
|
|
|
||
|
|
my $popen = 0;
|
||
|
|
my %popts;
|
||
|
|
|
||
|
|
my $qopen = 0;
|
||
|
|
my %qopts;
|
||
|
|
|
||
|
|
my $iopen = 0;
|
||
|
|
my %iopts;
|
||
|
|
|
||
|
|
my @polls; # completed parsed polls
|
||
|
|
|
||
|
|
my $p = HTML::TokeParser->new($postref);
|
||
|
|
|
||
|
|
# if we're being called from mailgated, then we're not in web context and therefore
|
||
|
|
# do not have any BML::ml functionality. detect this now and report errors in a
|
||
|
|
# plaintext, non-translated form to be bounced via email.
|
||
|
|
my $have_bml = eval { BML::ml() } || ! $@;
|
||
|
|
|
||
|
|
my $err = sub {
|
||
|
|
# more than one element, either make a call to BML::ml
|
||
|
|
# or build up a semi-useful error string from it
|
||
|
|
if (@_ > 1) {
|
||
|
|
if ($have_bml) {
|
||
|
|
$$error = BML::ml(@_);
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
$$error = shift() . ": ";
|
||
|
|
while (my ($k, $v) = each %{$_[0]}) {
|
||
|
|
$$error .= "$k=$v,";
|
||
|
|
}
|
||
|
|
chop $$error;
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# single element, either look up in %BML::ML or return verbatim
|
||
|
|
$$error = $have_bml ? $BML::ML{$_[0]} : $_[0];
|
||
|
|
return 0;
|
||
|
|
};
|
||
|
|
|
||
|
|
while (my $token = $p->get_token)
|
||
|
|
{
|
||
|
|
my $type = $token->[0];
|
||
|
|
my $append;
|
||
|
|
|
||
|
|
if ($type eq "S") # start tag
|
||
|
|
{
|
||
|
|
my $tag = $token->[1];
|
||
|
|
my $opts = $token->[2];
|
||
|
|
|
||
|
|
######## Begin poll tag
|
||
|
|
|
||
|
|
if ($tag eq "lj-poll") {
|
||
|
|
return $err->('poll.error.nested', { 'tag' => 'lj-poll' })
|
||
|
|
if $popen;
|
||
|
|
|
||
|
|
$popen = 1;
|
||
|
|
%popts = ();
|
||
|
|
$popts{'questions'} = [];
|
||
|
|
|
||
|
|
$popts{'name'} = $opts->{'name'};
|
||
|
|
$popts{'whovote'} = lc($opts->{'whovote'}) || "all";
|
||
|
|
$popts{'whoview'} = lc($opts->{'whoview'}) || "all";
|
||
|
|
|
||
|
|
if ($popts{'whovote'} ne "all" &&
|
||
|
|
$popts{'whovote'} ne "friends")
|
||
|
|
{
|
||
|
|
return $err->('poll.error.whovote');
|
||
|
|
}
|
||
|
|
if ($popts{'whoview'} ne "all" &&
|
||
|
|
$popts{'whoview'} ne "friends" &&
|
||
|
|
$popts{'whoview'} ne "none")
|
||
|
|
{
|
||
|
|
return $err->('poll.error.whoview');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
######## Begin poll question tag
|
||
|
|
|
||
|
|
elsif ($tag eq "lj-pq")
|
||
|
|
{
|
||
|
|
return $err->('poll.error.nested', { 'tag' => 'lj-pq' })
|
||
|
|
if $qopen;
|
||
|
|
|
||
|
|
return $err->('poll.error.missingljpoll')
|
||
|
|
unless $popen;
|
||
|
|
|
||
|
|
$qopen = 1;
|
||
|
|
%qopts = ();
|
||
|
|
$qopts{'items'} = [];
|
||
|
|
|
||
|
|
$qopts{'type'} = $opts->{'type'};
|
||
|
|
if ($qopts{'type'} eq "text") {
|
||
|
|
my $size = 35;
|
||
|
|
my $max = 255;
|
||
|
|
if (defined $opts->{'size'}) {
|
||
|
|
if ($opts->{'size'} > 0 &&
|
||
|
|
$opts->{'size'} <= 100)
|
||
|
|
{
|
||
|
|
$size = $opts->{'size'}+0;
|
||
|
|
} else {
|
||
|
|
return $err->('poll.error.badsize');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (defined $opts->{'maxlength'}) {
|
||
|
|
if ($opts->{'maxlength'} > 0 &&
|
||
|
|
$opts->{'maxlength'} <= 255)
|
||
|
|
{
|
||
|
|
$max = $opts->{'maxlength'}+0;
|
||
|
|
} else {
|
||
|
|
return $err->('poll.error.badmaxlength');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$qopts{'opts'} = "$size/$max";
|
||
|
|
}
|
||
|
|
if ($qopts{'type'} eq "scale")
|
||
|
|
{
|
||
|
|
my $from = 1;
|
||
|
|
my $to = 10;
|
||
|
|
my $by = 1;
|
||
|
|
|
||
|
|
if (defined $opts->{'from'}) {
|
||
|
|
$from = int($opts->{'from'});
|
||
|
|
}
|
||
|
|
if (defined $opts->{'to'}) {
|
||
|
|
$to = int($opts->{'to'});
|
||
|
|
}
|
||
|
|
if (defined $opts->{'by'}) {
|
||
|
|
$by = int($opts->{'by'});
|
||
|
|
}
|
||
|
|
if ($by < 1) {
|
||
|
|
return $err->('poll.error.scaleincrement');
|
||
|
|
}
|
||
|
|
if ($from >= $to) {
|
||
|
|
return $err->('poll.error.scalelessto');
|
||
|
|
}
|
||
|
|
if ((($to-$from)/$by) > 20) {
|
||
|
|
return $err->('poll.error.scaletoobig');
|
||
|
|
}
|
||
|
|
$qopts{'opts'} = "$from/$to/$by";
|
||
|
|
}
|
||
|
|
|
||
|
|
$qopts{'type'} = lc($opts->{'type'}) || "text";
|
||
|
|
|
||
|
|
if ($qopts{'type'} ne "radio" &&
|
||
|
|
$qopts{'type'} ne "check" &&
|
||
|
|
$qopts{'type'} ne "drop" &&
|
||
|
|
$qopts{'type'} ne "scale" &&
|
||
|
|
$qopts{'type'} ne "text")
|
||
|
|
{
|
||
|
|
return $err->('poll.error.unknownpqtype');
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
######## Begin poll item tag
|
||
|
|
|
||
|
|
elsif ($tag eq "lj-pi")
|
||
|
|
{
|
||
|
|
if ($iopen) {
|
||
|
|
return $err->('poll.error.nested', { 'tag' => 'lj-pi' });
|
||
|
|
}
|
||
|
|
if (! $qopen) {
|
||
|
|
return $err->('poll.error.missingljpq');
|
||
|
|
}
|
||
|
|
if ($qopts{'type'} eq "text")
|
||
|
|
{
|
||
|
|
return $err->('poll.error.noitemstext');
|
||
|
|
}
|
||
|
|
|
||
|
|
$iopen = 1;
|
||
|
|
%iopts = ();
|
||
|
|
}
|
||
|
|
|
||
|
|
#### not a special tag. dump it right back out.
|
||
|
|
|
||
|
|
else
|
||
|
|
{
|
||
|
|
$append .= "<$tag";
|
||
|
|
foreach (keys %$opts) {
|
||
|
|
$append .= " $_=\"$opts->{$_}\"";
|
||
|
|
}
|
||
|
|
$append .= ">";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ($type eq "E")
|
||
|
|
{
|
||
|
|
my $tag = $token->[1];
|
||
|
|
|
||
|
|
##### end POLL
|
||
|
|
|
||
|
|
if ($tag eq "lj-poll") {
|
||
|
|
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-poll' })
|
||
|
|
unless $popen;
|
||
|
|
|
||
|
|
$popen = 0;
|
||
|
|
|
||
|
|
return $err->('poll.error.noquestions')
|
||
|
|
unless @{$popts{'questions'}};
|
||
|
|
|
||
|
|
$popts{'journalid'} = $iteminfo->{'journalid'};
|
||
|
|
$popts{'posterid'} = $iteminfo->{'posterid'};
|
||
|
|
|
||
|
|
push @polls, { %popts };
|
||
|
|
|
||
|
|
$append .= "<lj-poll-placeholder>";
|
||
|
|
}
|
||
|
|
|
||
|
|
##### end QUESTION
|
||
|
|
|
||
|
|
elsif ($tag eq "lj-pq") {
|
||
|
|
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pq' })
|
||
|
|
unless $qopen;
|
||
|
|
|
||
|
|
unless ($qopts{'type'} eq "scale" ||
|
||
|
|
$qopts{'type'} eq "text" ||
|
||
|
|
@{$qopts{'items'}})
|
||
|
|
{
|
||
|
|
return $err->('poll.error.noitems');
|
||
|
|
}
|
||
|
|
|
||
|
|
$qopts{'qtext'} =~ s/^\s+//;
|
||
|
|
$qopts{'qtext'} =~ s/\s+$//;
|
||
|
|
my $len = length($qopts{'qtext'})
|
||
|
|
or return $err->('poll.error.notext');
|
||
|
|
|
||
|
|
push @{$popts{'questions'}}, { %qopts };
|
||
|
|
$qopen = 0;
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
##### end ITEM
|
||
|
|
|
||
|
|
elsif ($tag eq "lj-pi") {
|
||
|
|
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pi' })
|
||
|
|
unless $iopen;
|
||
|
|
|
||
|
|
$iopts{'item'} =~ s/^\s+//;
|
||
|
|
$iopts{'item'} =~ s/\s+$//;
|
||
|
|
|
||
|
|
my $len = length($iopts{'item'});
|
||
|
|
return $err->('poll.error.pitoolong', { 'len' => $len, })
|
||
|
|
if $len > 255 || $len < 1;
|
||
|
|
|
||
|
|
push @{$qopts{'items'}}, { %iopts };
|
||
|
|
$iopen = 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
###### not a special tag.
|
||
|
|
|
||
|
|
else
|
||
|
|
{
|
||
|
|
$append .= "</$tag>";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ($type eq "T" || $type eq "D")
|
||
|
|
{
|
||
|
|
$append = $token->[1];
|
||
|
|
}
|
||
|
|
elsif ($type eq "C") {
|
||
|
|
# ignore comments
|
||
|
|
}
|
||
|
|
elsif ($type eq "PI") {
|
||
|
|
$newdata .= "<?$token->[1]>";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$newdata .= "<!-- OTHER: " . $type . "-->\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
##### append stuff to the right place
|
||
|
|
if (length($append))
|
||
|
|
{
|
||
|
|
if ($iopen) {
|
||
|
|
$iopts{'item'} .= $append;
|
||
|
|
}
|
||
|
|
elsif ($qopen) {
|
||
|
|
$qopts{'qtext'} .= $append;
|
||
|
|
}
|
||
|
|
elsif ($popen) {
|
||
|
|
0; # do nothing.
|
||
|
|
} else {
|
||
|
|
$newdata .= $append;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($popen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-poll' }); }
|
||
|
|
if ($qopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pq' }); }
|
||
|
|
if ($iopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pi' }); }
|
||
|
|
|
||
|
|
$$postref = $newdata;
|
||
|
|
return @polls;
|
||
|
|
}
|
||
|
|
|
||
|
|
# preview poll
|
||
|
|
# -- accepts $poll hashref as found in the array returned by LJ::Poll::parse()
|
||
|
|
sub preview {
|
||
|
|
my $poll = shift;
|
||
|
|
return unless ref $poll eq 'HASH';
|
||
|
|
|
||
|
|
my $ret = '';
|
||
|
|
|
||
|
|
$ret .= "<form action='#'>\n";
|
||
|
|
$ret .= "<b>" . BML::ml('poll.pollnum', { 'num' => 'xxxx' }) . "</b>";
|
||
|
|
if ($poll->{'name'}) {
|
||
|
|
LJ::Poll::clean_poll(\$poll->{'name'});
|
||
|
|
$ret .= " <i>$poll->{'name'}</i>";
|
||
|
|
}
|
||
|
|
$ret .= "<br />\n";
|
||
|
|
$ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$poll->{whovote}}, 'whoview' => $BML::ML{'poll.security.'.$poll->{whoview}}, });
|
||
|
|
|
||
|
|
# iterate through all questions
|
||
|
|
foreach my $q (@{$poll->{'questions'}}) {
|
||
|
|
if ($q->{'qtext'}) {
|
||
|
|
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||
|
|
$ret .= "<p>$q->{'qtext'}</p>\n";
|
||
|
|
}
|
||
|
|
$ret .= "<div style='margin: 10px 0 10px 40px'>";
|
||
|
|
|
||
|
|
# text questions
|
||
|
|
if ($q->{'type'} eq 'text') {
|
||
|
|
my ($size, $max) = split(m!/!, $q->{'opts'});
|
||
|
|
$ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max });
|
||
|
|
|
||
|
|
# scale questions
|
||
|
|
} elsif ($q->{'type'} eq 'scale') {
|
||
|
|
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||
|
|
$by ||= 1;
|
||
|
|
my $count = int(($to-$from)/$by) + 1;
|
||
|
|
my $do_radios = ($count <= 11);
|
||
|
|
|
||
|
|
# few opts, display radios
|
||
|
|
if ($do_radios) {
|
||
|
|
$ret .= "<table><tr valign='top' align='center'>\n";
|
||
|
|
for (my $at = $from; $at <= $to; $at += $by) {
|
||
|
|
$ret .= "<td>" . LJ::html_check({ 'type' => 'radio' }) . "<br />$at</td>\n";
|
||
|
|
}
|
||
|
|
$ret .= "</tr></table>\n";
|
||
|
|
|
||
|
|
# many opts, display select
|
||
|
|
} else {
|
||
|
|
my @optlist = ();
|
||
|
|
for (my $at = $from; $at <= $to; $at += $by) {
|
||
|
|
push @optlist, ('', $at);
|
||
|
|
}
|
||
|
|
$ret .= LJ::html_select({}, @optlist);
|
||
|
|
}
|
||
|
|
|
||
|
|
# questions with items
|
||
|
|
} else {
|
||
|
|
|
||
|
|
# drop-down list
|
||
|
|
if ($q->{'type'} eq 'drop') {
|
||
|
|
my @optlist = ('', '');
|
||
|
|
foreach my $it (@{$q->{'items'}}) {
|
||
|
|
LJ::Poll::clean_poll(\$it->{'item'});
|
||
|
|
push @optlist, ('', $it->{'item'});
|
||
|
|
}
|
||
|
|
$ret .= LJ::html_select({}, @optlist);
|
||
|
|
|
||
|
|
|
||
|
|
# radio or checkbox
|
||
|
|
} else {
|
||
|
|
foreach my $it (@{$q->{'items'}}) {
|
||
|
|
LJ::Poll::clean_poll(\$it->{'item'});
|
||
|
|
$ret .= LJ::html_check({ 'type' => $q->{'type'} }) . "$it->{'item'}<br />\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= "</div>\n";
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= LJ::html_submit('', $BML::ML{'poll.submit'}, { 'disabled' => 1 }) . "\n";
|
||
|
|
$ret .= "</form>";
|
||
|
|
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
# note: $itemid is a $ditemid (display itemid, *256 + anum)
|
||
|
|
sub register
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
my $dbh = LJ::get_db_writer();
|
||
|
|
my $post = shift;
|
||
|
|
my $error = shift;
|
||
|
|
my $itemid = shift;
|
||
|
|
my @polls = @_;
|
||
|
|
|
||
|
|
foreach my $po (@polls)
|
||
|
|
{
|
||
|
|
my %popts = %$po;
|
||
|
|
$popts{'itemid'} = $itemid+0;
|
||
|
|
|
||
|
|
#### CREATE THE POLL!
|
||
|
|
|
||
|
|
my $sth = $dbh->prepare("INSERT INTO poll (itemid, journalid, posterid, whovote, whoview, name) " .
|
||
|
|
"VALUES (?, ?, ?, ?, ?, ?)");
|
||
|
|
$sth->execute($itemid, $popts{'journalid'}, $popts{'posterid'},
|
||
|
|
$popts{'whovote'}, $popts{'whoview'}, $popts{'name'});
|
||
|
|
if ($dbh->err) {
|
||
|
|
$$error = BML::ml('poll.dberror', { errmsg => $dbh->errstr });
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
my $pollid = $dbh->{'mysql_insertid'};
|
||
|
|
|
||
|
|
$$post =~ s/<lj-poll-placeholder>/<lj-poll-$pollid>/; # NOT global replace!
|
||
|
|
|
||
|
|
## start inserting poll questions
|
||
|
|
my $qnum = 0;
|
||
|
|
foreach my $q (@{$popts{'questions'}})
|
||
|
|
{
|
||
|
|
$qnum++;
|
||
|
|
$sth = $dbh->prepare("INSERT INTO pollquestion (pollid, pollqid, sortorder, type, opts, qtext) " .
|
||
|
|
"VALUES (?, ?, ?, ?, ?, ?)");
|
||
|
|
$sth->execute($pollid, $qnum, $qnum, $q->{'type'}, $q->{'opts'}, $q->{'qtext'});
|
||
|
|
if ($dbh->err) {
|
||
|
|
$$error = BML::ml('poll.dberror.questions', { errmsg => $dbh->errstr });
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $pollqid = $dbh->{'mysql_insertid'};
|
||
|
|
|
||
|
|
## start inserting poll items
|
||
|
|
my $inum = 0;
|
||
|
|
foreach my $it (@{$q->{'items'}}) {
|
||
|
|
$inum++;
|
||
|
|
$dbh->do("INSERT INTO pollitem (pollid, pollqid, pollitid, sortorder, item) " .
|
||
|
|
"VALUES (?, ?, ?, ?, ?)", undef, $pollid, $qnum, $inum, $inum, $it->{'item'});
|
||
|
|
if ($dbh->err) {
|
||
|
|
$$error = BML::ml('poll.dberror.items', { errmsg => $dbh->errstr });
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
## end inserting poll items
|
||
|
|
|
||
|
|
}
|
||
|
|
## end inserting poll questions
|
||
|
|
|
||
|
|
} ### end while over all poles
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_polls
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
my $itemid = shift;
|
||
|
|
my $remote = shift;
|
||
|
|
my $postref = shift;
|
||
|
|
|
||
|
|
$$postref =~ s/<lj-poll-(\d+)>/&show_poll($itemid, $remote, $1)/eg;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_poll
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
my $dbr = LJ::get_db_reader();
|
||
|
|
my $itemid = shift;
|
||
|
|
my $remote = shift;
|
||
|
|
my $pollid = shift;
|
||
|
|
my $opts = shift; # hashref. {"mode" => results/enter/ans}
|
||
|
|
my $sth;
|
||
|
|
|
||
|
|
my $mode = $opts->{'mode'};
|
||
|
|
$pollid += 0;
|
||
|
|
|
||
|
|
my $po = $dbr->selectrow_hashref("SELECT * FROM poll WHERE pollid=?", undef, $pollid);
|
||
|
|
return "<b>[" . BML::ml('poll.error.pollnotfound', { 'num' => $pollid }) . "]</b>" unless $po;
|
||
|
|
return "<b>[$BML::ML{'poll.error.noentry'}]</b>"
|
||
|
|
if $itemid && $po->{'itemid'} != $itemid;
|
||
|
|
|
||
|
|
my ($can_vote, $can_view) = find_security($po, $remote);
|
||
|
|
|
||
|
|
# update the mode if we need to
|
||
|
|
$mode = 'results' unless $remote;
|
||
|
|
if (!$mode && $remote) {
|
||
|
|
my $time = $dbr->selectrow_array('SELECT datesubmit FROM pollsubmission '.
|
||
|
|
'WHERE pollid=? AND userid=?', undef, $pollid, $remote->{userid});
|
||
|
|
$mode = $time ? 'results' : $can_vote ? 'enter' : 'results';
|
||
|
|
}
|
||
|
|
|
||
|
|
### load all the questions
|
||
|
|
my @qs;
|
||
|
|
$sth = $dbr->prepare('SELECT * FROM pollquestion WHERE pollid=?');
|
||
|
|
$sth->execute($pollid);
|
||
|
|
push @qs, $_ while $_ = $sth->fetchrow_hashref;
|
||
|
|
@qs = sort { $a->{sortorder} <=> $b->{sortorder} } @qs;
|
||
|
|
|
||
|
|
### load all the items
|
||
|
|
my %its;
|
||
|
|
$sth = $dbr->prepare("SELECT pollqid, pollitid, item FROM pollitem WHERE pollid=? ORDER BY sortorder");
|
||
|
|
$sth->execute($pollid);
|
||
|
|
while (my ($qid, $itid, $item) = $sth->fetchrow_array) {
|
||
|
|
push @{$its{$qid}}, [ $itid, $item ];
|
||
|
|
}
|
||
|
|
|
||
|
|
# see if we have a hook for alternate poll contents
|
||
|
|
my $ret = LJ::run_hook('alternate_show_poll_html', $po, $mode, \@qs);
|
||
|
|
return $ret if $ret;
|
||
|
|
|
||
|
|
### view answers to a particular question in a poll
|
||
|
|
if ($mode eq "ans")
|
||
|
|
{
|
||
|
|
return "<b>[$BML::ML{'poll.error.cantview'}]</b>"
|
||
|
|
unless $can_view;
|
||
|
|
|
||
|
|
# get the question from @qs, which we loaded earlier
|
||
|
|
my $q;
|
||
|
|
foreach (@qs) {
|
||
|
|
$q = $_ if $_->{pollqid} == $opts->{qid};
|
||
|
|
}
|
||
|
|
return "<b>[$BML::ML{'poll.error.questionnotfound'}]</b>"
|
||
|
|
unless $q;
|
||
|
|
|
||
|
|
# get the item information from %its, also loaded earlier
|
||
|
|
my %it;
|
||
|
|
$it{$_->[0]} = $_->[1] foreach (@{$its{$opts->{qid}}});
|
||
|
|
|
||
|
|
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||
|
|
$ret .= $q->{'qtext'};
|
||
|
|
$ret .= "<p>";
|
||
|
|
|
||
|
|
my $LIMIT = 2000;
|
||
|
|
$sth = $dbr->prepare("SELECT u.user, pr.value, ps.datesubmit ".
|
||
|
|
"FROM useridmap u, pollresult pr, pollsubmission ps " .
|
||
|
|
"WHERE u.userid=pr.userid AND pr.pollid=? AND pollqid=? " .
|
||
|
|
"AND ps.pollid=pr.pollid AND ps.userid=pr.userid LIMIT $LIMIT");
|
||
|
|
$sth->execute($pollid, $opts->{'qid'});
|
||
|
|
|
||
|
|
my @res;
|
||
|
|
push @res, $_ while $_ = $sth->fetchrow_hashref;
|
||
|
|
@res = sort { $a->{datesubmit} cmp $b->{datesubmit} } @res;
|
||
|
|
|
||
|
|
foreach my $res (@res) {
|
||
|
|
my ($user, $value) = ($res->{user}, $res->{value});
|
||
|
|
|
||
|
|
## some question types need translation; type 'text' doesn't.
|
||
|
|
if ($q->{'type'} eq "radio" || $q->{'type'} eq "drop") {
|
||
|
|
$value = $it{$value};
|
||
|
|
}
|
||
|
|
elsif ($q->{'type'} eq "check") {
|
||
|
|
$value = join(", ", map { $it{$_} } split(/,/, $value));
|
||
|
|
}
|
||
|
|
|
||
|
|
LJ::Poll::clean_poll(\$value);
|
||
|
|
$ret .= "<p>" . LJ::ljuser($user) . " -- $value</p>\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
# temporary
|
||
|
|
if (@res == $LIMIT) {
|
||
|
|
$ret .= "<p>[$BML::ML{'poll.error.truncated'}]</p>";
|
||
|
|
}
|
||
|
|
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Users cannot vote unless they are logged in
|
||
|
|
return "<?needlogin?>"
|
||
|
|
if $mode eq 'enter' && !$remote;
|
||
|
|
|
||
|
|
my $do_form = $mode eq 'enter' && $can_vote;
|
||
|
|
my %preval;
|
||
|
|
|
||
|
|
if ($do_form) {
|
||
|
|
$sth = $dbr->prepare("SELECT pollqid, value FROM pollresult WHERE pollid=? AND userid=?");
|
||
|
|
$sth->execute($pollid, $remote->{'userid'});
|
||
|
|
while (my ($qid, $value) = $sth->fetchrow_array) {
|
||
|
|
$preval{$qid} = $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= "<form action='$LJ::SITEROOT/poll/?id=$pollid' method='post'>";
|
||
|
|
$ret .= LJ::form_auth();
|
||
|
|
$ret .= LJ::html_hidden('pollid', $pollid);
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= "<b><a href='$LJ::SITEROOT/poll/?id=$pollid'>" . BML::ml('poll.pollnum', { 'num' => $pollid }) . "</a></b> ";
|
||
|
|
if ($po->{'name'}) {
|
||
|
|
LJ::Poll::clean_poll(\$po->{'name'});
|
||
|
|
$ret .= "<i>$po->{'name'}</i>";
|
||
|
|
}
|
||
|
|
$ret .= "<br />\n";
|
||
|
|
$ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$po->{whovote}},
|
||
|
|
'whoview' => $BML::ML{'poll.security.'.$po->{whoview}} });
|
||
|
|
my $text = LJ::run_hook('extra_poll_description', $po, \@qs);
|
||
|
|
$ret .= "<br />$text" if $text;
|
||
|
|
|
||
|
|
## go through all questions, adding to buffer to return
|
||
|
|
foreach my $q (@qs)
|
||
|
|
{
|
||
|
|
my $qid = $q->{'pollqid'};
|
||
|
|
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||
|
|
$ret .= "<p>$q->{'qtext'}</p><div style='margin: 10px 0 10px 40px'>";
|
||
|
|
|
||
|
|
### get statistics, for scale questions
|
||
|
|
my ($valcount, $valmean, $valstddev, $valmedian);
|
||
|
|
if ($q->{'type'} eq "scale")
|
||
|
|
{
|
||
|
|
## manually add all the possible values, since they aren't in the database
|
||
|
|
## (which was the whole point of making a "scale" type):
|
||
|
|
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||
|
|
$by = 1 unless ($by > 0 and int($by) == $by);
|
||
|
|
for (my $at=$from; $at<=$to; $at+=$by) {
|
||
|
|
push @{$its{$qid}}, [ $at, $at ]; # note: fake itemid, doesn't matter, but needed to be unique
|
||
|
|
}
|
||
|
|
|
||
|
|
$sth = $dbr->prepare("SELECT COUNT(*), AVG(value), STDDEV(value) FROM pollresult WHERE pollid=? AND pollqid=?");
|
||
|
|
$sth->execute($pollid, $qid);
|
||
|
|
($valcount, $valmean, $valstddev) = $sth->fetchrow_array;
|
||
|
|
|
||
|
|
# find median:
|
||
|
|
$valmedian = 0;
|
||
|
|
if ($valcount == 1) {
|
||
|
|
$valmedian = $valmean;
|
||
|
|
} elsif ($valcount > 1) {
|
||
|
|
my ($mid, $fetch);
|
||
|
|
# fetch two mids and average if even count, else grab absolute middle
|
||
|
|
$fetch = ($valcount % 2) ? 1 : 2;
|
||
|
|
$mid = int(($valcount+1)/2);
|
||
|
|
my $skip = $mid-1;
|
||
|
|
|
||
|
|
$sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=? " .
|
||
|
|
"ORDER BY value+0 LIMIT $skip,$fetch");
|
||
|
|
$sth->execute($pollid, $qid);
|
||
|
|
while (my ($v) = $sth->fetchrow_array) {
|
||
|
|
$valmedian += $v;
|
||
|
|
}
|
||
|
|
$valmedian /= $fetch;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
my $usersvoted = 0;
|
||
|
|
my %itvotes;
|
||
|
|
my $maxitvotes = 1;
|
||
|
|
|
||
|
|
if ($mode eq "results")
|
||
|
|
{
|
||
|
|
### to see individual's answers
|
||
|
|
$ret .= "<a href='$LJ::SITEROOT/poll/?id=$pollid&qid=$qid&mode=ans'>$BML::ML{'poll.viewanswers'}</a><br />";
|
||
|
|
|
||
|
|
### but, if this is a non-text item, and we're showing results, need to load the answers:
|
||
|
|
if ($q->{'type'} ne "text") {
|
||
|
|
$sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=?");
|
||
|
|
$sth->execute($pollid, $qid);
|
||
|
|
while (my ($val) = $sth->fetchrow_array) {
|
||
|
|
$usersvoted++;
|
||
|
|
if ($q->{'type'} eq "check") {
|
||
|
|
foreach (split(/,/,$val)) {
|
||
|
|
$itvotes{$_}++;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$itvotes{$val}++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach (values %itvotes) {
|
||
|
|
$maxitvotes = $_ if ($_ > $maxitvotes);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#### text questions are the easy case
|
||
|
|
|
||
|
|
if ($q->{'type'} eq "text" && $do_form) {
|
||
|
|
my ($size, $max) = split(m!/!, $q->{'opts'});
|
||
|
|
|
||
|
|
$ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max,
|
||
|
|
'name' => "pollq-$qid", 'value' => $preval{$qid} });
|
||
|
|
}
|
||
|
|
|
||
|
|
#### drop-down list
|
||
|
|
elsif ($q->{'type'} eq 'drop' && $do_form) {
|
||
|
|
my @optlist = ('', '');
|
||
|
|
foreach my $it (@{$its{$qid}}) {
|
||
|
|
my ($itid, $item) = @$it;
|
||
|
|
LJ::Poll::clean_poll(\$item);
|
||
|
|
push @optlist, ($itid, $item);
|
||
|
|
}
|
||
|
|
$ret .= LJ::html_select({ 'name' => "pollq-$qid",
|
||
|
|
'selected' => $preval{$qid} }, @optlist);
|
||
|
|
}
|
||
|
|
|
||
|
|
#### scales (from 1-10) questions
|
||
|
|
|
||
|
|
elsif ($q->{'type'} eq "scale" && $do_form) {
|
||
|
|
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||
|
|
$by ||= 1;
|
||
|
|
my $count = int(($to-$from)/$by) + 1;
|
||
|
|
my $do_radios = ($count <= 11);
|
||
|
|
|
||
|
|
# few opts, display radios
|
||
|
|
if ($do_radios) {
|
||
|
|
|
||
|
|
$ret .= "<table><tr valign='top' align='center'>";
|
||
|
|
|
||
|
|
for (my $at=$from; $at<=$to; $at+=$by) {
|
||
|
|
$ret .= "<td style='text-align: center;'>";
|
||
|
|
$ret .= LJ::html_check({ 'type' => 'radio', 'name' => "pollq-$qid",
|
||
|
|
'value' => $at, 'id' => "pollq-$pollid-$qid-$at",
|
||
|
|
'selected' => (defined $preval{$qid} && $at == $preval{$qid}) });
|
||
|
|
$ret .= "<br /><label for='pollq-$pollid-$qid-$at'>$at</label></td>";
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= "</tr></table>\n";
|
||
|
|
|
||
|
|
# many opts, display select
|
||
|
|
# but only if displaying form
|
||
|
|
} else {
|
||
|
|
|
||
|
|
my @optlist = ('', '');
|
||
|
|
for (my $at=$from; $at<=$to; $at+=$by) {
|
||
|
|
push @optlist, ($at, $at);
|
||
|
|
}
|
||
|
|
$ret .= LJ::html_select({ 'name' => "pollq-$qid", 'selected' => $preval{$qid} }, @optlist);
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
#### now, questions with items
|
||
|
|
|
||
|
|
else
|
||
|
|
{
|
||
|
|
my $do_table = 0;
|
||
|
|
|
||
|
|
if ($q->{'type'} eq "scale") { # implies ! do_form
|
||
|
|
my $stddev = sprintf("%.2f", $valstddev);
|
||
|
|
my $mean = sprintf("%.2f", $valmean);
|
||
|
|
$ret .= BML::ml('poll.scaleanswers', { 'mean' => $mean, 'median' => $valmedian, 'stddev' => $stddev });
|
||
|
|
$ret .= "<br />\n";
|
||
|
|
$do_table = 1;
|
||
|
|
$ret .= "<table>";
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach my $it (@{$its{$qid}})
|
||
|
|
{
|
||
|
|
my ($itid, $item) = @$it;
|
||
|
|
LJ::Poll::clean_poll(\$item);
|
||
|
|
|
||
|
|
# displaying a radio or checkbox
|
||
|
|
if ($do_form) {
|
||
|
|
$ret .= LJ::html_check({ 'type' => $q->{'type'}, 'name' => "pollq-$qid",
|
||
|
|
'value' => $itid, 'id' => "pollq-$pollid-$qid-$itid",
|
||
|
|
'selected' => ($preval{$qid} =~ /\b$itid\b/) });
|
||
|
|
$ret .= " <label for='pollq-$pollid-$qid-$itid'>$item</label><br />";
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
|
||
|
|
# displaying results
|
||
|
|
my $count = $itvotes{$itid}+0;
|
||
|
|
my $percent = sprintf("%.1f", (100 * $count / ($usersvoted||1)));
|
||
|
|
my $width = 20+int(($count/$maxitvotes)*380);
|
||
|
|
|
||
|
|
if ($do_table) {
|
||
|
|
$ret .= "<tr valign='middle'><td align='right'>$item</td>";
|
||
|
|
$ret .= "<td><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
|
||
|
|
$ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
|
||
|
|
$ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
|
||
|
|
$ret .= "<b>$count</b> ($percent%)</td></tr>";
|
||
|
|
} else {
|
||
|
|
$ret .= "<p>$item<br />";
|
||
|
|
$ret .= "<span style='white-space: nowrap'><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
|
||
|
|
$ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
|
||
|
|
$ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
|
||
|
|
$ret .= "<b>$count</b> ($percent%)</span></p>";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($do_table) {
|
||
|
|
$ret .= "</table>";
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
$ret .= "</div>";
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($do_form) {
|
||
|
|
$ret .= LJ::html_submit('poll-submit', $BML::ML{'poll.submit'}) . "</form>\n";;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub find_security
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
|
||
|
|
my $po = shift;
|
||
|
|
my $remote = shift;
|
||
|
|
my $sth;
|
||
|
|
|
||
|
|
## if remote is poll owner, can do anything.
|
||
|
|
if ($remote && $remote->{'userid'} == $po->{'posterid'}) {
|
||
|
|
return (1, 1);
|
||
|
|
}
|
||
|
|
|
||
|
|
## need to be both a person and with a visible journal to vote
|
||
|
|
if ($remote &&
|
||
|
|
($remote->{'journaltype'} ne "P" || $remote->{'statusvis'} ne "V")) {
|
||
|
|
return (0, 0);
|
||
|
|
}
|
||
|
|
|
||
|
|
my $is_friend = 0;
|
||
|
|
if (($po->{'whoview'} eq "friends" ||
|
||
|
|
$po->{'whovote'} eq "friends") && $remote)
|
||
|
|
{
|
||
|
|
$is_friend = LJ::is_friend($po->{'journalid'}, $remote->{'userid'});
|
||
|
|
}
|
||
|
|
|
||
|
|
my %sec;
|
||
|
|
if ($po->{'whoview'} eq "all" ||
|
||
|
|
($po->{'whoview'} eq "friends" && $is_friend) ||
|
||
|
|
($po->{'whoview'} eq "none" && $remote && $remote->{'userid'} == $po->{'posterid'}))
|
||
|
|
{
|
||
|
|
$sec{'view'} = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($po->{'whovote'} eq "all" ||
|
||
|
|
($po->{'whovote'} eq "friends" && $is_friend))
|
||
|
|
{
|
||
|
|
$sec{'vote'} = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($sec{'vote'} && (LJ::is_banned($remote, $po->{'journalid'}) ||
|
||
|
|
LJ::is_banned($remote, $po->{'posterid'}))) {
|
||
|
|
$sec{'vote'} = 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
return ($sec{'vote'}, $sec{'view'});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub submit
|
||
|
|
{
|
||
|
|
&LJ::nodb;
|
||
|
|
|
||
|
|
my $remote = shift;
|
||
|
|
my $form = shift;
|
||
|
|
my $error = shift;
|
||
|
|
my $sth;
|
||
|
|
|
||
|
|
my $dbh = LJ::get_db_writer();
|
||
|
|
|
||
|
|
unless ($remote) {
|
||
|
|
$$error = $BML::ML{'error.noremote'}; # instead of <?needremote?>, because errors are displayed in LJ::bad_input()
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $pollid = $form->{'pollid'}+0;
|
||
|
|
my $po = $dbh->selectrow_hashref("SELECT itemid, whovote, journalid, posterid, whoview, whovote, name ".
|
||
|
|
"FROM poll WHERE pollid=?", undef, $pollid);
|
||
|
|
unless ($po) {
|
||
|
|
$$error = $BML::ML{'poll.error.nopollid'};
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
my ($can_vote, undef) = find_security($po, $remote);
|
||
|
|
|
||
|
|
unless ($can_vote) {
|
||
|
|
$$error = $BML::ML{'poll.error.cantvote'};
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
### load all the questions
|
||
|
|
my @qs;
|
||
|
|
$sth = $dbh->prepare("SELECT pollqid, type, opts, qtext FROM pollquestion WHERE pollid=?");
|
||
|
|
$sth->execute($pollid);
|
||
|
|
push @qs, $_ while $_ = $sth->fetchrow_hashref;
|
||
|
|
|
||
|
|
foreach my $q (@qs) {
|
||
|
|
my $qid = $q->{'pollqid'}+0;
|
||
|
|
my $val = $form->{"pollq-$qid"};
|
||
|
|
if ($q->{'type'} eq "check") {
|
||
|
|
## multi-selected items are comma separated from htdocs/poll/index.bml
|
||
|
|
$val = join(",", sort { $a <=> $b } split(/,/, $val));
|
||
|
|
}
|
||
|
|
if ($q->{'type'} eq "scale") {
|
||
|
|
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||
|
|
if ($val < $from || $val > $to) {
|
||
|
|
# bogus! cheating?
|
||
|
|
$val = "";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($val ne "") {
|
||
|
|
$dbh->do("REPLACE INTO pollresult (pollid, pollqid, userid, value) VALUES (?, ?, ?, ?)",
|
||
|
|
undef, $pollid, $qid, $remote->{'userid'}, $val);
|
||
|
|
} else {
|
||
|
|
$dbh->do("DELETE FROM pollresult WHERE pollid=? AND pollqid=? AND userid=?",
|
||
|
|
undef, $pollid, $qid, $remote->{'userid'});
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
## finally, register the vote happened
|
||
|
|
$dbh->do("REPLACE INTO pollsubmission (pollid, userid, datesubmit) VALUES (?, ?, NOW())",
|
||
|
|
undef, $pollid, $remote->{'userid'});
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|