/[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

Contents of /make_poll.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Tue Oct 21 15:15:08 2003 UTC (20 years, 5 months ago) by dpavlin
Branch: MAIN
Changes since 1.12: +18 -0 lines
File MIME type: text/plain
added html tag for arbitrary html insertion

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

  ViewVC Help
Powered by ViewVC 1.1.26