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