/[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.22 - (hide annotations)
Mon Apr 19 16:33:10 2004 UTC (15 years, 2 months ago) by dpavlin
Branch: MAIN
CVS Tags: HEAD
Changes since 1.21: +27 -1 lines
File MIME type: text/plain
ask to copy template into poll's dir if they don't exist

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.14 use Carp;
13 dpavlin 1.21 use Text::Iconv;
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 dpavlin 1.21 # output encoding for files, probably defined in header.html also
112     my $html_encoding="ISO-8859-2";
113    
114     Text::Iconv->raise_error(1); # Conversion errors raise exceptions
115     my $iconv;
116    
117     # convert UTF8 (as from XML file) to 8-bit encoding
118     sub x {
119     if (! $iconv) {
120     $iconv = Text::Iconv->new('UTF8', $html_encoding);
121     print "output encoding is $html_encoding\n";
122     }
123     return $iconv->convert($_[0]);
124     }
125    
126     1;
127 dpavlin 1.17
128 dpavlin 1.1 #------------------------------------------------------------------
129    
130 dpavlin 1.2 sub suck_file {
131 dpavlin 1.14 my $file = shift || croak "suck_file called without argument";
132 dpavlin 1.22 if (! -f $file) {
133     my $template_file = $file;
134     $template_file =~ s,^.*?/*([^/]+)$,$1,;
135     if (-f $template_file) {
136     print "WARNING: can't find '$file', copy template '$template_file' ? [Y/n]: ";
137     my $a = <STDIN>;
138     chomp $a;
139     if ($a =~ m/^y/i || $a eq "") {
140     open(I,$template_file) || die "FATAL: can't open template file '$template_file': $!";
141     open(O,"> $file") || die "FATAL: can't create '$file' from template: $!";
142     while(<I>) {
143     print O $_;
144     }
145     close(I);
146     close(O);
147     print "File '$file' created from template '$template_file'\n";
148     }
149     }
150    
151     }
152    
153     if (! -f $file) {
154     print STDERR "FATAL: please create file $file and then re-run this script!\n";
155     exit 1;
156     }
157    
158     open(H,$file) || die "FATAL: can't open '$file': $!";
159 dpavlin 1.2 my $content;
160     while (<H>) { $content .= $_; } ;
161     close(H);
162     return $content;
163     }
164 dpavlin 1.1
165 dpavlin 1.14 $html{'header'}=suck_file($include_files{'header'});
166     $html{'separator'}=suck_file($include_files{'separator'});
167     $html{'submit'}=suck_file($include_files{'submit'});
168     $html{'footer'}=suck_file($include_files{'footer'});
169 dpavlin 1.1
170     #------------------------------------------------------------------
171    
172     sub php_header {
173     my ($page_nr,@sql_update) = @_;
174 dpavlin 1.3 my $out='<?php
175 dpavlin 1.6 include_once("common.php");
176 dpavlin 1.1 if (isset($update)) {
177     $member_id=id_decode($a);
178     ';
179     $out.=$php_addon[$page_nr-2] if (defined $php_addon[$page_nr-2]);
180     $out.='
181 dpavlin 1.6 $sql="update '.$poll.' set '.join(",\n",@sql_update).',
182 dpavlin 1.1 do_stranice=\'$PHP_SELF\'
183     where id=$id";
184 dpavlin 1.7 # print "<pre>$sql</pre>";
185 dpavlin 1.1 $result=pg_Exec($conn,fix_sql($sql));
186 dpavlin 1.6 } elseif($do_stranice != $PHP_SELF && isset($do_uri) && isset($a)) {
187 dpavlin 1.1 Header("Location: $do_uri?a=$a");
188     exit;
189     }
190     ?>';
191     return $out;
192     }
193    
194     #------------------------------------------------------------------
195    
196     # first, define some constants
197 dpavlin 1.3 my $common_php = suck_file("common.php");
198 dpavlin 1.1
199     #------------------------------------------------------------------
200    
201 dpavlin 1.2 my $head_php=suck_file("head.php");
202 dpavlin 1.1
203     #------------------------------------------------------------------
204    
205 dpavlin 1.16 $html{'thanks'}=suck_file($include_files{'thanks'});
206 dpavlin 1.1
207     #------------------------------------------------------------------
208    
209     while (defined($ARGV[0]) and $ARGV[0] =~ /^-/) {
210     my $opt = shift;
211    
212     if ($opt eq '-h') {
213     print $Usage;
214     exit;
215     }
216     } # End of option processing
217    
218 dpavlin 1.4 my $xmlfile = shift;
219 dpavlin 1.1
220 dpavlin 1.4 die "No poll xml file provided!\n$Usage" unless defined $xmlfile;
221 dpavlin 1.1
222 dpavlin 1.4 die "Can't read $xmlfile" unless -r $xmlfile;
223 dpavlin 1.1
224 dpavlin 1.6 if (defined $poll) {
225     die "$poll isn't a directory" unless -d $poll;
226 dpavlin 1.1 }
227     else {
228 dpavlin 1.4 $xmlfile =~ m!([^/.]+)(?:\.[^/.]*)?$!;
229 dpavlin 1.6 $poll = $1;
230     if (-e $poll) {
231     die "$poll exists but isn't a directory"
232     unless -d $poll;
233 dpavlin 1.1 }
234     else {
235 dpavlin 1.6 mkdir $poll, 0755;
236 dpavlin 1.1 }
237     }
238    
239 dpavlin 1.4 my $in_poll = 0;
240 dpavlin 1.1 my $after_head = 0;
241    
242     my $Mode = 0;
243     my $Mode_level = 0;
244    
245     my $Text;
246     my $Markedup_Text;
247     my $Object;
248     my @Ostack = ();
249    
250 dpavlin 1.4 #my $intext = 0;
251 dpavlin 1.1 my $closure;
252     my @closure_stack = ();
253    
254 dpavlin 1.4 #my $style_link = '';
255 dpavlin 1.1
256 dpavlin 1.4 #my $index = 'index.html';
257     #my @slidetitle;
258 dpavlin 1.1 my $body;
259 dpavlin 1.4 #my $inlist = 0;
260 dpavlin 1.1
261 dpavlin 1.4 #my @Titles;
262 dpavlin 1.1
263     my $header;
264    
265     my $page_number = 0;
266    
267     my $p = new XML::Parser(ErrorContext => 3,
268     Handlers => {Start => \&starthndl,
269     End => \&endhndl,
270     Char => \&text});
271 dpavlin 1.4 $p->parsefile($xmlfile);
272 dpavlin 1.1
273     #----------------------------------------------------------
274    
275     # dump last php page....
276    
277     print "p[$page_nr] ";
278    
279 dpavlin 1.6 open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
280 dpavlin 1.1 print PAGE php_header($page_nr,@prelast_sql_update);
281     my $next_fn=sprintf("%02d.php",$page_nr);
282     $last_page=~s/##NEXTPAGE##/$next_fn/;
283     print PAGE $last_page;
284     close(PAGE);
285    
286     $page_nr++;
287 dpavlin 1.6 open(PAGE, ">$poll/$next_fn") or die "Couldn't open $next_fn for writing:\n$!";
288 dpavlin 1.1 print PAGE php_header($page_nr,@last_sql_update);
289 dpavlin 1.16 print PAGE "$html{'header'} $html{'thanks'} $html{'footer'}";
290 dpavlin 1.1 close(PAGE);
291    
292     # dump sql structure
293    
294 dpavlin 1.6 open(SQL,">$poll/$poll.sql") || die "$poll.sql: $!";
295 dpavlin 1.8 print SQL "drop database ".$prefix.$poll.";\n";
296     print SQL "create database ".$prefix.$poll.";\n";
297     print SQL "\\connect ".$prefix.$poll.";\n";
298 dpavlin 1.1 print SQL "create table poslani ( member_id int4 not null, unesen timestamp default now() );\n";
299 dpavlin 1.6 print SQL "create table $poll (do_stranice text default null, ",join(",\n",@sql_create),");\n";
300 dpavlin 1.1 close(SQL);
301    
302 dpavlin 1.3 # dump common.php
303    
304 dpavlin 1.6 open(PHP,">$poll/common.php") || die "common.php: $!";
305     $common_php =~ s/##DB##/$poll/g;
306     my $db_name = $prefix.$poll;
307 dpavlin 1.3 $common_php =~ s/##DB_NAME##/$db_name/g;
308     $common_php =~ s/##PREFIX##/$prefix/g;
309     $common_php =~ s/##DB_USER##/$db_user/g;
310     $common_php =~ s/##PREFIX##/$prefix/g;
311     my $members_db = $prefix."members";
312     $common_php =~ s/##MEMBERS_DB##/$members_db/g;
313 dpavlin 1.9 $common_php =~ s/##WITHOUT_INVITATION##/$without_invitation/g;
314 dpavlin 1.1
315 dpavlin 1.3 print PHP $common_php;
316 dpavlin 1.1 close(PHP);
317    
318 dpavlin 1.6 open(PHP,">$poll/head.php") || die "head.php: $!";
319 dpavlin 1.3 my $max_page = $page_nr - 1;
320 dpavlin 1.2 $head_php=~ s/##MAXPAGE##/$max_page/;
321     $head_php=~ s/##TEXT##/Ispunili ste %02d%% ankete/;
322 dpavlin 1.1 print PHP $head_php;
323     close(PHP);
324    
325 dpavlin 1.4 # 01.php -> index.php
326 dpavlin 1.6 rename "$poll/01.php","$poll/index.php" || die "can't rename '$poll/01.php' to index.php";
327 dpavlin 1.4
328 dpavlin 1.1 ################
329     ## End of main
330     ################
331    
332 dpavlin 1.15 # return unique name of question
333     sub new_que {
334 dpavlin 1.17 my $out=$q_type.( $question_nr{$q_type} || 0 );
335 dpavlin 1.8 $out .= "_".$p_suffix if ($p_suffix);
336 dpavlin 1.1 $curr_suffix=$p_suffix;
337     $p_suffix++;
338     return $out;
339     }
340    
341 dpavlin 1.15 # current question
342     sub curr_que {
343 dpavlin 1.17 return $q_type.( $question_nr{$q_type} || 0 ).$curr_suffix;
344 dpavlin 1.1 }
345    
346 dpavlin 1.4 #----------------------------------------------------------
347    
348 dpavlin 1.1 sub starthndl {
349 dpavlin 1.15 my ($xp, $el, %atts) = @_;
350 dpavlin 1.1
351 dpavlin 1.15 # return unless ($in_poll or $el eq 'slideshow');
352 dpavlin 1.1
353 dpavlin 1.15 unless ($in_poll) {
354     $in_poll = $xp->depth + 1;
355     return;
356     }
357 dpavlin 1.1
358 dpavlin 1.15 if ($Mode) {
359     if ($Mode eq 'pass') {
360     $Markedup_Text .= "\n" . $xp->recognized_string;
361     } elsif ($Mode eq 'object') {
362     push(@Ostack, $Object);
363 dpavlin 1.1
364 dpavlin 1.15 $Object = {
365     _Atts => \%atts,
366     _Text => ''
367     };
368     bless $Object, "Slideobj::$el";
369     }
370 dpavlin 1.1
371 dpavlin 1.15 # skip does nothing
372     return;
373     }
374    
375     unless ($after_head) {
376     if ($el eq 'head') {
377     $after_head = 1;
378     start_mode($xp, 'object');
379 dpavlin 1.1
380 dpavlin 1.15 push(@closure_stack, $closure);
381     $closure = sub {
382     my ($xp, $text) = @_;
383 dpavlin 1.1
384 dpavlin 1.15 unless (defined $text) {
385     $header = $Object;
386     }
387     };
388     return;
389     }
390 dpavlin 1.1
391 dpavlin 1.15 # die "The head element must be the first thing in the slideshow";
392     }
393 dpavlin 1.1
394    
395 dpavlin 1.15 my $new_closure;
396 dpavlin 1.1
397 dpavlin 1.15 my $subname = "Poll::$el";
398 dpavlin 1.1
399 dpavlin 1.15 if (defined &$subname) {
400     no strict 'refs';
401 dpavlin 1.1
402 dpavlin 1.15 &$subname($xp, $el, \%atts, \$new_closure);
403     } else {
404     $body .= x($xp->recognized_string);
405     $new_closure = sub {
406     my ($xp, $text) = @_;
407 dpavlin 1.1
408 dpavlin 1.15 if (defined $text) {
409     $body .= x($text);
410     } else {
411     $body .= x("</$el>");
412     }
413     };
414 dpavlin 1.1 }
415    
416 dpavlin 1.15 push(@closure_stack, $closure);
417     $closure = $new_closure;
418     } # End starthndl
419 dpavlin 1.1
420     sub endhndl {
421 dpavlin 1.15 my ($xp, $el) = @_;
422 dpavlin 1.1
423 dpavlin 1.15 return unless $in_poll;
424 dpavlin 1.1
425 dpavlin 1.15 my $lev = $xp->depth;
426 dpavlin 1.1
427 dpavlin 1.15 if ($lev == $in_poll - 1) {
428     $in_poll = 0;
429     $xp->finish;
430     return;
431     }
432    
433     if ($Mode_level == $lev) {
434    
435     if ($Mode eq 'pass') {
436     &$closure($xp, $Markedup_Text) if (defined $closure);
437     }
438    
439     $Mode = $Mode_level = 0;
440     }
441    
442     if ($Mode) {
443     if ($Mode eq 'pass') {
444     $Markedup_Text .= "</$el>";
445     } elsif ($Mode eq 'object') {
446     my $this = $Object;
447     if (2 == keys %$this) {
448     $this = $this->{_Text};
449     }
450 dpavlin 1.1
451 dpavlin 1.15 $Object = pop(@Ostack);
452 dpavlin 1.1
453 dpavlin 1.15 my $slot = $Object->{$el};
454     if (defined $slot) {
455     if (ref($slot) eq 'ARRAY') {
456     push(@$slot, $this);
457     } else {
458     $Object->{$el} = [$slot, $this];
459     }
460     } else {
461     $Object->{$el} = $this;
462     }
463     }
464 dpavlin 1.1
465 dpavlin 1.15 return;
466     }
467 dpavlin 1.1
468 dpavlin 1.15 &$closure($xp) if defined $closure;
469 dpavlin 1.1
470 dpavlin 1.15 $closure = pop(@closure_stack);
471 dpavlin 1.1 } # End endhndl
472    
473 dpavlin 1.4 #----------------------------------------------------------
474    
475 dpavlin 1.1 sub text {
476 dpavlin 1.15 my ($xp, $data) = @_;
477 dpavlin 1.1
478 dpavlin 1.15 return unless $in_poll;
479 dpavlin 1.1
480 dpavlin 1.15 if ($Mode) {
481 dpavlin 1.1
482 dpavlin 1.15 if ($Mode eq 'pass') {
483     my $safe = sgml_escape($data);
484 dpavlin 1.1
485 dpavlin 1.15 $Text .= $safe;
486     $Markedup_Text .= $safe;
487     } elsif ($Mode eq 'object') {
488     $Object->{_Text} .= $data if $data =~ /\S/;
489     }
490 dpavlin 1.1
491 dpavlin 1.15 return;
492     }
493 dpavlin 1.1
494 dpavlin 1.15 &$closure($xp, sgml_escape($data)) if (defined $closure);
495 dpavlin 1.1
496     } # End text
497    
498     sub start_mode {
499 dpavlin 1.15 my ($xp, $mode) = @_;
500 dpavlin 1.1
501 dpavlin 1.15 if ($mode eq 'pass') {
502     $Text = '';
503     $Markedup_Text = '';
504     } elsif ($mode eq 'object') {
505     $Object = {
506     _Atts => undef,
507     _Text => undef
508     };
509     }
510 dpavlin 1.1
511 dpavlin 1.15 $Mode = $mode;
512     $Mode_level = $xp->depth;
513 dpavlin 1.1 } # End start_mode
514    
515     sub sgml_escape {
516 dpavlin 1.15 my ($str) = @_;
517 dpavlin 1.1
518 dpavlin 1.15 $str =~ s/\&/\&amp;/g;
519     $str =~ s/</\&lt;/g;
520     $str =~ s/>/\&gt;/g;
521 dpavlin 1.1
522 dpavlin 1.15 $str;
523 dpavlin 1.1 } # End sgml_escape
524    
525     ################################################################
526    
527 dpavlin 1.4 package Poll;
528 dpavlin 1.1
529     sub page {
530     package main;
531    
532     my ($xp, $el, $attref, $ncref) = @_;
533    
534     $$ncref = sub {
535     my ($xp, $text) = @_;
536    
537     if (! defined $text) {
538    
539     print "p[$page_nr] ";
540    
541     if (defined $last_fn) {
542 dpavlin 1.6 open(PAGE, ">$poll/$last_fn") or die "Couldn't open $last_fn for writing:\n$!";
543 dpavlin 1.7 print PAGE php_header($page_nr,@prelast_sql_update);
544 dpavlin 1.1 my $next_fn=sprintf("%02d.php",$page_nr);
545     $last_page=~s/##NEXTPAGE##/$next_fn/;
546     print PAGE $last_page;
547     close(PAGE);
548    
549     }
550     @prelast_sql_update=@last_sql_update;
551     @last_sql_update=@sql_update;
552     @sql_update = ();
553    
554     $last_fn=sprintf("%02d.php",$page_nr);
555 dpavlin 1.14 $last_page="$html{'header'} $body $html{'submit'} $html{'footer'}";
556 dpavlin 1.1 # delete vars for next page
557     $page_nr++;
558     $body="";
559     }
560     }
561     } # page
562    
563     sub nr {
564     package main;
565    
566     my ($xp, $el, $attref, $ncref) = @_;
567    
568 dpavlin 1.15 $question_tag="";
569 dpavlin 1.1
570     $$ncref = sub {
571     my ($xp, $text) = @_;
572     if (defined($text)) {
573 dpavlin 1.4 $body.=x($text);
574 dpavlin 1.1 chomp $text;
575 dpavlin 1.15 $question_tag .= x($text);
576 dpavlin 1.1 } else {
577 dpavlin 1.17 $question_nr{$q_type} = $question_tag;
578     $question_nr{$q_type} =~ s/[^0-9a-zA-Z]//g;
579     print "$question_nr{$q_type} ";
580 dpavlin 1.1 }
581     $p_suffix="";
582     };
583     } # nr
584    
585    
586     sub hr {
587 dpavlin 1.15 $body .= $html{'hr_before'}.$html{'separator'}.$html{'hr_after'};
588 dpavlin 1.1 }
589    
590 dpavlin 1.15 sub que {
591 dpavlin 1.1 package main;
592    
593     my ($xp, $el, $attref, $ncref) = @_;
594    
595 dpavlin 1.17 my $nonum = x($attref->{unnumbered});
596     if ($nonum) {
597     $q_type = $u_db_col; # unnumbered questions
598     } else {
599     $q_type = $q_db_col;
600     }
601 dpavlin 1.20
602 dpavlin 1.17 $question_nr{$q_type}++;
603    
604 dpavlin 1.20 # attribute markup_before override que_before
605     my $markup_before = x($attref->{markup_before});
606     my $markup_after = x($attref->{markup_after});
607    
608     if (defined($markup_before)) {
609     $body.=$markup_before;
610     } elsif ($html{'que_before'}) {
611     $body.=$html{'que_before'}
612     }
613 dpavlin 1.1
614     $$ncref = sub {
615     my ($xp, $text) = @_;
616    
617     if (defined $text) {
618 dpavlin 1.2 $body.=x($text);
619 dpavlin 1.1 } else {
620 dpavlin 1.20 if (defined($markup_after)) {
621     $body.=$markup_after;
622     } elsif ($html{'que_after'}) {
623     $body.=$html{'que_after'}
624     }
625 dpavlin 1.1 }
626     }
627     }
628    
629 dpavlin 1.15 sub subque {
630 dpavlin 1.1 package main;
631    
632     my ($xp, $el, $attref, $ncref) = @_;
633    
634 dpavlin 1.20 my $markup_before = x($attref->{markup_before});
635     my $markup_after = x($attref->{markup_after});
636    
637     if (defined($markup_before)) {
638     $body.=$markup_before;
639     } elsif ($html{'subque_before'}) {
640     $body.=$html{'subque_before'}
641     }
642 dpavlin 1.15
643 dpavlin 1.1 $$ncref = sub {
644     my ($xp, $text) = @_;
645    
646     if (defined $text) {
647 dpavlin 1.2 $body.=x($text);
648 dpavlin 1.1 } else {
649 dpavlin 1.20 if (defined($markup_after)) {
650     $body.=$markup_after;
651     } elsif ($html{'subque_after'}) {
652     $body.=$html{'subque_after'}
653     }
654 dpavlin 1.1 }
655     }
656     }
657    
658    
659 dpavlin 1.15 sub ans {
660 dpavlin 1.1 package main;
661    
662     my ($xp, $el, $attref, $ncref) = @_;
663    
664 dpavlin 1.20 my $markup_before = x($attref->{markup_before});
665     my $markup_after = x($attref->{markup_after});
666    
667     if (defined($markup_before)) {
668     $body.=$markup_before;
669     } elsif ($html{'ans_before'}) {
670     $body.=$html{'ans_before'}
671     }
672 dpavlin 1.15
673 dpavlin 1.1 $$ncref = sub {
674     my ($xp, $text) = @_;
675    
676     if (defined $text) {
677 dpavlin 1.2 $body .= x($text);
678 dpavlin 1.1 } else {
679 dpavlin 1.20 if (defined($markup_after)) {
680     $body.=$markup_after;
681     } elsif ($html{'ans_after'}) {
682     $body.=$html{'ans_after'}
683     }
684 dpavlin 1.1 }
685     }
686     }
687    
688     sub php {
689     package main;
690     my ($xp, $el, $attref, $ncref) = @_;
691    
692     $body.="<?php\n";
693    
694     $$ncref = sub {
695     my ($xp, $text) = @_;
696    
697     if (defined $text) {
698     $text=~s/ lt / < /g;
699     $text=~s/ le / <= /g;
700     $text=~s/ gt / > /g;
701     $text=~s/ ge / >= /g;
702 dpavlin 1.2 $body.=x($text);
703 dpavlin 1.1 } else {
704     $body.="\n?>\n";
705     }
706     }
707     }
708    
709     sub dropdown {
710     package main;
711    
712     my ($xp, $el, $attref, $ncref) = @_;
713    
714     my @dropdown_data;
715    
716 dpavlin 1.12 my $default_value = x($attref->{default_value}) || 'null';
717     my $default_text = x($attref->{default_text}) || '-';
718    
719 dpavlin 1.1 $$ncref = sub {
720     my ($xp, $text) = @_;
721    
722     if (defined $text) {
723     chomp $text;
724     $text=~s/^\s*//g;
725 dpavlin 1.10 $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
726 dpavlin 1.1 $text=~s/\s*$//g;
727 dpavlin 1.2 push @dropdown_data,x($text) if ($text ne "");
728 dpavlin 1.1 } else {
729     my $opt;
730     my $id=1;
731 dpavlin 1.15 my $p=new_que();
732 dpavlin 1.1 $body.="<select name=$p >\n";
733 dpavlin 1.12 $body.="<option value=\"$default_value\">$default_text</option>\n";
734 dpavlin 1.1 foreach $opt (@dropdown_data) {
735     if (defined($opt) && $opt ne "") {
736     $body.="<option value=$id>$opt</option>\n";
737     $id++;
738     }
739     }
740     $body.="</select>\n";
741    
742     push @sql_create,"$p int4";
743     push @sql_update,"$p=\$$p";
744     }
745     }
746     }
747    
748     sub textbox {
749     package main;
750     my ($xp, $el, $attref, $ncref) = @_;
751    
752     $$ncref = sub {
753     my ($xp, $text) = @_;
754     my $size=$attref->{size};
755     $size = 25 if (! defined $size || $size == 0); # default
756 dpavlin 1.15 my $p=new_que();
757 dpavlin 1.2 $body.="<input type=text name=$p size=".x($size)." >\n";
758 dpavlin 1.1 push @sql_create,"$p text";
759     push @sql_update,"$p='\$$p'";
760     }
761     }
762    
763     sub radiobuttons_tab {
764     package main;
765     my ($xp, $el, $attref, $ncref) = @_;
766    
767     $$ncref = sub {
768     my ($xp, $text) = @_;
769     if (! defined $text) {
770 dpavlin 1.17 my $nr=$attref->{nr} || die "need <radiobuttons_tab nr=\"999\"> for number of buttons";
771     # shownumbers="before|after"
772     my $shownumbers=lc(x($attref->{shownumbers})) || 'no';
773 dpavlin 1.18 my $showlabels=lc(x($attref->{showlabels})) || 'no';
774 dpavlin 1.19 my $class=lc(x($attref->{class})) || '';
775     $class=' class="'.$class.'"' if ($class);
776 dpavlin 1.15 my $p=new_que();
777 dpavlin 1.1 for (my $i=1; $i<=$nr; $i++) {
778 dpavlin 1.19 $body.="<td$class>";
779 dpavlin 1.17 $body.=$i if ($shownumbers eq "before");
780 dpavlin 1.18 if ($showlabels eq "before" && $attref->{"label_$i"}) {
781     $body.=x($attref->{"label_$i"});
782     }
783 dpavlin 1.17 $body.="<input type=radio name=$p value=$i>";
784     $body.=$i if ($shownumbers eq "after");
785     $body.="</td> ";
786 dpavlin 1.1 }
787     push @sql_create,"$p int4";
788     push @sql_update,"$p=\$$p";
789     }
790     }
791     }
792    
793     sub radiobuttons {
794     package main;
795     my ($xp, $el, $attref, $ncref) = @_;
796    
797     my @radiobuttons_data;
798    
799     $$ncref = sub {
800     my ($xp, $text) = @_;
801    
802     if (defined $text) {
803     chomp $text;
804     $text=~s/^\s*//g;
805 dpavlin 1.10 $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
806 dpavlin 1.1 $text=~s/\s*$//g;
807 dpavlin 1.2 push @radiobuttons_data,x($text) if ($text ne "");
808 dpavlin 1.1 } else {
809     my $opt;
810 dpavlin 1.15 my $p=new_que();
811 dpavlin 1.1 my $id=1;
812     foreach $opt (@radiobuttons_data) {
813     if (defined($opt) && $opt ne "") {
814     $body.="<input type=radio name=$p value=$id> $opt<br>\n";
815     $id++;
816     }
817     }
818     push @sql_create,"$p int4";
819     push @sql_update,"$p=\$$p";
820     }
821     }
822     }
823     sub checkbox {
824     package main;
825     my ($xp, $el, $attref, $ncref) = @_;
826    
827     $$ncref = sub {
828     my ($xp, $text) = @_;
829 dpavlin 1.15 my $p=new_que();
830 dpavlin 1.1 $body.="<input type=checkbox name=$p >\n";
831     push @sql_create,"$p text";
832     push @sql_update,"$p='\$$p'";
833     }
834     }
835    
836     sub checkboxes {
837     package main;
838    
839     my ($xp, $el, $attref, $ncref) = @_;
840    
841     my @checkboxes_data;
842    
843     $$ncref = sub {
844     my ($xp, $text) = @_;
845    
846    
847     if (defined $text) {
848     chomp $text;
849     $text=~s/^\s*//g;
850 dpavlin 1.10 $text=~s/^[\d\.\s]+//g if ($remove_nrs_in_answers);
851 dpavlin 1.1 $text=~s/\s*$//g;
852 dpavlin 1.2 push @checkboxes_data,x($text) if ($text ne "");
853 dpavlin 1.1 } else {
854     my $opt;
855 dpavlin 1.15 my $base_p=new_que();
856 dpavlin 1.1 my $id=1;
857    
858     my $before=$attref->{before};
859     my $after=$attref->{after};
860     my $middle=$attref->{middle};
861     if (! $before && ! $after && ! $middle) {
862     $middle="&nbsp;";
863     $after="<br>";
864     }
865     my $hide_description=$attref->{hide_description};
866    
867     foreach $opt (@checkboxes_data) {
868     if (defined($opt) && $opt ne "") {
869     $p=$base_p."_".$id;
870     $id++;
871 dpavlin 1.2 $body .= x($before) if ($before);
872 dpavlin 1.1 $body.="<input type=checkbox name=$p>";
873 dpavlin 1.2 $body .= x($middle) if ($middle);
874 dpavlin 1.1 $body .= "$opt" if (! $hide_description);
875 dpavlin 1.2 $body .= x($after) if ($after);
876 dpavlin 1.1 $body.="\n";
877    
878     push @sql_create,"$p boolean";
879     push @sql_update,"$p=\$$p";
880     }
881     }
882     $php_addon[$page_nr].="fix_checkboxes($base_p,".($id-1).");";
883    
884     }
885 dpavlin 1.4 }
886     }
887 dpavlin 1.8
888 dpavlin 1.15 #
889     # insert arbitrary html
890     #
891 dpavlin 1.13 sub html {
892     package main;
893    
894     my ($xp, $el, $attref, $ncref) = @_;
895    
896 dpavlin 1.15 $body.=$html{'html_before'} if ($html{'html_before'});
897 dpavlin 1.13
898     $$ncref = sub {
899     my ($xp, $text) = @_;
900    
901     if (defined $text) {
902     $body.=x($text);
903 dpavlin 1.14 } elsif ($attref->{include}) {
904     $body.=suck_file($attref->{include});
905 dpavlin 1.13 } else {
906 dpavlin 1.15 $body.=$html{'html_after'} if ($html{'html_after'});
907 dpavlin 1.13 }
908     }
909     }
910    
911 dpavlin 1.15 #
912     # markup tag can specify any markup which should be applied pre (before)
913     # or post (after) any other tag which produces html output
914     #
915    
916     sub markup {
917     package main;
918    
919     my ($xp, $el, $attref, $ncref) = @_;
920    
921     $$ncref = sub {
922     my ($xp, $text) = @_;
923    
924     my $tag=lc($attref->{tag}) || die 'markup need tag attribute: <markup tag="tag_name" pos="(before|after)">';
925     my $pos=lc($attref->{pos}) || die 'markup need pos attribute: <markup tag="tag_name" pos="(before|after)">';
926    
927     return if (! defined $text);
928     chomp($text);
929     if ($text ne "") {
930     $text =~ s/\&amp;/\&/g;
931     $text =~ s/\&lt;/</g;
932     $text =~ s/\&gt;/>/g;
933     $text =~ s/^\s+//g;
934     $text =~ s/\s+$//g;
935     $html{$tag.'_'.$pos}=x($text);
936     print "Using markup $pos $tag: ",x($text),"<--\n";
937     }
938     }
939     }
940    
941     #
942     # print final instructions and exit
943     #
944    
945 dpavlin 1.8 print "\n\nTo create database for poll $poll use:\n\n";
946     print "\$ psql template1 < $poll/$poll.sql\n\n";
947     print "THIS WILL DISTROY ALL DATA IN EXISTING DATABASE ".$prefix.$poll." !!\n";
948 dpavlin 1.4
949     # read configuration data
950     sub config {
951     package main;
952     my ($xp, $el, $attref, $ncref) = @_;
953    
954     $$ncref = sub {
955     my ($xp, $text) = @_;
956 dpavlin 1.21 # encoding should be checked first since it also
957     # initialize iconv for conversion from XML's UTF-8
958     $html_encoding=$attref->{html_encoding} if ($attref->{html_encoding});
959 dpavlin 1.4 $db_user=x($attref->{db_user});
960     $prefix=x($attref->{prefix});
961 dpavlin 1.10 $without_invitation=x($attref->{without_invitation}) &&
962     print "Pool is without need for unique ID (and invitation URLs).\n";
963 dpavlin 1.15 $remove_nrs_in_answers=x($attref->{remove_nrs_in_answers}) &&
964 dpavlin 1.10 print "Numbers before answers will be removed.\n";
965 dpavlin 1.14
966 dpavlin 1.15 # fill in configuration about include files
967 dpavlin 1.14 foreach my $file (qw(header separator submit footer thanks)) {
968     if ($attref->{$file}) {
969     $include_files{$file}=x($attref->{$file});
970     print "Using custom $file '$include_files{$file}'\n";
971     $html{$file} = suck_file($include_files{$file});
972     }
973     }
974 dpavlin 1.17 $q_db_col=x($attref->{q_db_col}) || 'q';
975     $u_db_col=x($attref->{u_db_col}) || 'u';
976 dpavlin 1.15
977 dpavlin 1.21
978 dpavlin 1.1 }
979     }
980    
981     #---------------------------------------------------------------

  ViewVC Help
Powered by ViewVC 1.1.26