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

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

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;

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) = @_;

                if (defined $text) {
                        chomp $text;
                        $text=~s/^\s*//g;
                        $text=~s/^[\d\.\s]+//g;
                        $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=null>-</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;
                        $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;
                        $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});
        }
}

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