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 $pitanje_nr = 0;             # curr. pitanje
my $pitanje_tag = "";           # originalni oblik broja pitanja
my $page_nr = 1;                # prvo pitanje na strani

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

my $curr_suffix="";             # trenutni suffix

my @stack_pit;                  # stack pitanja (pitanje, 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"
);

my %html;       # buffer for suck(_file)ed html files

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

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{'kraj'}=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{'kraj'} $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 pitanje
sub new_pit {
        my $out="p".$pitanje_nr;
        $out .= "_".$p_suffix if ($p_suffix);
        $curr_suffix=$p_suffix;
        $p_suffix++;
        return $out;
}

# current pitanje
sub curr_pit {
        return "p".$pitanje_nr.$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) = @_;

        $pitanje_tag="";

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


sub hr {
        $body .= "<br></td></tr>$html{'separator'}<tr><td></td><td><br>";
}

sub br {
        $body .= "<br>\n";
}

sub pit {
        package main;

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

        $body.="<p>";

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

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

sub podpit {
        package main;

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

        $body.='<table width="100%" cellspacing="0" cellpadding="2" border="0">';
        $$ncref = sub {
                my ($xp, $text) = @_;

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


sub odg {
        package main;

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

        $body .= "<p>";

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

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

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_pit();
                        $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_pit();
                $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};
                        my $p=new_pit();
                        for (my $i=1; $i<=$nr; $i++) {
                                $body.="<td><input type=radio name=$p value=$i></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_pit();
                        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_pit();
                $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_pit();
                        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).");";

                }
        }
}

sub html {
        package main;

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

        $body.="<p>";

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

                if (defined $text) {
                        $body.=x($text);
                } elsif ($attref->{include}) {
                        $body.=suck_file($attref->{include});
                } else {
                        $body.="</p>";
                }
        }
}

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
#
# FIX: write actually this :-)
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";

                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});
                        }
                }
        }
}

#---------------------------------------------------------------
1	dpavlin	1.1	#!/usr/bin/perl -w
2			#
3	dpavlin	1.4	# Dobrica Pavlinusic <dpavlin@rot13.org>
4			#
5			# Originally made for proof. during April 2001; later released under GPL v2
6			#
7			# 2003-04-dd general cleanup in preparation of release
8	dpavlin	1.1
9	dpavlin	1.2	use strict;
10
11	dpavlin	1.1	use XML::Parser;
12	dpavlin	1.5	use common;
13	dpavlin	1.14	use Carp;
14	dpavlin	1.1
15			$\|=1;
16
17			my $Usage =<<'End_of_Usage;';
18	dpavlin	1.4	I will write usage information here. I promise!
19	dpavlin	1.1	End_of_Usage;
20
21			my @Modes = qw(object pass skip);
22
23	dpavlin	1.6	my $poll;
24	dpavlin	1.1	my $dowarn = 1;
25
26			my $pitanje_nr = 0; # curr. pitanje
27			my $pitanje_tag = ""; # originalni oblik broja pitanja
28			my $page_nr = 1; # prvo pitanje na strani
29
30			my $p_suffix=""; # if more than one box per question
31
32			my $curr_suffix=""; # trenutni suffix
33
34			my @stack_pit; # stack pitanja (pitanje, suffix)
35
36			my @sql_create = ("id serial",
37			"http_referer character varying(500)",
38			"remote_addr character varying(15)",
39			"user_agent character varying(300)",
40			"unesen timestamp DEFAULT now()",
41			"member_id int4 NOT NULL"
42			);
43			my @sql_update;
44			my @last_sql_update;
45			my @prelast_sql_update;
46
47			my @php_addon; # php code to add on page header
48
49			my ($last_fn,$last_page);
50
51			# this is unique prefix for this installation
52			my $prefix="wopi_";
53
54			# this is usename in database
55			my $db_user="dpavlin";
56
57	dpavlin	1.9	# This option allows users to fill poll without using invitation URL.
58			# That also means it's unpossible for them to return to exiting poll
59			# because they don't have thair own unique ID. Howver, it enables simple
60			# polls to be conducted by just publishing URL to them.
61			my $without_invitation=0;
62
63	dpavlin	1.10	# This will remove numbers before answers. That enables you to have
64			# answers written like:
65			# 1.1 red
66			# 1.2 black
67			# and users will see just "red" and "black"
68			my $remove_nrs_in_answers=0;
69
70	dpavlin	1.14	# This defines files which will be included in various places to produce
71			# design. You could desing them using your faviourite html editor (vim :-)
72			# and then split them into separate files
73
74			my %include_files = (
75			# this file is included at top of each paAge
76			'header' => "header.html",
77			# this file is used to separate questions
78			'separator' => "separator.html",
79			# this file is used to show "submit" button, which under multi-page
80			# polls will also bring next page
81			'submit' => "next.html",
82			# this file is included at bottom of each page
83			'footer' => "footer.html",
84			# this file will be showen after poll is completed
85			'thanks' => "thanks.html"
86			);
87
88			my %html; # buffer for suck(_file)ed html files
89
90	dpavlin	1.1	#------------------------------------------------------------------
91
92	dpavlin	1.2	sub suck_file {
93	dpavlin	1.14	my $file = shift \|\| croak "suck_file called without argument";
94	dpavlin	1.2	open(H,$file) \|\| die "can't open '$file': $!";
95			my $content;
96			while (<H>) { $content .= $_; } ;
97			close(H);
98			return $content;
99			}
100	dpavlin	1.1
101	dpavlin	1.14	$html{'header'}=suck_file($include_files{'header'});
102			$html{'separator'}=suck_file($include_files{'separator'});
103			$html{'submit'}=suck_file($include_files{'submit'});
104			$html{'footer'}=suck_file($include_files{'footer'});
105	dpavlin	1.1
106			#------------------------------------------------------------------
107
108			sub php_header {
109			my ($page_nr,@sql_update) = @_;
110	dpavlin	1.3	my $out='<?php
111	dpavlin	1.6	include_once("common.php");
112	dpavlin	1.1	if (isset($update)) {
113			$member_id=id_decode($a);
114			';
115			$out.=$php_addon[$page_nr-2] if (defined $php_addon[$page_nr-2]);
116			$out.='
117	dpavlin	1.6	$sql="update '.$poll.' set '.join(",\n",@sql_update).',
118	dpavlin	1.1	do_stranice=\'$PHP_SELF\'
119			where id=$id";
120	dpavlin	1.7	# print "<pre>$sql</pre>";
121	dpavlin	1.1	$result=pg_Exec($conn,fix_sql($sql));
122	dpavlin	1.6	} elseif($do_stranice != $PHP_SELF && isset($do_uri) && isset($a)) {
123	dpavlin	1.1	Header("Location: $do_uri?a=$a");
124			exit;
125			}
126			?>';
127			return $out;
128			}
129
130			#------------------------------------------------------------------
131
132			# first, define some constants
133	dpavlin	1.3	my $common_php = suck_file("common.php");
134	dpavlin	1.1
135			#------------------------------------------------------------------
136
137	dpavlin	1.2	my $head_php=suck_file("head.php");
138	dpavlin	1.1
139			#------------------------------------------------------------------
140
141	dpavlin	1.14	$html{'kraj'}=suck_file($include_files{'thanks'});
142	dpavlin	1.1
143			#------------------------------------------------------------------
144
145			while (defined($ARGV[0]) and $ARGV[0] =~ /^-/) {
146			my $opt = shift;
147
148			if ($opt eq '-h') {
149			print $Usage;
150			exit;
151			}
152			} # End of option processing
153
154	dpavlin	1.4	my $xmlfile = shift;
155	dpavlin	1.1
156	dpavlin	1.4	die "No poll xml file provided!\n$Usage" unless defined $xmlfile;
157	dpavlin	1.1
158	dpavlin	1.4	die "Can't read $xmlfile" unless -r $xmlfile;
159	dpavlin	1.1
160	dpavlin	1.6	if (defined $poll) {
161			die "$poll isn't a directory" unless -d $poll;
162	dpavlin	1.1	}
163			else {
164	dpavlin	1.4	$xmlfile =~ m!([^/.]+)(?:\.[^/.]*)?$!;
165	dpavlin	1.6	$poll = $1;
166			if (-e $poll) {
167			die "$poll exists but isn't a directory"
168			unless -d $poll;
169	dpavlin	1.1	}
170			else {
171	dpavlin	1.6	mkdir $poll, 0755;
172	dpavlin	1.1	}
173			}
174
175	dpavlin	1.4	my $in_poll = 0;
176	dpavlin	1.1	my $after_head = 0;
177
178			my $Mode = 0;
179			my $Mode_level = 0;
180
181			my $Text;
182			my $Markedup_Text;
183			my $Object;
184			my @Ostack = ();
185
186	dpavlin	1.4	#my $intext = 0;
187	dpavlin	1.1	my $closure;
188			my @closure_stack = ();
189
190	dpavlin	1.4	#my $style_link = '';
191	dpavlin	1.1
192	dpavlin	1.4	#my $index = 'index.html';
193			#my @slidetitle;
194	dpavlin	1.1	my $body;
195	dpavlin	1.4	#my $inlist = 0;
196	dpavlin	1.1
197	dpavlin	1.4	#my @Titles;
198	dpavlin	1.1
199			my $header;
200
201			my $page_number = 0;
202
203			my $p = new XML::Parser(ErrorContext => 3,
204			Handlers => {Start => \&starthndl,
205			End => \&endhndl,
206			Char => \&text});
207	dpavlin	1.4	$p->parsefile($xmlfile);
208	dpavlin	1.1
209			#----------------------------------------------------------
210
211			# dump last php page....
212
213			print "p[$page_nr] ";
214
215	dpavlin	1.6	open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
216	dpavlin	1.1	print PAGE php_header($page_nr,@prelast_sql_update);
217			my $next_fn=sprintf("%02d.php",$page_nr);
218			$last_page=~s/##NEXTPAGE##/$next_fn/;
219			print PAGE $last_page;
220			close(PAGE);
221
222			$page_nr++;
223	dpavlin	1.6	open(PAGE, ">$poll/$next_fn") or die "Couldn't open $next_fn for writing:\n$!";
224	dpavlin	1.1	print PAGE php_header($page_nr,@last_sql_update);
225	dpavlin	1.14	print PAGE "$html{'header'} $html{'kraj'} $html{'footer'}";
226	dpavlin	1.1	close(PAGE);
227
228			# dump sql structure
229
230	dpavlin	1.6	open(SQL,">$poll/$poll.sql") \|\| die "$poll.sql: $!";
231	dpavlin	1.8	print SQL "drop database ".$prefix.$poll.";\n";
232			print SQL "create database ".$prefix.$poll.";\n";
233			print SQL "\\connect ".$prefix.$poll.";\n";
234	dpavlin	1.1	print SQL "create table poslani ( member_id int4 not null, unesen timestamp default now() );\n";
235	dpavlin	1.6	print SQL "create table $poll (do_stranice text default null, ",join(",\n",@sql_create),");\n";
236	dpavlin	1.1	close(SQL);
237
238	dpavlin	1.3	# dump common.php
239
240	dpavlin	1.6	open(PHP,">$poll/common.php") \|\| die "common.php: $!";
241			$common_php =~ s/##DB##/$poll/g;
242			my $db_name = $prefix.$poll;
243	dpavlin	1.3	$common_php =~ s/##DB_NAME##/$db_name/g;
244			$common_php =~ s/##PREFIX##/$prefix/g;
245			$common_php =~ s/##DB_USER##/$db_user/g;
246			$common_php =~ s/##PREFIX##/$prefix/g;
247			my $members_db = $prefix."members";
248			$common_php =~ s/##MEMBERS_DB##/$members_db/g;
249	dpavlin	1.9	$common_php =~ s/##WITHOUT_INVITATION##/$without_invitation/g;
250	dpavlin	1.1
251	dpavlin	1.3	print PHP $common_php;
252	dpavlin	1.1	close(PHP);
253
254	dpavlin	1.6	open(PHP,">$poll/head.php") \|\| die "head.php: $!";
255	dpavlin	1.3	my $max_page = $page_nr - 1;
256	dpavlin	1.2	$head_php=~ s/##MAXPAGE##/$max_page/;
257			$head_php=~ s/##TEXT##/Ispunili ste %02d%% ankete/;
258	dpavlin	1.1	print PHP $head_php;
259			close(PHP);
260
261	dpavlin	1.4	# 01.php -> index.php
262	dpavlin	1.6	rename "$poll/01.php","$poll/index.php" \|\| die "can't rename '$poll/01.php' to index.php";
263	dpavlin	1.4
264	dpavlin	1.1	################
265			## End of main
266			################
267
268			# return unique name of pitanje
269			sub new_pit {
270	dpavlin	1.8	my $out="p".$pitanje_nr;
271			$out .= "_".$p_suffix if ($p_suffix);
272	dpavlin	1.1	$curr_suffix=$p_suffix;
273			$p_suffix++;
274			return $out;
275			}
276
277			# current pitanje
278			sub curr_pit {
279			return "p".$pitanje_nr.$curr_suffix;
280			}
281
282	dpavlin	1.4	#----------------------------------------------------------
283
284	dpavlin	1.1	sub starthndl {
285			my ($xp, $el, %atts) = @_;
286
287	dpavlin	1.4	# return unless ($in_poll or $el eq 'slideshow');
288	dpavlin	1.1
289	dpavlin	1.4	unless ($in_poll) {
290			$in_poll = $xp->depth + 1;
291	dpavlin	1.1	return;
292			}
293
294			if ($Mode) {
295
296			if ($Mode eq 'pass') {
297			$Markedup_Text .= "\n" . $xp->recognized_string;
298			}
299			elsif ($Mode eq 'object') {
300			push(@Ostack, $Object);
301
302			$Object = {_Atts => \%atts,
303			_Text => ''
304			};
305			bless $Object, "Slideobj::$el";
306			}
307
308			# skip does nothing
309			return;
310			}
311
312			unless ($after_head) {
313			if ($el eq 'head') {
314			$after_head = 1;
315			start_mode($xp, 'object');
316
317			push(@closure_stack, $closure);
318			$closure =
319			sub {
320			my ($xp, $text) = @_;
321
322			unless (defined $text) {
323
324			$header = $Object;
325			}
326			};
327
328			return;
329			}
330
331			# die "The head element must be the first thing in the slideshow";
332			}
333
334
335			my $new_closure;
336
337	dpavlin	1.4	my $subname = "Poll::$el";
338	dpavlin	1.1
339			if (defined &$subname) {
340			no strict 'refs';
341
342			&$subname($xp, $el, \%atts, \$new_closure);
343			}
344			else {
345	dpavlin	1.6	$body .= x($xp->recognized_string);
346	dpavlin	1.1	$new_closure =
347			sub {
348			my ($xp, $text) = @_;
349
350			if (defined $text) {
351	dpavlin	1.6	$body .= x($text);
352	dpavlin	1.1	}
353			else {
354	dpavlin	1.6	$body .= x("</$el>");
355	dpavlin	1.1	}
356			};
357			}
358
359			push(@closure_stack, $closure);
360			$closure = $new_closure;
361			} # End starthndl
362
363			sub endhndl {
364			my ($xp, $el) = @_;
365
366	dpavlin	1.4	return unless $in_poll;
367	dpavlin	1.1
368			my $lev = $xp->depth;
369
370	dpavlin	1.4	if ($lev == $in_poll - 1) {
371			$in_poll = 0;
372	dpavlin	1.1	$xp->finish;
373			return;
374			}
375
376			if ($Mode_level == $lev) {
377
378			if ($Mode eq 'pass') {
379			&$closure($xp, $Markedup_Text)
380			if (defined $closure);
381			}
382
383			$Mode = $Mode_level = 0;
384			}
385
386			if ($Mode) {
387			if ($Mode eq 'pass') {
388			$Markedup_Text .= "</$el>";
389			}
390			elsif ($Mode eq 'object') {
391			my $this = $Object;
392			if (2 == keys %$this) {
393			$this = $this->{_Text};
394			}
395
396			$Object = pop(@Ostack);
397
398			my $slot = $Object->{$el};
399			if (defined $slot) {
400			if (ref($slot) eq 'ARRAY') {
401			push(@$slot, $this);
402			}
403			else {
404			$Object->{$el} = [$slot, $this];
405			}
406			}
407			else {
408			$Object->{$el} = $this;
409			}
410			}
411
412			return;
413			}
414
415			&$closure($xp)
416			if defined $closure;
417
418			$closure = pop(@closure_stack);
419			} # End endhndl
420
421	dpavlin	1.4	#----------------------------------------------------------
422
423	dpavlin	1.1	sub text {
424			my ($xp, $data) = @_;
425
426	dpavlin	1.4	return unless $in_poll;
427	dpavlin	1.1
428			if ($Mode ) {
429
430			if ($Mode eq 'pass') {
431			my $safe = sgml_escape($data);
432
433			$Text .= $safe;
434			$Markedup_Text .= $safe;
435			}
436			elsif ($Mode eq 'object') {
437			$Object->{_Text} .= $data
438			if $data =~ /\S/;
439			}
440
441			return;
442			}
443
444			&$closure($xp, sgml_escape($data))
445			if (defined $closure);
446
447			} # End text
448
449			sub start_mode {
450			my ($xp, $mode) = @_;
451
452			if ($mode eq 'pass') {
453			$Text = '';
454			$Markedup_Text = '';
455			}
456			elsif ($mode eq 'object') {
457			$Object = {_Atts => undef,
458			_Text => undef
459			};
460			}
461
462			$Mode = $mode;
463			$Mode_level = $xp->depth;
464			} # End start_mode
465
466			sub sgml_escape {
467			my ($str) = @_;
468
469			$str =~ s/\&/\&/g;
470			$str =~ s/</\</g;
471			$str =~ s/>/\>/g;
472
473			$str;
474			} # End sgml_escape
475
476	dpavlin	1.6
477	dpavlin	1.1	################################################################
478
479	dpavlin	1.4	package Poll;
480	dpavlin	1.1
481			sub page {
482			package main;
483
484			my ($xp, $el, $attref, $ncref) = @_;
485
486			$$ncref = sub {
487			my ($xp, $text) = @_;
488
489			if (! defined $text) {
490
491			print "p[$page_nr] ";
492
493			if (defined $last_fn) {
494	dpavlin	1.6	open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
495	dpavlin	1.7	print PAGE php_header($page_nr,@prelast_sql_update);
496	dpavlin	1.1	my $next_fn=sprintf("%02d.php",$page_nr);
497			$last_page=~s/##NEXTPAGE##/$next_fn/;
498			print PAGE $last_page;
499			close(PAGE);
500
501			}
502			@prelast_sql_update=@last_sql_update;
503			@last_sql_update=@sql_update;
504			@sql_update = ();
505
506			$last_fn=sprintf("%02d.php",$page_nr);
507	dpavlin	1.14	$last_page="$html{'header'} $body $html{'submit'} $html{'footer'}";
508	dpavlin	1.1	# delete vars for next page
509			$page_nr++;
510			$body="";
511			}
512			}
513			} # page
514
515			sub nr {
516			package main;
517
518			my ($xp, $el, $attref, $ncref) = @_;
519
520			$pitanje_tag="";
521
522			$$ncref = sub {
523			my ($xp, $text) = @_;
524			if (defined($text)) {
525	dpavlin	1.4	$body.=x($text);
526	dpavlin	1.1	chomp $text;
527	dpavlin	1.4	$pitanje_tag .= x($text);
528	dpavlin	1.1	} else {
529			$pitanje_nr = $pitanje_tag;
530			$pitanje_nr =~ s/[^0-9a-zA-Z]//g;
531			print "$pitanje_nr ";
532			}
533			$p_suffix="";
534			};
535			} # nr
536
537
538			sub hr {
539	dpavlin	1.14	$body .= "<br></td></tr>$html{'separator'}<tr><td></td><td><br>";
540	dpavlin	1.1	}
541
542			sub br {
543			$body .= "<br>\n";
544			}
545
546			sub pit {
547			package main;
548
549			my ($xp, $el, $attref, $ncref) = @_;
550
551			$body.="<p>";
552
553			$$ncref = sub {
554			my ($xp, $text) = @_;
555
556			if (defined $text) {
557	dpavlin	1.2	$body.=x($text);
558	dpavlin	1.1	} else {
559			$body.="</p>";
560			}
561			}
562			}
563
564			sub podpit {
565			package main;
566
567			my ($xp, $el, $attref, $ncref) = @_;
568
569			$body.='<table width="100%" cellspacing="0" cellpadding="2" border="0">';
570			$$ncref = sub {
571			my ($xp, $text) = @_;
572
573			if (defined $text) {
574	dpavlin	1.2	$body.=x($text);
575	dpavlin	1.1	} else {
576			$body.="</table>";
577			}
578			}
579			}
580
581
582			sub odg {
583			package main;
584
585			my ($xp, $el, $attref, $ncref) = @_;
586
587			$body .= "<p>";
588
589			$$ncref = sub {
590			my ($xp, $text) = @_;
591
592			if (defined $text) {
593	dpavlin	1.2	$body .= x($text);
594	dpavlin	1.1	} else {
595			$body .= "</p>";
596			}
597			}
598			}
599
600			sub php {
601			package main;
602			my ($xp, $el, $attref, $ncref) = @_;
603
604			$body.="<?php\n";
605
606			$$ncref = sub {
607			my ($xp, $text) = @_;
608
609			if (defined $text) {
610			$text=~s/ lt / < /g;
611			$text=~s/ le / <= /g;
612			$text=~s/ gt / > /g;
613			$text=~s/ ge / >= /g;
614	dpavlin	1.2	$body.=x($text);
615	dpavlin	1.1	} else {
616			$body.="\n?>\n";
617			}
618			}
619			}
620
621			sub dropdown {
622			package main;
623
624			my ($xp, $el, $attref, $ncref) = @_;
625
626			my @dropdown_data;
627
628	dpavlin	1.12	my $default_value = x($attref->{default_value}) \|\| 'null';
629			my $default_text = x($attref->{default_text}) \|\| '-';
630
631	dpavlin	1.1	$$ncref = sub {
632			my ($xp, $text) = @_;
633
634			if (defined $text) {
635			chomp $text;
636			$text=~s/^\s*//g;
637	dpavlin	1.10	$text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
638	dpavlin	1.1	$text=~s/\s*$//g;
639	dpavlin	1.2	push @dropdown_data,x($text) if ($text ne "");
640	dpavlin	1.1	} else {
641			my $opt;
642			my $id=1;
643			my $p=new_pit();
644			$body.="<select name=$p >\n";
645	dpavlin	1.12	$body.="<option value=\"$default_value\">$default_text</option>\n";
646	dpavlin	1.1	foreach $opt (@dropdown_data) {
647			if (defined($opt) && $opt ne "") {
648			$body.="<option value=$id>$opt</option>\n";
649			$id++;
650			}
651			}
652			$body.="</select>\n";
653
654			push @sql_create,"$p int4";
655			push @sql_update,"$p=\$$p";
656			}
657			}
658			}
659
660			sub textbox {
661			package main;
662			my ($xp, $el, $attref, $ncref) = @_;
663
664			$$ncref = sub {
665			my ($xp, $text) = @_;
666			my $size=$attref->{size};
667			$size = 25 if (! defined $size \|\| $size == 0); # default
668			my $p=new_pit();
669	dpavlin	1.2	$body.="<input type=text name=$p size=".x($size)." >\n";
670	dpavlin	1.1	push @sql_create,"$p text";
671			push @sql_update,"$p='\$$p'";
672			}
673			}
674
675			sub radiobuttons_tab {
676			package main;
677			my ($xp, $el, $attref, $ncref) = @_;
678
679			$$ncref = sub {
680			my ($xp, $text) = @_;
681			if (! defined $text) {
682			my $nr=$attref->{nr};
683			my $p=new_pit();
684			for (my $i=1; $i<=$nr; $i++) {
685			$body.="<td><input type=radio name=$p value=$i></td> ";
686			}
687			push @sql_create,"$p int4";
688			push @sql_update,"$p=\$$p";
689			}
690			}
691			}
692
693			sub radiobuttons {
694			package main;
695			my ($xp, $el, $attref, $ncref) = @_;
696
697			my @radiobuttons_data;
698
699			$$ncref = sub {
700			my ($xp, $text) = @_;
701
702			if (defined $text) {
703			chomp $text;
704			$text=~s/^\s*//g;
705	dpavlin	1.10	$text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
706	dpavlin	1.1	$text=~s/\s*$//g;
707	dpavlin	1.2	push @radiobuttons_data,x($text) if ($text ne "");
708	dpavlin	1.1	} else {
709			my $opt;
710			my $p=new_pit();
711			my $id=1;
712			foreach $opt (@radiobuttons_data) {
713			if (defined($opt) && $opt ne "") {
714			$body.="<input type=radio name=$p value=$id> $opt<br>\n";
715			$id++;
716			}
717			}
718			push @sql_create,"$p int4";
719			push @sql_update,"$p=\$$p";
720			}
721			}
722			}
723			sub checkbox {
724			package main;
725			my ($xp, $el, $attref, $ncref) = @_;
726
727			$$ncref = sub {
728			my ($xp, $text) = @_;
729			my $p=new_pit();
730			$body.="<input type=checkbox name=$p >\n";
731			push @sql_create,"$p text";
732			push @sql_update,"$p='\$$p'";
733			}
734			}
735
736			sub checkboxes {
737			package main;
738
739			my ($xp, $el, $attref, $ncref) = @_;
740
741			my @checkboxes_data;
742
743			$$ncref = sub {
744			my ($xp, $text) = @_;
745
746
747			if (defined $text) {
748			chomp $text;
749			$text=~s/^\s*//g;
750	dpavlin	1.10	$text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
751	dpavlin	1.1	$text=~s/\s*$//g;
752	dpavlin	1.2	push @checkboxes_data,x($text) if ($text ne "");
753	dpavlin	1.1	} else {
754			my $opt;
755			my $base_p=new_pit();
756			my $id=1;
757
758			my $before=$attref->{before};
759			my $after=$attref->{after};
760			my $middle=$attref->{middle};
761			if (! $before && ! $after && ! $middle) {
762			$middle=" ";
763			$after="<br>";
764			}
765			my $hide_description=$attref->{hide_description};
766
767			foreach $opt (@checkboxes_data) {
768			if (defined($opt) && $opt ne "") {
769			$p=$base_p."_".$id;
770			$id++;
771	dpavlin	1.2	$body .= x($before) if ($before);
772	dpavlin	1.1	$body.="<input type=checkbox name=$p>";
773	dpavlin	1.2	$body .= x($middle) if ($middle);
774	dpavlin	1.1	$body .= "$opt" if (! $hide_description);
775	dpavlin	1.2	$body .= x($after) if ($after);
776	dpavlin	1.1	$body.="\n";
777
778			push @sql_create,"$p boolean";
779			push @sql_update,"$p=\$$p";
780			}
781			}
782			$php_addon[$page_nr].="fix_checkboxes($base_p,".($id-1).");";
783
784			}
785	dpavlin	1.4	}
786			}
787	dpavlin	1.8
788	dpavlin	1.13	sub html {
789			package main;
790
791			my ($xp, $el, $attref, $ncref) = @_;
792
793			$body.="<p>";
794
795			$$ncref = sub {
796			my ($xp, $text) = @_;
797
798			if (defined $text) {
799			$body.=x($text);
800	dpavlin	1.14	} elsif ($attref->{include}) {
801			$body.=suck_file($attref->{include});
802	dpavlin	1.13	} else {
803			$body.="</p>";
804			}
805			}
806			}
807
808	dpavlin	1.8	print "\n\nTo create database for poll $poll use:\n\n";
809			print "\$ psql template1 < $poll/$poll.sql\n\n";
810			print "THIS WILL DISTROY ALL DATA IN EXISTING DATABASE ".$prefix.$poll." !!\n";
811	dpavlin	1.4
812			# read configuration data
813			#
814			# FIX: write actually this :-)
815			sub config {
816			package main;
817			my ($xp, $el, $attref, $ncref) = @_;
818
819			$$ncref = sub {
820			my ($xp, $text) = @_;
821			$db_user=x($attref->{db_user});
822			$prefix=x($attref->{prefix});
823	dpavlin	1.10	$without_invitation=x($attref->{without_invitation}) &&
824			print "Pool is without need for unique ID (and invitation URLs).\n";
825			$remove_nrs_in_answers=x($attref->{$remove_nrs_in_answers}) &&
826			print "Numbers before answers will be removed.\n";
827	dpavlin	1.14
828			foreach my $file (qw(header separator submit footer thanks)) {
829			if ($attref->{$file}) {
830			$include_files{$file}=x($attref->{$file});
831			print "Using custom $file '$include_files{$file}'\n";
832			$html{$file} = suck_file($include_files{$file});
833			}
834			}
835	dpavlin	1.1	}
836			}
837
838			#---------------------------------------------------------------