/[wopi]/make_poll.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /make_poll.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Sat Nov 8 01:08:44 2003 UTC (20 years, 4 months ago) by dpavlin
Branch: MAIN
Changes since 1.16: +33 -8 lines
File MIME type: text/plain
Added two type of questions: numbered (normal, by default in database as q
columns) and unnumbered (in database u colums).
Added q_db_col="x" and u_db_col="y" to rename database colums for numbered
and unnumbered questions to x and y respectivly in <config>
Added <radiobuttons_tab shownumbers="before|after"> to add numbers
Question numbers increase on each <que> tag if you don't use nr to number
then manually.

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

  ViewVC Help
Powered by ViewVC 1.1.26