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;

$|=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;

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

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

my $html_header=suck_file("header.html");
my $html_separator=suck_file("separator.html");
my $html_next=suck_file("next.html");
my $html_footer=suck_file("footer.html");

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

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

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

my $html_kraj=suck_file("thanks.html");

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

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_next $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;

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

        my $default_value = x($attref->{default_value}) || 'null';
        my $default_text = x($attref->{default_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).");";

                }
        }
}

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

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