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