selfforum-cgi/user/fo_posting.pl

   1 #!/usr/bin/perl -w
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        user/fo_posting.pl                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-04-08                          #
   8 #                                                                              #
   9 # Description: Accept new postings, display "Neue Nachricht" page              #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   $Bin
  16   $Shared
  17   $Script
  18   $Config
  19 );
  20
  21 # locate the script
  22 #
  23 BEGIN {
  24   my $null = $0; $null =~ s/\\/\//g; # for win :-(
  25   $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  26   $Shared  = "$Bin/../shared";
  27   $Config  = "$Bin/config";
  28   $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  29
  30 #  my $null = $0; #$null =~ s/\\/\//g; # for win :-(
  31 #  $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  32 #  $Config  = "$Bin/../../../cgi-config/devforum";
  33 #  $Shared  = "$Bin/../../../cgi-shared";
  34 #  $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  35 }
  36
  37 use lib "$Shared";
  38 use CGI::Carp qw(fatalsToBrowser);
  39
  40 use Conf;
  41 use Conf::Admin;
  42 use Posting::Cache;
  43
  44 # load script configuration and admin default conf.
  45 #
  46 my $conf         = read_script_conf ($Config, $Shared, $Script);
  47 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
  48
  49 # Initialize the request
  50 #
  51 my $request = new Posting::Request ($conf, $adminDefault);
  52
  53 # fetch and parse the cgi-params
  54 #
  55 $request -> parse_cgi;
  56
  57 # handle errors or save the posting
  58 #
  59 $request -> handle_error or $request -> save;
  60
  61 # show response
  62 #
  63 $request -> response;
  64
  65 #
  66 #
  67 ### main end ###################################################################
  68
  69 ################################################################################
  70 ### Posting::Request ###########################################################
  71 package Posting::Request;
  72
  73 use CheckRFC;
  74 use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
  75 use Encode::Posting;
  76 use Lock          qw(:ALL);
  77 use Posting::_lib qw(
  78   hr_time
  79   parse_xml_file
  80   get_all_threads
  81   get_message_node
  82   get_message_header
  83   KEEP_DELETED
  84 );
  85 use Posting::Write;
  86 use Id;
  87 use Template;
  88 use Template::Posting;
  89
  90 use CGI;
  91
  92 ### sub new ####################################################################
  93 #
  94 # initialising the Posting::Request object
  95 # check parameters and fill in object properties
  96 #
  97 sub new {
  98   my ($class, $conf, $adminDefault) = @_;
  99
 100   my $sp = $conf -> {show} -> {Posting};
 101
 102   my $self = {
 103        conf => {
 104          original => $conf,
 105          admin    => $adminDefault,
 106
 107          message_path    => $conf -> {files} -> {messagePath},
 108          forum_file_name => $conf -> {files} -> {forum},
 109
 110          show_posting    => $sp,
 111          assign          => $sp -> {assign},
 112          template        => $conf -> {template},
 113          form_must       => $sp -> {form} -> {must},
 114          form_data       => $sp -> {form} -> {data},
 115          form_action     => $sp -> {form} -> {action},
 116        },
 117
 118        template => new Template $sp -> {templateFile},
 119        response => {},
 120        forum    => {},
 121        error    => {}
 122      };
 123
 124   bless $self, $class;
 125 }
 126
 127 ### sub response ###############################################################
 128 #
 129 # print the response to STDOUT
 130 #
 131 # Return: -none-
 132 #
 133 sub response {
 134   my $self = shift;
 135   my $formdata = $self -> {conf} -> {form_data};
 136   my $formact  = $self -> {conf} -> {form_action};
 137   my $template = $self -> {template};
 138   my $assign   = $self -> {conf} -> {assign};
 139   my $q        = $self -> {cgi_object};
 140
 141   # fill out the form field names
 142   #
 143   my $pars = {};
 144   for (keys %$formdata) {
 145     $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name}) if (
 146       exists($formdata -> {$_} -> {name})
 147       and exists ($formdata -> {$_} -> {assign})
 148       and exists ($formdata -> {$_} -> {assign} -> {name})
 149     );
 150   }
 151
 152   # response the 'new message' page
 153   #
 154   if ($self -> {response} -> {new_thread}) {
 155
 156     # fill in the default form data
 157     # and optionlist(s)
 158     #
 159     my $default = {};
 160     for (keys %$formdata) {
 161       unless (exists ($formdata -> {$_} -> {type}) and $formdata -> {$_} -> {type} eq 'internal') {
 162         if (exists ($formdata -> {$_} -> {default}) and exists ($formdata -> {$_} -> {assign} -> {value})) {
 163           $default -> {$formdata -> {$_} -> {assign} -> {value}}
 164           = $formdata -> {$_} -> {default};
 165         }
 166         elsif (exists($formdata -> {$_} -> {values})) {
 167           my ($_name, $val) = $_;
 168           $val = exists ($formdata -> {$_} -> {default})
 169             ? $formdata -> {$_} -> {default}
 170             : undef;
 171           $default -> {$formdata -> {$_} -> {assign} -> {value}}
 172           = $self -> {template} -> list (
 173               $assign -> {option},
 174               [ map {
 175                   { $assign -> {optval} => plain($_),
 176                     ((defined $val and $_ eq $val)
 177                       ? ($assign -> {optsel} => 1)
 178                       : ()
 179                     )
 180                   }
 181                 } @{$formdata -> {$_name} -> {values}}
 182               ]
 183             );
 184         }
 185       }
 186     }
 187
 188     print $q -> header (-type => 'text/html');
 189     print ${$template -> scrap (
 190       $assign -> {docNew},
 191       { $formdata->{uniqueID}      ->{assign}->{value} => plain(unique_id),
 192         $formdata->{quoteChar}     ->{assign}->{value} => '&#255;'.plain($self -> {conf} -> {admin} -> {View} -> {quoteChars}),
 193         $formact->{post}->{assign}                     => $formact->{post}->{url},
 194       },
 195       $pars,
 196       $default
 197     )};
 198     return;
 199   }
 200
 201   # check the response -> doc
 202   #
 203   unless ($self -> {response} -> {doc}) {
 204     $self -> {error} = {
 205       spec => 'unknown_error',
 206       type => 'fatal'
 207     };
 208
 209     $self -> handle_error;
 210
 211     unless ($self -> {response} -> {doc}) {
 212       $self -> jerk ('While producing the HTML response an unknown error has occurred.');
 213       return;
 214     }
 215   }
 216
 217   # ok, print the response document to STDOUT
 218   #
 219   print $q -> header (-type => 'text/html');
 220   print ${$template -> scrap (
 221       $self -> {response} -> {doc},
 222       $pars,
 223       $self -> {response} -> {pars}
 224     )
 225   };
 226
 227   return;
 228 }
 229
 230 ### sub handle_error ###########################################################
 231 #
 232 # analyze error data and create content for the response method
 233 #
 234 # Return: true  if error detected
 235 #         false otherwise
 236 #
 237 sub handle_error {
 238   my $self = shift;
 239
 240   my $spec = $self -> {error} -> {spec};
 241
 242   return unless ($spec);
 243
 244   my $assign   = $self -> {conf} -> {assign};
 245   my $formdata = $self -> {conf} -> {form_data};
 246
 247   my $desc = $self -> {error} -> {desc} || '';
 248   my $type = $self -> {error} -> {type};
 249   my $emsg;
 250
 251   if (exists ($formdata -> {$desc})
 252       and exists ($formdata -> {$desc} -> {assign} -> {$spec})) {
 253     $emsg = $formdata -> {$desc} -> {assign} -> {$spec};
 254   }
 255   else {
 256     $emsg = $assign -> {$spec} || '';
 257   }
 258
 259   # fatal errors
 260   #
 261   if ($type eq 'fatal') {
 262     $self -> {response} -> {doc}  = $assign -> {docFatal};
 263     $self -> {response} -> {pars} = {
 264       $assign -> {errorMessage} => $self -> {template} -> insert ($emsg)
 265     };
 266   }
 267
 268   # 'soft' errors
 269   # user is able to repair his request
 270   #
 271   elsif ($type eq 'repeat' or $type eq 'fetch') {
 272     $self -> {response} -> {doc} = $assign -> {docError};
 273     $self -> fillout_form;
 274     $self -> {response} -> {pars} -> {$assign -> {errorMessage}} = $self -> {template} -> insert ($emsg);
 275     my $num = $spec eq 'too_long'
 276       ? $formdata -> {$desc} -> {maxlength}
 277       : ($spec eq 'too_short'
 278           ? $formdata -> {$desc} -> {minlength}
 279           : undef
 280         );
 281
 282     $self -> {response} -> {pars} -> {$assign -> {charNum}} = $num
 283       if $num;
 284   }
 285
 286   1;
 287 }
 288
 289 ### sub fillout_form ###########################################################
 290 #
 291 # fill out the form using available form data
 292 #
 293 # Return: -none-
 294 #
 295 sub fillout_form {
 296   my $self = shift;
 297
 298   my $assign   = $self -> {conf} -> {assign};
 299   my $formdata = $self -> {conf} -> {form_data};
 300   my $formact  = $self -> {conf} -> {form_action};
 301   my $q        = $self -> {cgi_object};
 302   my $pars     = {};
 303
 304   # fill out the form
 305   #
 306   $pars -> {$formact -> {post} -> {assign}} = $formact -> {post} -> {url};
 307
 308   for (keys %$formdata) {
 309     if ($_ eq 'quoteChar') {
 310       $pars -> {$formdata->{$_}->{assign}->{value}}
 311       = '&#255;'.plain($q -> param ($formdata -> {quoteChar} -> {name}) or '');
 312     }
 313     elsif (exists ($formdata -> {$_} -> {name})) {
 314       unless (exists ($formdata -> {$_} -> {values})) {
 315         $pars -> {$formdata -> {$_} -> {assign} -> {value}}
 316         = plain($q -> param ($formdata -> {$_} -> {name}));
 317       }
 318       else {
 319         my $_name = $_;
 320         $pars -> {$formdata -> {$_} -> {assign} -> {value}}
 321         = $self -> {template} -> list (
 322             $assign -> {option},
 323             [ map {
 324                 { $assign -> {optval} => plain($_),
 325                   (( $_ eq $q -> param ($formdata -> {$_name} -> {name}))
 326                     ? ($assign -> {optsel} => 1)
 327                     : ()
 328                   )
 329                 }
 330               } @{$formdata -> {$_name} -> {values}}
 331             ]
 332           );
 333       }
 334     }
 335   }
 336
 337   $self -> {response} -> {pars} = $pars;
 338   return;
 339 }
 340
 341 ### sub save ###################################################################
 342 #
 343 # save posting
 344 # check on legal reply or dupe is released here
 345 #
 346 # Return: -none-
 347 #
 348 sub save {
 349   my $self = shift;
 350
 351   # if an empty 'new message' document, there's nothing to save
 352   #
 353   return if ($self -> {response} -> {new_thread});
 354
 355   $self -> {check_success} = 0;
 356
 357   # lock and load the forum main file
 358   #
 359   if ($self -> load_main_file) {
 360
 361     # if a reply - is it legal?
 362     # is it a dupe?
 363     #
 364     if ($self -> check_reply_dupe) {
 365
 366       unless ($self -> {response} -> {reply} or $self -> {response} -> {new}) {
 367         # don't know, if we any time come to this branch
 368         # the script is probably broken
 369         #
 370         $self -> {error} = {
 371           spec => 'unknown_error',
 372           type => 'fatal'
 373         };
 374       }
 375       else {
 376         my $time     = time;
 377         my $formdata = $self -> {conf} -> {form_data};
 378         my $q        = $self -> {cgi_object};
 379         my $f        = $self -> {forum};
 380         my $pars     = {
 381           quoteChars    => $q -> param ($formdata -> {quoteChar} -> {name}),
 382           uniqueID      => $q -> param ($formdata -> {uniqueID} -> {name}),
 383           time          => $time,
 384           ip            => $q -> remote_addr,
 385           forumFile     => $self -> {conf} -> {forum_file_name},
 386           messagePath   => $self -> {conf} -> {message_path},
 387           lastThread    => $f -> {last_thread},
 388           lastMessage   => $f -> {last_message},
 389           parsedThreads => $f -> {threads},
 390           dtd           => $f -> {dtd},
 391           messages      => $self -> {conf} -> {template} -> {messages} || {},
 392           base_uri      => $self -> {conf} -> {original} -> {files} -> {forum_base}
 393         };
 394
 395         # set the variables if defined..
 396         #
 397         my %may = (
 398           author   => 'posterName',
 399           email    => 'posterEmail',
 400           category => 'posterCategory',
 401           subject  => 'posterSubject',
 402           body     => 'posterBody',
 403           homepage => 'posterURL',
 404           image    => 'posterImage'
 405         );
 406
 407         for (keys %may) {
 408           $pars -> {$_} = $q -> param ($formdata -> {$may{$_}} -> {name})
 409             if (defined $q -> param ($formdata -> {$may{$_}} -> {name}));
 410         }
 411
 412         my ($stat, $xml, $mid, $tid);
 413
 414         # we've got a fup if it's a reply
 415         #
 416         if ($self -> {response} -> {reply}) {
 417           $pars -> {parentMessage} = $self -> {fup_mid};
 418           $pars -> {thread}        = $self -> {fup_tid};
 419           ($stat, $xml, $mid, $tid) = write_reply_posting ($pars);
 420         }
 421         else {
 422           ($stat, $xml, $mid, $tid) = write_new_thread ($pars);
 423         }
 424
 425         if ($stat) {
 426           $self -> {error} = {
 427             spec => 'not_saved',
 428             desc => $stat,
 429             type => 'fatal'
 430           };
 431         }
 432         else {
 433           my $cache = new Posting::Cache ($self->{conf}->{original}->{files}->{cacheFile});
 434           $cache -> add_posting (
 435             { thread  => ($tid =~ /(\d+)/)[0],
 436               posting => ($mid =~ /(\d+)/)[0]
 437             }
 438           );
 439
 440           $self -> {check_success} = 1;
 441           my $thx = $self -> {conf} -> {show_posting} -> {thanx};
 442
 443           # define special response data
 444           #
 445           $self -> {response} -> {doc}  = $self -> {conf} -> {assign} -> {docThx};
 446           $self -> {response} -> {pars} = {
 447             $thx -> {time} => plain (hr_time($time)),
 448             $thx -> {body} => message_as_HTML (
 449               $xml,
 450               $self -> {template},
 451               { posting    => $mid,
 452                 assign     => $self -> {conf} -> {assign},
 453                 quoteChars => $q -> param ($formdata -> {quoteChar} -> {name}),
 454                 quoting    => $self -> {conf} -> {admin} -> {View} -> {quoting}
 455               }) || ''
 456           };
 457
 458           # set the variables if defined..
 459           #
 460           my %may = (
 461             author   => 'posterName',
 462             email    => 'posterEmail',
 463             category => 'posterCategory',
 464             subject  => 'posterSubject',
 465             homepage => 'posterURL',
 466             image    => 'posterImage'
 467           );
 468
 469           for (keys %may) {
 470             my $x = $q -> param ($formdata -> {$may{$_}} -> {name});
 471             $x = '' unless (defined $x);
 472             $self -> {response} -> {pars} -> {$thx -> {$_}} = plain ($x)
 473               if (defined $thx -> {$_});
 474           }
 475         }
 476       }
 477     }
 478   }
 479
 480   # unlock forum main file
 481   #
 482   if ($self -> {forum} -> {flocked}) {
 483     violent_unlock_file($self -> {conf} -> {forum_file_name}) unless write_unlock_file ($self -> {conf} -> {forum_file_name});
 484     $self -> {forum} -> {flocked} = 0;
 485   }
 486
 487   $self -> handle_error unless $self -> {check_success};
 488
 489   return;
 490 }
 491
 492 ### sub parse_cgi ##############################################################
 493 #
 494 # fetch and decode cgi-parameters,
 495 # find out the kind of response requested by the user (new message, reply)
 496 #
 497 # Return: -none-
 498 #
 499 sub parse_cgi {
 500   my $self = shift;
 501
 502   # create the CGI object
 503   #
 504   $self -> {cgi_object} = new CGI;
 505
 506   # check the params
 507   #
 508   $self -> {check_success} = $self -> check_cgi;
 509
 510   return;
 511 }
 512
 513 ### sub load_main_file #########################################################
 514 #
 515 # load and parse the forum main file
 516 #
 517 # Return: Success (true/false)
 518 #
 519 sub load_main_file {
 520   my $self = shift;
 521   my $lock_stat;
 522
 523   unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
 524     if (defined $lock_stat) {
 525       # occupied or no w-bit set for the directory..., hmmm
 526       #
 527       violent_unlock_file ($self -> {conf} -> {forum_file_name});
 528       $self -> {error} = {
 529         spec => 'occupied',
 530         type => 'repeat'
 531       };
 532       return;
 533     }
 534     else {
 535       # master lock is set
 536       #
 537       $self -> {error} = {
 538         spec => 'master_lock',
 539         type => 'fatal'
 540       };
 541       return;
 542     }
 543   }
 544   else {
 545     $self -> {forum} -> {flocked} = 1;
 546     ( $self -> {forum} -> {threads},
 547       $self -> {forum} -> {last_thread},
 548       $self -> {forum} -> {last_message},
 549       $self -> {forum} -> {dtd},
 550       $self -> {forum} -> {unids}
 551     ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
 552   }
 553
 554   # ok, looks good
 555   1;
 556 }
 557
 558 ### sub check_reply_dupe #######################################################
 559 #
 560 # check whether a reply is legal
 561 # (followup posting must exists)
 562 #
 563 # check whether this form request is a dupe
 564 # (unique id already exists)
 565 #
 566 # Return: Status Code (Bool)
 567 #
 568 sub check_reply_dupe {
 569   my $self = shift;
 570   my %unids;
 571
 572   # return true unless it's not a reply
 573   # or an opening
 574   #
 575   return 1 unless (
 576     $self -> {response} -> {reply}
 577     or $self -> {response} -> {new}
 578   );
 579
 580   if ($self -> {response} -> {reply}) {
 581
 582     my ($threads, $ftid, $fmid, $i, %msg) = (
 583           $self -> {forum} -> {threads},
 584           $self -> {fup_tid},
 585           $self -> {fup_mid}
 586        );
 587
 588     # thread doesn't exist
 589     #
 590     unless (exists($threads -> {$ftid})) {
 591       $self -> {error} = {
 592         spec => 'no_reply',
 593         type => 'fatal'
 594       };
 595       return;
 596     }
 597
 598     # build a reverse lookup hash (mid => number in array)
 599     # and ignore invisible messages
 600     # (users can't reply to "deleted" msg)
 601     #
 602     for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
 603
 604       if ($threads -> {$ftid} -> [$i] -> {deleted}) {
 605         $i+=$threads -> {$ftid} -> [$i] -> {answers};
 606       }
 607       else {
 608         $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
 609       }
 610     }
 611
 612     # message doesn't exist
 613     #
 614     unless (exists($msg{$fmid})) {
 615       $self -> {error} = {
 616         spec => 'no_reply',
 617         type => 'fatal'
 618       };
 619       return;
 620     }
 621
 622     # build a unique id lookup hash
 623     # use the unids of parent message's kids
 624     #
 625     %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
 626   }
 627   else {
 628     # build a unique id lookup hash, too
 629     # but use only the level-zero-messages
 630     #
 631     %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
 632   }
 633
 634   # now check on dupe
 635   #
 636   if (exists ($unids{
 637                 $self -> {cgi_object} -> param (
 638                   $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
 639     $self -> {error} = {
 640       spec => 'dupe',
 641       type => 'fatal'
 642     };
 643     return;
 644   }
 645
 646   # ok, looks fine
 647   1;
 648 }
 649
 650 ### sub check_cgi ##############################################################
 651 #
 652 # cgi params are like raw eggs...
 653 #
 654 # Return: Status Code (Bool)
 655 #         creates content for the handle_error method if anything fails
 656 #
 657 sub check_cgi {
 658   my $self = shift;
 659
 660   # count the submitted keys and get the keys themselves
 661   #
 662   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
 663   my $cnt_got_keys = keys %got_keys;
 664   my $formdata     = $self -> {conf} -> {form_data};
 665   my $formmust     = $self -> {conf} -> {form_must};
 666
 667   # user requested the 'new thread' page
 668   # (no params but perhaps the user-ID have been submitted)
 669   #
 670   if ($cnt_got_keys == 0 or (
 671         exists ($formdata -> {userID})
 672         and $cnt_got_keys == 1
 673         and $got_keys{$formdata -> {userID} -> {name}}
 674         )) {
 675     $self -> {response} -> {new_thread} = 1;
 676     $self -> {check_success} = 1;
 677     return 1;
 678   }
 679
 680   # now we know, we've got a filled out form
 681   # we do the following steps to check it:
 682   #
 683   # 1st: create a reverse Hash (CGI-key - identifier)
 684   # 2nd: did we get _all_ must-keys?
 685   #      check whether reply or new message request
 686   # 3rd: did we get too many keys?
 687   # 4th: do _all_ submitted values accord to
 688   #      our expectations?
 689   #      fetch the "missing" keys
 690   #
 691
 692   # 1
 693   #
 694   my %name = map {
 695     exists($formdata -> {$_} -> {name})
 696     ? ($formdata -> {$_} -> {name} => $_)
 697     : ()
 698   } keys %$formdata;
 699
 700   # 2
 701   #
 702   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 703   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 704
 705   # define the fetch array (values to fetch from parent message)
 706   #
 707   $self -> {fetch} = [];
 708
 709   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 710
 711     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 712
 713       # only miss the key unless we're able to fetch it from parent posting
 714       #
 715       unless (
 716         not $self -> {response} -> {reply}
 717         or $formdata -> {$_} -> {errorType} eq 'fetch') {
 718
 719         $self -> {error} = {
 720           spec => 'missing_key',
 721           desc => $_,
 722           type => 'fatal'
 723         };
 724         return;
 725       }
 726       else {
 727         # keep in mind to fetch the value later
 728         #
 729         push @{$self -> {fetch}} => $_;
 730       }
 731     }
 732   }
 733
 734   # I'm lazy - I know...
 735   my $q = $self -> {cgi_object};
 736
 737   # 3
 738   #
 739   for ($q -> param) {
 740     unless (exists ($name {$_})) {
 741       $self -> {error} = {
 742         spec => 'unexpected_key',
 743         desc => $name{$_},
 744         type => 'fatal'
 745       };
 746       return;
 747     }
 748   }
 749
 750   # 4
 751   #
 752   unless ($self -> decode_param) {
 753     $self -> {error} = {
 754       spec => 'unknown_encoding',
 755       type => 'fatal'
 756     };
 757     return;
 758   };
 759
 760   if ($self -> {response} -> {reply}) {
 761
 762     # get the parent-identifiers if we got a reply request
 763     #
 764     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 765
 766     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 767       $self -> {error} = {
 768         spec => 'unknown_followup',
 769         type => 'fatal'
 770       };
 771       return;
 772     }
 773     $self -> {fup_tid} = $ftid;
 774     $self -> {fup_mid} = $fmid;
 775
 776     # fetch the missing keys
 777     # if it fails, they're too short, too... ;)
 778     #
 779     $self -> fetch;
 780     $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
 781   }
 782
 783   # now we can check on length, type etc.
 784   #
 785   for (keys %got_keys) {
 786
 787     # we are sure, we've got only one value for one key
 788     #
 789     my $val = $q -> param ($_);
 790
 791     $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
 792     $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
 793       unless (
 794         exists ($formdata -> {$name {$_}} -> {type})
 795         and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
 796       );
 797
 798     $q -> param ($_ => $val);  # write it back
 799
 800     # too long?
 801     #
 802     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 803       $self -> {error} = {
 804         spec => 'too_long',
 805         desc => $name{$_},
 806         type => $formdata -> {$name {$_}} -> {errorType}
 807       };
 808       $self -> kill_param or return;
 809     }
 810
 811     # too short?
 812     # (only check if there's defined a minimum length)
 813     #
 814     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 815
 816       # kill the whitespaces to get only the visible characters...
 817       #
 818       (my $val_ww = $val) =~ s/\s+//g;
 819
 820       $val_ww =~ y/a-zA-Z//cd
 821         if (exists ($formdata -> {$name {$_}} -> {type}) and $formdata -> {$name {$_}} -> {type} eq 'name');
 822
 823       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 824         $self -> {error} = {
 825           spec => 'too_short',
 826           desc => $name{$_},
 827           type => $formdata -> {$name {$_}} -> {errorType}
 828         };
 829         $self -> kill_param or return;
 830       }
 831     }
 832
 833     # check the values on expected kinds of content
 834     # (email, http-url, url, option)
 835     #
 836     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
 837       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
 838         $self -> {error} = {
 839           spec => 'wrong_mail',
 840           desc => $name{$_},
 841           type => $formdata -> {$name {$_}} -> {errorType}
 842         };
 843         $self -> kill_param or return;
 844       }
 845
 846       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
 847         $self -> {error} = {
 848           spec => 'wrong_http_url',
 849           desc => $name{$_},
 850           type => $formdata -> {$name {$_}} -> {errorType}
 851         };
 852         $self -> kill_param or return;
 853       }
 854
 855       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
 856         $self -> {error} = {
 857           spec => 'wrong_url',
 858           desc => $name{$_},
 859           type => $formdata -> {$name {$_}} -> {errorType}
 860         };
 861         $self -> kill_param or return;
 862       }
 863     }
 864
 865     if (exists ($formdata -> {$name {$_}} -> {values})
 866         and not exists ({map {$_ => undef} @{$formdata -> {$name {$_}} -> {values}}} -> {$val})) {
 867         $self -> {error} = {
 868           spec => 'no_option',
 869           desc => $name{$_},
 870           type => $formdata -> {$name {$_}} -> {errorType}
 871         };
 872         $self -> kill_param or return;
 873     }
 874   }
 875
 876   # ok, looks good.
 877   1;
 878 }
 879 ### sub kill_param #############################################################
 880 #
 881 # kill the param (set it on '') if wrong and declared as 'kill' in config file
 882 #
 883 # Return: true  if killed
 884 #         false otherwise
 885 #
 886 sub kill_param {
 887   my $self = shift;
 888
 889   if ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {errorType} eq 'kill') {
 890     $self -> {cgi_object} -> param ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {name} => '');
 891     $self -> {error} = {};
 892     return 1;
 893   }
 894
 895   return;
 896 }
 897
 898 ### sub fetch ##################################################################
 899 #
 900 # fetch "missing" keys from parent posting
 901 #
 902 sub fetch {
 903   my $self = shift;
 904   my $q = $self -> {cgi_object};
 905   my $formdata = $self -> {conf} -> {form_data};
 906
 907   if (@{$self -> {fetch}}) {
 908     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 909
 910     if (lock_file ($filename)) {
 911       my $xml = parse_xml_file ($filename);
 912       violent_unlock_file($filename) unless unlock_file ($filename);
 913
 914       if ($xml) {
 915         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 916         if ($mnode) {
 917           my $header = get_message_header ($mnode);
 918
 919           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 920             for (@{$self -> {fetch}});
 921
 922           return;
 923         }
 924       }
 925     }
 926   }
 927
 928   # fetching failed:
 929   # fillout the values with an empty string
 930   #
 931   $q -> param ($formdata -> {$_} -> {name} => '')
 932     for (@{$self -> {fetch}});
 933
 934   return;
 935 }
 936
 937 ### sub decode_param ###########################################################
 938 #
 939 # convert submitted form data into UTF-8
 940 # unless it's not encoded yet
 941 #
 942 # Return: Status Code (Bool)
 943 #         false if unknown encoding (like UTF-7 for instance)
 944 #
 945 sub decode_param {
 946   my $self = shift;
 947
 948   my $q = $self -> {cgi_object};
 949   my $formdata = $self -> {conf} -> {form_data};
 950
 951   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 952   my @array;
 953
 954   # Latin 1 (we hope so - there's no real way to find out :-( )
 955   if ($code =~ /^\377/) {
 956     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 957   }
 958   else {
 959     # UTF-8 is (probably) correct,
 960     # other encodings we don't know and fail
 961     return unless $code =~ /^\303\277/;
 962   }
 963
 964   # remove the &#255; (encoded as UTF-8) from quotechars
 965   $q -> param ($formdata -> {quoteChar} -> {name}
 966         => substr $q -> param ($formdata -> {quoteChar} -> {name}),2);
 967
 968   # ok, params now should be UTF-8 encoded
 969   1;
 970 }
 971
 972 sub jerk {
 973   my $text = $_[1] || 'An error has occurred.';
 974   print <<EOF;
 975 Content-type: text/plain
 976
 977
 978
 979  Oops.
 980
 981  $text
 982  We will fix it as soon as possible. Thank you for your patience.
 983
 984  Regards
 985     n.d.p.
 986 EOF
 987 }
 988
 989 #
 990 #
 991 ### end of fo_posting.pl #######################################################