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