viewvc.cgi/wopi/make_poll.pl

#!/usr/bin/perl -w
#
# Dobrica Pavlinusic <dpavlin@rot13.org>
#
# Originally made for proof. during April 2001; later released under GPL v2
#
# 2003-04-dd general cleanup in preparation of release

use strict;

use XML::Parser;
use common;
use Carp;

$|=1;

my $Usage =<<'End_of_Usage;';
I will write usage information here. I promise!
End_of_Usage;

my @Modes = qw(object pass skip);

my $poll;
my $dowarn = 1;

my $q_type = "q";               # q=question, u=unnumbered question
my %question_nr;                # curr. question numbers
my $question_tag = "";          # originalni oblik broja questions
my $page_nr = 1;                # prvo question na strani

my $p_suffix="";                # if more than one box per question

my $curr_suffix="";             # trenutni suffix

my @stack_que;                  # stack of questions (question, suffix)

my @sql_create = ("id serial",
        "http_referer character varying(500)",
        "remote_addr character varying(15)",
        "user_agent character varying(300)",
        "unesen timestamp DEFAULT now()",
        "member_id int4 NOT NULL"
        );
my @sql_update;
my @last_sql_update;
my @prelast_sql_update;

my @php_addon;                  # php code to add on page header

my ($last_fn,$last_page);

# this is unique prefix for this installation
my $prefix="wopi_";

# this is usename in database
my $db_user="dpavlin";

# This option allows users to fill poll without using invitation URL.
# That also means it's unpossible for them to return to exiting poll
# because they don't have thair own unique ID. Howver, it enables simple
# polls to be conducted by just publishing URL to them.
my $without_invitation=0;

# This will remove numbers before answers. That enables you to have
# answers written like:
# 1.1 red
# 1.2 black
# and users will see just "red" and "black"
my $remove_nrs_in_answers=0;

# This defines files which will be included in various places to produce
# design. You could desing them using your faviourite html editor (vim :-)
# and then split them into separate files

my %include_files = (
# this file is included at top of each paAge
        'header' => "header.html",
# this file is used to separate questions
        'separator' => "separator.html",
# this file is used to show "submit" button, which under multi-page
# polls will also bring next page
        'submit' => "next.html",
# this file is included at bottom of each page
        'footer' => "footer.html",
# this file will be showen after poll is completed
        'thanks' => "thanks.html"
);

# buffer for suck(_file)ed html files
# and additional markup before and after tags
my %html = (
        'hr_before' => "<br></td></tr>",
        'hr_after' => "<tr><td></td><td><br>",
        'que_before' => "<p>",
        'que_after' => "</p>",
        'subque_before' => '<table width="100%" cellspacing="0" cellpadding="2" border="0">',
        'subque_after' => "</table>",
        'ans_before' => "<p>",
        'ans_after' => "</p>",
        'html_before' => "<p>",
        'html_after' => "</p>",

);

# name of database colums
# for questions
my $q_db_col = "q";
# for unnumbered questions
my $u_db_col = "u";


#------------------------------------------------------------------

sub suck_file {
        my $file = shift || croak "suck_file called without argument";
        open(H,$file) || die "can't open '$file': $!";
        my $content;
        while (<H>) { $content .= $_; } ;
        close(H);
        return $content;
}

$html{'header'}=suck_file($include_files{'header'});
$html{'separator'}=suck_file($include_files{'separator'});
$html{'submit'}=suck_file($include_files{'submit'});
$html{'footer'}=suck_file($include_files{'footer'});

#------------------------------------------------------------------

sub php_header {
my ($page_nr,@sql_update) = @_;
my $out='<?php
        include_once("common.php");
        if (isset($update)) {
                $member_id=id_decode($a);
                ';
$out.=$php_addon[$page_nr-2] if (defined $php_addon[$page_nr-2]);
$out.='
                $sql="update '.$poll.' set '.join(",\n",@sql_update).',
                        do_stranice=\'$PHP_SELF\'
                        where id=$id";
#               print "<pre>$sql</pre>";
                $result=pg_Exec($conn,fix_sql($sql));
        } elseif($do_stranice != $PHP_SELF && isset($do_uri) && isset($a)) {
                Header("Location: $do_uri?a=$a");
                exit;
        }
?>';
return $out;
}

#------------------------------------------------------------------

# first, define some constants
my $common_php = suck_file("common.php");

#------------------------------------------------------------------

my $head_php=suck_file("head.php");

#------------------------------------------------------------------

$html{'thanks'}=suck_file($include_files{'thanks'});

#------------------------------------------------------------------

while (defined($ARGV[0]) and $ARGV[0] =~ /^-/) {
  my $opt = shift;

  if ($opt eq '-h') {
    print $Usage;
    exit;
  }
}  # End of option processing

my $xmlfile = shift;

die "No poll xml file provided!\n$Usage" unless defined $xmlfile;

die "Can't read $xmlfile" unless -r $xmlfile;

if (defined $poll) {
  die "$poll isn't a directory" unless -d $poll;
}
else {
  $xmlfile =~ m!([^/.]+)(?:\.[^/.]*)?$!;
  $poll = $1;
  if (-e $poll) {
    die "$poll exists but isn't a directory"
      unless -d $poll;
  }
  else {
    mkdir $poll, 0755;
  }
}

my $in_poll = 0;
my $after_head = 0;

my $Mode = 0;
my $Mode_level = 0;

my $Text;
my $Markedup_Text;
my $Object;
my @Ostack = ();

#my $intext = 0;
my $closure;
my @closure_stack = ();

#my $style_link = '';

#my $index = 'index.html';
#my @slidetitle;
my $body;
#my $inlist = 0;

#my @Titles;

my $header;

my $page_number = 0;

my $p = new XML::Parser(ErrorContext => 3,
                        Handlers => {Start => \&starthndl,
                                     End   => \&endhndl,
                                     Char  => \&text});
$p->parsefile($xmlfile);

#----------------------------------------------------------

# dump last php page....

print "p[$page_nr] ";

open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
print PAGE php_header($page_nr,@prelast_sql_update);
my $next_fn=sprintf("%02d.php",$page_nr);
$last_page=~s/##NEXTPAGE##/$next_fn/;
print PAGE $last_page;
close(PAGE);

$page_nr++;
open(PAGE, ">$poll/$next_fn") or die "Couldn't open $next_fn for writing:\n$!";
print PAGE php_header($page_nr,@last_sql_update);
print PAGE "$html{'header'} $html{'thanks'} $html{'footer'}";
close(PAGE);

# dump sql structure

open(SQL,">$poll/$poll.sql") || die "$poll.sql: $!";
print SQL "drop database ".$prefix.$poll.";\n";
print SQL "create database ".$prefix.$poll.";\n";
print SQL "\\connect ".$prefix.$poll.";\n";
print SQL "create table poslani ( member_id int4 not null, unesen timestamp default now() );\n";
print SQL "create table $poll (do_stranice text default null, ",join(",\n",@sql_create),");\n";
close(SQL);

# dump common.php

open(PHP,">$poll/common.php") || die "common.php: $!";
$common_php =~ s/##DB##/$poll/g;
my $db_name = $prefix.$poll;
$common_php =~ s/##DB_NAME##/$db_name/g;
$common_php =~ s/##PREFIX##/$prefix/g;
$common_php =~ s/##DB_USER##/$db_user/g;
$common_php =~ s/##PREFIX##/$prefix/g;
my $members_db = $prefix."members";
$common_php =~ s/##MEMBERS_DB##/$members_db/g;
$common_php =~ s/##WITHOUT_INVITATION##/$without_invitation/g;

print PHP $common_php;
close(PHP);

open(PHP,">$poll/head.php") || die "head.php: $!";
my $max_page = $page_nr - 1;
$head_php=~ s/##MAXPAGE##/$max_page/;
$head_php=~ s/##TEXT##/Ispunili ste %02d%% ankete/;
print PHP $head_php;
close(PHP);

# 01.php -> index.php
rename "$poll/01.php","$poll/index.php" || die "can't rename '$poll/01.php' to index.php";

################
## End of main
################

# return unique name of question
sub new_que {
        my $out=$q_type.( $question_nr{$q_type} || 0 );
        $out .= "_".$p_suffix if ($p_suffix);
        $curr_suffix=$p_suffix;
        $p_suffix++;
        return $out;
}

# current question
sub curr_que {
        return $q_type.( $question_nr{$q_type} || 0 ).$curr_suffix;
}

#----------------------------------------------------------

sub starthndl {
        my ($xp, $el, %atts) = @_;

#       return unless ($in_poll or $el eq 'slideshow');

        unless ($in_poll) {
                $in_poll = $xp->depth + 1;
                return;
        }

        if ($Mode) {
                if ($Mode eq 'pass') {
                        $Markedup_Text .= "\n" . $xp->recognized_string;
                } elsif ($Mode eq 'object') {
                        push(@Ostack, $Object);

                        $Object = {
                                _Atts     => \%atts,
                                _Text    => ''
                        };
                        bless $Object, "Slideobj::$el";
                }

                # skip does nothing
                return;
        }

        unless ($after_head) {
                if ($el eq 'head') {
                        $after_head = 1;
                        start_mode($xp, 'object');

                        push(@closure_stack, $closure);
                        $closure = sub {
                                my ($xp, $text) = @_;

                                unless (defined $text) {
                                        $header = $Object;
                                }
                        };
                        return;
                }

#               die "The head element must be the first thing in the slideshow";
        }


        my $new_closure;

        my $subname = "Poll::$el";

        if (defined &$subname) {
                no strict 'refs';

                &$subname($xp, $el, \%atts, \$new_closure);
        } else {
                $body .= x($xp->recognized_string);
                $new_closure = sub {
                        my ($xp, $text) = @_;

                        if (defined $text) {
                                $body .= x($text);
                        } else {
                                $body .= x("</$el>");
                        }
                };
        }

        push(@closure_stack, $closure);
        $closure = $new_closure;
}       # End starthndl

sub endhndl {
        my ($xp, $el) = @_;

        return unless $in_poll;

        my $lev = $xp->depth;

        if ($lev == $in_poll - 1) {
                $in_poll = 0;
                $xp->finish;
                return;
        }
        
        if ($Mode_level == $lev) {
                
                if ($Mode eq 'pass') {
                        &$closure($xp, $Markedup_Text) if (defined $closure);
                }

                $Mode = $Mode_level = 0;
        }

        if ($Mode) {
                if ($Mode eq 'pass') {
                        $Markedup_Text .= "</$el>";
                } elsif ($Mode eq 'object') {
                        my $this = $Object;
                        if (2 == keys %$this) {
                                $this = $this->{_Text};
                        }

                        $Object = pop(@Ostack);

                        my $slot = $Object->{$el};
                        if (defined $slot) {
                                if (ref($slot) eq 'ARRAY') {
                                        push(@$slot, $this);
                                } else {
                                        $Object->{$el} = [$slot, $this];
                                }
                        } else {
                                $Object->{$el} = $this;
                        }
                }

                return;
        }

        &$closure($xp) if defined $closure;

        $closure = pop(@closure_stack);
}  # End endhndl

#----------------------------------------------------------

sub text {
        my ($xp, $data) = @_;

        return unless $in_poll;

        if ($Mode) {

                if ($Mode eq 'pass') {
                        my $safe = sgml_escape($data);

                        $Text .= $safe;
                        $Markedup_Text .= $safe;
                } elsif ($Mode eq 'object') {
                        $Object->{_Text} .= $data if $data =~ /\S/;
                }

                return;
        }

        &$closure($xp, sgml_escape($data)) if (defined $closure);

}  # End text

sub start_mode {
        my ($xp, $mode) = @_;

        if ($mode eq 'pass') {
                $Text = '';
                $Markedup_Text = '';
        } elsif ($mode eq 'object') {
                $Object = {
                        _Atts => undef,
                        _Text => undef
                };
        }

        $Mode = $mode;
        $Mode_level = $xp->depth;
}  # End start_mode

sub sgml_escape {
        my ($str) = @_;

        $str =~ s/\&/\&amp;/g;
        $str =~ s/</\&lt;/g;
        $str =~ s/>/\&gt;/g;

        $str;
}  # End sgml_escape

################################################################

package Poll;

sub page {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (! defined $text) {

                        print "p[$page_nr] ";

                        if (defined $last_fn) {
                                open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
                                print PAGE php_header($page_nr,@prelast_sql_update);
                                my $next_fn=sprintf("%02d.php",$page_nr);
                                $last_page=~s/##NEXTPAGE##/$next_fn/;
                                print PAGE $last_page;
                                close(PAGE);

                        }
                        @prelast_sql_update=@last_sql_update;
                        @last_sql_update=@sql_update;
                        @sql_update = ();
        
                        $last_fn=sprintf("%02d.php",$page_nr);
                        $last_page="$html{'header'} $body $html{'submit'} $html{'footer'}";
                        # delete vars for next page
                        $page_nr++;
                        $body="";
                }
        }
}  # page

sub nr {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        $question_tag="";

        $$ncref = sub {
                my ($xp, $text) = @_;
                if (defined($text)) {
                        $body.=x($text);
                        chomp $text;
                        $question_tag .= x($text);
                } else {
                        $question_nr{$q_type} = $question_tag;
                        $question_nr{$q_type} =~ s/[^0-9a-zA-Z]//g;
                        print "$question_nr{$q_type} ";
                }
                $p_suffix="";
        };
}  # nr


sub hr {
        $body .= $html{'hr_before'}.$html{'separator'}.$html{'hr_after'};
}

sub que {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        my $nonum = x($attref->{unnumbered});
        if ($nonum) {
                $q_type = $u_db_col;    # unnumbered questions
        } else {
                $q_type = $q_db_col;
        }
        
        $question_nr{$q_type}++;

        # attribute markup_before override que_before
        my $markup_before = x($attref->{markup_before});
        my $markup_after = x($attref->{markup_after});

        if (defined($markup_before)) {
                $body.=$markup_before;
        } elsif ($html{'que_before'}) {
                $body.=$html{'que_before'}
        }

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        $body.=x($text);
                } else {
                        if (defined($markup_after)) {
                                $body.=$markup_after;
                        } elsif ($html{'que_after'}) {
                                $body.=$html{'que_after'}
                        }
                }
        }
}

sub subque {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        my $markup_before = x($attref->{markup_before});
        my $markup_after = x($attref->{markup_after});

        if (defined($markup_before)) {
                $body.=$markup_before;
        } elsif ($html{'subque_before'}) {
                $body.=$html{'subque_before'}
        }

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        $body.=x($text);
                } else {
                        if (defined($markup_after)) {
                                $body.=$markup_after;
                        } elsif ($html{'subque_after'}) {
                                $body.=$html{'subque_after'}
                        }
                }
        }
}


sub ans {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        my $markup_before = x($attref->{markup_before});
        my $markup_after = x($attref->{markup_after});

        if (defined($markup_before)) {
                $body.=$markup_before;
        } elsif ($html{'ans_before'}) {
                $body.=$html{'ans_before'}
        }
        
        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        $body .= x($text);
                } else {
                        if (defined($markup_after)) {
                                $body.=$markup_after;
                        } elsif ($html{'ans_after'}) {
                                $body.=$html{'ans_after'}
                        }
                }
        }
}

sub php {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        $body.="<?php\n";

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        $text=~s/ lt / < /g;
                        $text=~s/ le / <= /g;
                        $text=~s/ gt / > /g;
                        $text=~s/ ge / >= /g;
                        $body.=x($text);
                } else {
                        $body.="\n?>\n";
                }
        }
}

sub dropdown {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        my @dropdown_data;

        my $default_value = x($attref->{default_value}) || 'null';
        my $default_text = x($attref->{default_text}) || '-';

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        chomp $text;
                        $text=~s/^\s*//g;
                        $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
                        $text=~s/\s*$//g;
                        push @dropdown_data,x($text) if ($text ne "");
                } else {
                        my $opt;
                        my $id=1;
                        my $p=new_que();
                        $body.="<select name=$p >\n";
                        $body.="<option value=\"$default_value\">$default_text</option>\n";
                        foreach $opt (@dropdown_data) {
                                if (defined($opt) && $opt ne "") {
                                        $body.="<option value=$id>$opt</option>\n";
                                        $id++;
                                }
                        }
                        $body.="</select>\n";

                        push @sql_create,"$p int4";
                        push @sql_update,"$p=\$$p";
                }
        }
}

sub textbox {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;
                my $size=$attref->{size};
                $size = 25 if (! defined $size || $size == 0);  # default
                my $p=new_que();
                $body.="<input type=text name=$p size=".x($size)." >\n";
                push @sql_create,"$p text";
                push @sql_update,"$p='\$$p'";
        }
}

sub radiobuttons_tab {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;
                if (! defined $text) {
                        my $nr=$attref->{nr} || die "need <radiobuttons_tab nr=\"999\"> for number of buttons";
                        # shownumbers="before|after"
                        my $shownumbers=lc(x($attref->{shownumbers})) || 'no';
                        my $showlabels=lc(x($attref->{showlabels})) || 'no';
                        my $class=lc(x($attref->{class})) || '';
                        $class=' class="'.$class.'"' if ($class);
                        my $p=new_que();
                        for (my $i=1; $i<=$nr; $i++) {
                                $body.="<td$class>";
                                $body.=$i if ($shownumbers eq "before");
                                if ($showlabels eq "before" && $attref->{"label_$i"}) {
                                        $body.=x($attref->{"label_$i"});
                                }
                                $body.="<input type=radio name=$p value=$i>";
                                $body.=$i if ($shownumbers eq "after");
                                $body.="</td> ";
                        }
                        push @sql_create,"$p int4";
                        push @sql_update,"$p=\$$p";
                }
        }
}

sub radiobuttons {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        my @radiobuttons_data;

        $$ncref = sub {
                my ($xp, $text) = @_;
                
                if (defined $text) {
                        chomp $text;
                        $text=~s/^\s*//g;
                        $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
                        $text=~s/\s*$//g;
                        push @radiobuttons_data,x($text) if ($text ne "");
                } else {
                        my $opt;
                        my $p=new_que();
                        my $id=1;
                        foreach $opt (@radiobuttons_data) {
                                if (defined($opt) && $opt ne "") {
                                        $body.="<input type=radio name=$p value=$id> $opt<br>\n";
                                        $id++;
                                }
                        }
                        push @sql_create,"$p int4";
                        push @sql_update,"$p=\$$p";
                }
        }
}
sub checkbox {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;
                my $p=new_que();
                $body.="<input type=checkbox name=$p >\n";
                push @sql_create,"$p text";
                push @sql_update,"$p='\$$p'";
        }
}

sub checkboxes {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        my @checkboxes_data;

        $$ncref = sub {
                my ($xp, $text) = @_;


                if (defined $text) {
                        chomp $text;
                        $text=~s/^\s*//g;
                        $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
                        $text=~s/\s*$//g;
                        push @checkboxes_data,x($text) if ($text ne "");
                } else {
                        my $opt;
                        my $base_p=new_que();
                        my $id=1;

                        my $before=$attref->{before};
                        my $after=$attref->{after};
                        my $middle=$attref->{middle};
                        if (! $before && ! $after && ! $middle) {
                                $middle="&nbsp;";
                                $after="<br>";
                        }
                        my $hide_description=$attref->{hide_description};

                        foreach $opt (@checkboxes_data) {
                                if (defined($opt) && $opt ne "") {
                                        $p=$base_p."_".$id;
                                        $id++;
                                        $body .= x($before) if ($before);
                                        $body.="<input type=checkbox name=$p>";
                                        $body .= x($middle) if ($middle);
                                        $body .= "$opt" if (! $hide_description);
                                        $body .= x($after) if ($after);
                                        $body.="\n";

                                        push @sql_create,"$p boolean";
                                        push @sql_update,"$p=\$$p";
                                }
                        }
                        $php_addon[$page_nr].="fix_checkboxes($base_p,".($id-1).");";

                }
        }
}

#
# insert arbitrary html
#
sub html {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        $body.=$html{'html_before'} if ($html{'html_before'});

        $$ncref = sub {
                my ($xp, $text) = @_;

                if (defined $text) {
                        $body.=x($text);
                } elsif ($attref->{include}) {
                        $body.=suck_file($attref->{include});
                } else {
                        $body.=$html{'html_after'} if ($html{'html_after'});
                }
        }
}

#
# markup tag can specify any markup which should be applied pre (before)
# or post (after) any other tag which produces html output
# 

sub markup {
        package main;

        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;

                my $tag=lc($attref->{tag}) || die 'markup need tag attribute: <markup tag="tag_name" pos="(before|after)">';
                my $pos=lc($attref->{pos}) || die 'markup need pos attribute: <markup tag="tag_name" pos="(before|after)">';

                return if (! defined $text);
                chomp($text);
                if ($text ne "") {
                        $text =~ s/\&amp;/\&/g;
                        $text =~ s/\&lt;/</g;
                        $text =~ s/\&gt;/>/g;
                        $text =~ s/^\s+//g;
                        $text =~ s/\s+$//g;
                        $html{$tag.'_'.$pos}=x($text);
                        print "Using markup $pos $tag: ",x($text),"<--\n";
                }
        }
}

#
# print final instructions and exit
#

print "\n\nTo create database for poll $poll use:\n\n";
print "\$ psql template1 < $poll/$poll.sql\n\n";
print "THIS WILL DISTROY ALL DATA IN EXISTING DATABASE ".$prefix.$poll." !!\n";

# read configuration data
sub config {
        package main;
        my ($xp, $el, $attref, $ncref) = @_;

        $$ncref = sub {
                my ($xp, $text) = @_;
                $db_user=x($attref->{db_user});
                $prefix=x($attref->{prefix});
                $without_invitation=x($attref->{without_invitation}) &&
                        print "Pool is without need for unique ID (and invitation URLs).\n";
                $remove_nrs_in_answers=x($attref->{remove_nrs_in_answers}) &&
                        print "Numbers before answers will be removed.\n";

                # fill in configuration about include files
                foreach my $file (qw(header separator submit footer thanks)) {
                        if ($attref->{$file}) {
                                $include_files{$file}=x($attref->{$file});
                                print "Using custom $file '$include_files{$file}'\n";
                                $html{$file} = suck_file($include_files{$file});
                        }
                }
                $q_db_col=x($attref->{q_db_col}) || 'q';
                $u_db_col=x($attref->{u_db_col}) || 'u';

        }
}

#---------------------------------------------------------------