--- make_poll.pl 2003/09/24 20:35:48 1.9 +++ make_poll.pl 2003/11/08 01:08:44 1.17 @@ -10,6 +10,7 @@ use XML::Parser; use common; +use Carp; $|=1; @@ -22,15 +23,16 @@ 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 $q_type = "q"; # q=question, u=unnumbered question +my %question_nr; # curr. question numbers +my $question_tag = ""; # originalni oblik broja questions +my $page_nr = 1; # prvo question na strani my $p_suffix=""; # if more than one box per question my $curr_suffix=""; # trenutni suffix -my @stack_pit; # stack pitanja (pitanje, suffix) +my @stack_que; # stack of questions (question, suffix) my @sql_create = ("id serial", "http_referer character varying(500)", @@ -59,10 +61,58 @@ # polls to be conducted by just publishing URL to them. my $without_invitation=0; +# This will remove numbers before answers. That enables you to have +# answers written like: +# 1.1 red +# 1.2 black +# and users will see just "red" and "black" +my $remove_nrs_in_answers=0; + +# This defines files which will be included in various places to produce +# design. You could desing them using your faviourite html editor (vim :-) +# and then split them into separate files + +my %include_files = ( +# this file is included at top of each paAge + 'header' => "header.html", +# this file is used to separate questions + 'separator' => "separator.html", +# this file is used to show "submit" button, which under multi-page +# polls will also bring next page + 'submit' => "next.html", +# this file is included at bottom of each page + 'footer' => "footer.html", +# this file will be showen after poll is completed + 'thanks' => "thanks.html" +); + +# buffer for suck(_file)ed html files +# and additional markup before and after tags +my %html = ( + 'hr_before' => "
", + 'hr_after' => "
", + 'que_before' => "

", + 'que_after' => "

", + 'subque_before' => '', + 'subque_after' => "
", + 'ans_before' => "

", + 'ans_after' => "

", + 'html_before' => "

", + 'html_after' => "

", + +); + +# name of database colums +# for questions +my $q_db_col = "q"; +# for unnumbered questions +my $u_db_col = "u"; + + #------------------------------------------------------------------ sub suck_file { - my $file = shift @_; + my $file = shift || croak "suck_file called without argument"; open(H,$file) || die "can't open '$file': $!"; my $content; while () { $content .= $_; } ; @@ -70,10 +120,10 @@ 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"); +$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'}); #------------------------------------------------------------------ @@ -110,7 +160,7 @@ #------------------------------------------------------------------ -my $html_kraj=suck_file("thanks.html"); +$html{'thanks'}=suck_file($include_files{'thanks'}); #------------------------------------------------------------------ @@ -194,7 +244,7 @@ $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"; +print PAGE "$html{'header'} $html{'thanks'} $html{'footer'}"; close(PAGE); # dump sql structure @@ -237,215 +287,199 @@ ## End of main ################ -# return unique name of pitanje -sub new_pit { - my $out="p".$pitanje_nr; +# return unique name of question +sub new_que { + my $out=$q_type.( $question_nr{$q_type} || 0 ); $out .= "_".$p_suffix if ($p_suffix); $curr_suffix=$p_suffix; $p_suffix++; return $out; } -# current pitanje -sub curr_pit { - return "p".$pitanje_nr.$curr_suffix; +# current question +sub curr_que { + return $q_type.( $question_nr{$q_type} || 0 ).$curr_suffix; } #---------------------------------------------------------- sub starthndl { - my ($xp, $el, %atts) = @_; + my ($xp, $el, %atts) = @_; -# return unless ($in_poll or $el eq 'slideshow'); +# return unless ($in_poll or $el eq 'slideshow'); - unless ($in_poll) { - $in_poll = $xp->depth + 1; - return; - } + 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"; + } - if ($Mode) { + # skip does nothing + return; + } - if ($Mode eq 'pass') { - $Markedup_Text .= "\n" . $xp->recognized_string; - } - elsif ($Mode eq 'object') { - push(@Ostack, $Object); + unless ($after_head) { + if ($el eq 'head') { + $after_head = 1; + start_mode($xp, 'object'); - $Object = {_Atts => \%atts, - _Text => '' - }; - bless $Object, "Slideobj::$el"; - } + push(@closure_stack, $closure); + $closure = sub { + my ($xp, $text) = @_; - # skip does nothing - return; - } + unless (defined $text) { + $header = $Object; + } + }; + 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; - } - }; +# die "The head element must be the first thing in the slideshow"; + } - return; - } -# die "The head element must be the first thing in the slideshow"; - } + my $new_closure; + my $subname = "Poll::$el"; - my $new_closure; + if (defined &$subname) { + no strict 'refs'; - my $subname = "Poll::$el"; + &$subname($xp, $el, \%atts, \$new_closure); + } else { + $body .= x($xp->recognized_string); + $new_closure = sub { + my ($xp, $text) = @_; - 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(""); + if (defined $text) { + $body .= x($text); + } else { + $body .= x(""); + } + }; } - }; - } - push(@closure_stack, $closure); - $closure = $new_closure; -} # End starthndl + push(@closure_stack, $closure); + $closure = $new_closure; +} # End starthndl sub endhndl { - my ($xp, $el) = @_; + my ($xp, $el) = @_; - return unless $in_poll; + return unless $in_poll; - my $lev = $xp->depth; + 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); - } + 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; - } + $Mode = $Mode_level = 0; + } - if ($Mode) { - if ($Mode eq 'pass') { - $Markedup_Text .= ""; - } - 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; - } - } + if ($Mode) { + if ($Mode eq 'pass') { + $Markedup_Text .= ""; + } elsif ($Mode eq 'object') { + my $this = $Object; + if (2 == keys %$this) { + $this = $this->{_Text}; + } - return; - } + $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($xp) if defined $closure; - $closure = pop(@closure_stack); + $closure = pop(@closure_stack); } # End endhndl #---------------------------------------------------------- sub text { - my ($xp, $data) = @_; + my ($xp, $data) = @_; - return unless $in_poll; + return unless $in_poll; - if ($Mode ) { + if ($Mode) { - if ($Mode eq 'pass') { - my $safe = sgml_escape($data); + if ($Mode eq 'pass') { + my $safe = sgml_escape($data); - $Text .= $safe; - $Markedup_Text .= $safe; - } - elsif ($Mode eq 'object') { - $Object->{_Text} .= $data - if $data =~ /\S/; - } + $Text .= $safe; + $Markedup_Text .= $safe; + } elsif ($Mode eq 'object') { + $Object->{_Text} .= $data if $data =~ /\S/; + } - return; - } + return; + } - &$closure($xp, sgml_escape($data)) - if (defined $closure); + &$closure($xp, sgml_escape($data)) if (defined $closure); } # End text sub start_mode { - my ($xp, $mode) = @_; + my ($xp, $mode) = @_; - if ($mode eq 'pass') { - $Text = ''; - $Markedup_Text = ''; - } - elsif ($mode eq 'object') { - $Object = {_Atts => undef, - _Text => undef - }; - } + if ($mode eq 'pass') { + $Text = ''; + $Markedup_Text = ''; + } elsif ($mode eq 'object') { + $Object = { + _Atts => undef, + _Text => undef + }; + } - $Mode = $mode; - $Mode_level = $xp->depth; + $Mode = $mode; + $Mode_level = $xp->depth; } # End start_mode sub sgml_escape { - my ($str) = @_; + my ($str) = @_; - $str =~ s/\&/\&/g; - $str =~ s//\>/g; + $str =~ s/\&/\&/g; + $str =~ s//\>/g; - $str; + $str; } # End sgml_escape - ################################################################ package Poll; @@ -476,7 +510,7 @@ @sql_update = (); $last_fn=sprintf("%02d.php",$page_nr); - $last_page="$html_header $body $html_next $html_footer"; + $last_page="$html{'header'} $body $html{'submit'} $html{'footer'}"; # delete vars for next page $page_nr++; $body=""; @@ -489,18 +523,18 @@ my ($xp, $el, $attref, $ncref) = @_; - $pitanje_tag=""; + $question_tag=""; $$ncref = sub { my ($xp, $text) = @_; if (defined($text)) { $body.=x($text); chomp $text; - $pitanje_tag .= x($text); + $question_tag .= x($text); } else { - $pitanje_nr = $pitanje_tag; - $pitanje_nr =~ s/[^0-9a-zA-Z]//g; - print "$pitanje_nr "; + $question_nr{$q_type} = $question_tag; + $question_nr{$q_type} =~ s/[^0-9a-zA-Z]//g; + print "$question_nr{$q_type} "; } $p_suffix=""; }; @@ -508,19 +542,24 @@ sub hr { - $body .= "
$html_separator
"; -} - -sub br { - $body .= "
\n"; + $body .= $html{'hr_before'}.$html{'separator'}.$html{'hr_after'}; } -sub pit { +sub que { package main; my ($xp, $el, $attref, $ncref) = @_; - $body.="

"; + my $nonum = x($attref->{unnumbered}); + if ($nonum) { + $q_type = $u_db_col; # unnumbered questions + } else { + $q_type = $q_db_col; + } + + $question_nr{$q_type}++; + + $body.=$html{'que_before'} if ($html{'que_before'}); $$ncref = sub { my ($xp, $text) = @_; @@ -528,43 +567,44 @@ if (defined $text) { $body.=x($text); } else { - $body.="

"; + $body.=$html{'que_after'} if ($html{'que_after'}); } } } -sub podpit { +sub subque { package main; my ($xp, $el, $attref, $ncref) = @_; - $body.=''; + $body.=$html{'subque_before'} if ($html{'subque_before'}); + $$ncref = sub { my ($xp, $text) = @_; if (defined $text) { $body.=x($text); } else { - $body.="
"; + $body.=$html{'subque_after'} if ($html{'subque_after'}); } } } -sub odg { +sub ans { package main; my ($xp, $el, $attref, $ncref) = @_; - $body .= "

"; - + $body.=$html{'ans_before'} if ($html{'ans_before'}); + $$ncref = sub { my ($xp, $text) = @_; if (defined $text) { $body .= x($text); } else { - $body .= "

"; + $body.=$html{'ans_after'} if ($html{'ans_after'}); } } } @@ -597,21 +637,24 @@ 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; + $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(); + my $p=new_que(); $body.="\n"; push @sql_create,"$p text"; push @sql_update,"$p='\$$p'"; @@ -648,10 +691,16 @@ $$ncref = sub { my ($xp, $text) = @_; if (! defined $text) { - my $nr=$attref->{nr}; - my $p=new_pit(); + my $nr=$attref->{nr} || die "need for number of buttons"; + # shownumbers="before|after" + my $shownumbers=lc(x($attref->{shownumbers})) || 'no'; + my $p=new_que(); for (my $i=1; $i<=$nr; $i++) { - $body.=" "; + $body.=""; + $body.=$i if ($shownumbers eq "before"); + $body.=""; + $body.=$i if ($shownumbers eq "after"); + $body.=" "; } push @sql_create,"$p int4"; push @sql_update,"$p=\$$p"; @@ -671,12 +720,12 @@ if (defined $text) { chomp $text; $text=~s/^\s*//g; - $text=~s/^[\d\.\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 $p=new_que(); my $id=1; foreach $opt (@radiobuttons_data) { if (defined($opt) && $opt ne "") { @@ -695,7 +744,7 @@ $$ncref = sub { my ($xp, $text) = @_; - my $p=new_pit(); + my $p=new_que(); $body.="\n"; push @sql_create,"$p text"; push @sql_update,"$p='\$$p'"; @@ -716,12 +765,12 @@ if (defined $text) { chomp $text; $text=~s/^\s*//g; - $text=~s/^[\d\.\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 $base_p=new_que(); my $id=1; my $before=$attref->{before}; @@ -754,13 +803,68 @@ } } +# +# insert arbitrary html +# +sub html { + package main; + + my ($xp, $el, $attref, $ncref) = @_; + + $body.=$html{'html_before'} if ($html{'html_before'}); + + $$ncref = sub { + my ($xp, $text) = @_; + + if (defined $text) { + $body.=x($text); + } elsif ($attref->{include}) { + $body.=suck_file($attref->{include}); + } else { + $body.=$html{'html_after'} if ($html{'html_after'}); + } + } +} + +# +# markup tag can specify any markup which should be applied pre (before) +# or post (after) any other tag which produces html output +# + +sub markup { + package main; + + my ($xp, $el, $attref, $ncref) = @_; + + $$ncref = sub { + my ($xp, $text) = @_; + + my $tag=lc($attref->{tag}) || die 'markup need tag attribute: '; + my $pos=lc($attref->{pos}) || die 'markup need pos attribute: '; + + return if (! defined $text); + chomp($text); + if ($text ne "") { + $text =~ s/\&/\&/g; + $text =~ s/\<//g; + $text =~ s/^\s+//g; + $text =~ s/\s+$//g; + $html{$tag.'_'.$pos}=x($text); + print "Using markup $pos $tag: ",x($text),"<--\n"; + } + } +} + +# +# print final instructions and exit +# + print "\n\nTo create database for poll $poll use:\n\n"; print "\$ psql template1 < $poll/$poll.sql\n\n"; print "THIS WILL DISTROY ALL DATA IN EXISTING DATABASE ".$prefix.$poll." !!\n"; # read configuration data -# -# FIX: write actually this :-) sub config { package main; my ($xp, $el, $attref, $ncref) = @_; @@ -769,7 +873,22 @@ my ($xp, $text) = @_; $db_user=x($attref->{db_user}); $prefix=x($attref->{prefix}); - $without_invitation=x($attref->{without_invitation}); + $without_invitation=x($attref->{without_invitation}) && + print "Pool is without need for unique ID (and invitation URLs).\n"; + $remove_nrs_in_answers=x($attref->{remove_nrs_in_answers}) && + print "Numbers before answers will be removed.\n"; + + # fill in configuration about include files + foreach my $file (qw(header separator submit footer thanks)) { + if ($attref->{$file}) { + $include_files{$file}=x($attref->{$file}); + print "Using custom $file '$include_files{$file}'\n"; + $html{$file} = suck_file($include_files{$file}); + } + } + $q_db_col=x($attref->{q_db_col}) || 'q'; + $u_db_col=x($attref->{u_db_col}) || 'u'; + } }