selfforum-cgi/user/fo_posting.pl

   1 #!/usr/bin/perl -w
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        user/fo_posting.pl                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-04-08                          #
   8 #                                                                              #
   9 # Description: Accept new postings, display "Neue Nachricht" page              #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   $Bin
  16   $Shared
  17   $Script
  18   $Config
  19 );
  20
  21 # locate the script
  22 #
  23 BEGIN {
  24   my $null = $0; $null =~ s/\\/\//g; # for win :-(
  25   $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  26   $Shared  = "$Bin/../shared";
  27   $Config  = "$Bin/config";
  28   $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  29
  30 #  my $null = $0; #$null =~ s/\\/\//g; # for win :-(
  31 #  $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  32 #  $Config  = "$Bin/../../../cgi-config/devforum";
  33 #  $Shared  = "$Bin/../../../cgi-shared";
  34 #  $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  35 }
  36
  37 use lib "$Shared";
  38 use CGI::Carp qw(fatalsToBrowser);
  39
  40 use Conf;
  41 use Conf::Admin;
  42 use Posting::Cache;
  43
  44 # load script configuration and admin default conf.
  45 #
  46 my $conf         = read_script_conf ($Config, $Shared, $Script);
  47 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
  48
  49 # Initialize the request
  50 #
  51 my $request = new Posting::Request ($conf, $adminDefault);
  52
  53 # fetch and parse the cgi-params
  54 #
  55 $request -> parse_cgi;
  56
  57 # handle errors or save the posting
  58 #
  59 $request -> handle_error or $request -> save;
  60
  61 # show response
  62 #
  63 $request -> response;
  64
  65 # shorten the main file?
  66 #
  67 $request -> severance;
  68
  69 #
  70 #
  71 ### main end ###################################################################
  72
  73 ################################################################################
  74 ### Posting::Request ###########################################################
  75 package Posting::Request;
  76
  77 use Arc::Archive;
  78 use CheckRFC;
  79 use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
  80 use Encode::Posting;
  81 use Lock          qw(:ALL);
  82 use Posting::_lib qw(
  83   hr_time
  84   parse_xml_file
  85   get_all_threads
  86   get_message_node
  87   get_message_header
  88   KEEP_DELETED
  89 );
  90 use Posting::Write;
  91 use Id;
  92 use Template;
  93 use Template::Posting;
  94
  95 use CGI;
  96
  97 ### sub new ####################################################################
  98 #
  99 # initialising the Posting::Request object
 100 # check parameters and fill in object properties
 101 #
 102 sub new {
 103   my ($class, $conf, $adminDefault) = @_;
 104
 105   my $sp = $conf -> {show} -> {Posting};
 106
 107   my $self = {
 108        conf => {
 109          original => $conf,
 110          admin    => $adminDefault,
 111
 112          message_path    => $conf -> {files} -> {messagePath},
 113          forum_file_name => $conf -> {files} -> {forum},
 114
 115          show_posting    => $sp,
 116          assign          => $sp -> {assign},
 117          template        => $conf -> {template},
 118          form_must       => $sp -> {form} -> {must},
 119          form_data       => $sp -> {form} -> {data},
 120          form_action     => $sp -> {form} -> {action},
 121        },
 122
 123        template => new Template $sp -> {templateFile},
 124        response => {},
 125        forum    => {},
 126        error    => {}
 127      };
 128
 129   bless $self, $class;
 130 }
 131
 132 sub severance {
 133   my $self = shift;
 134
 135   my $stat = cut_tail ({
 136     forumFile    => $self -> {conf} -> {forum_file_name},
 137     messagePath  => $self -> {conf} -> {message_path},
 138     archivePath  => $self -> {conf} -> {original} -> {files} -> {archivePath},
 139     lockFile     => $self -> {conf} -> {original} -> {files} -> {sev_lock},
 140     adminDefault => $self -> {conf} -> {admin},
 141     cachePath    => $self -> {conf} -> {original} -> {files} -> {cachePath}
 142   });
 143 #  die $stat->{(keys %$stat)[0]} if (%$stat);
 144
 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     violent_unlock_file($self -> {conf} -> {forum_file_name}) unless write_unlock_file ($self -> {conf} -> {forum_file_name});
 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 $lock_stat;
 542
 543   unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
 544     if (defined $lock_stat) {
 545       # occupied or no w-bit set for the directory..., hmmm
 546       #
 547       violent_unlock_file ($self -> {conf} -> {forum_file_name});
 548       $self -> {error} = {
 549         spec => 'occupied',
 550         type => 'repeat'
 551       };
 552       return;
 553     }
 554     else {
 555       # master lock is set
 556       #
 557       $self -> {error} = {
 558         spec => 'master_lock',
 559         type => 'fatal'
 560       };
 561       return;
 562     }
 563   }
 564   else {
 565     $self -> {forum} -> {flocked} = 1;
 566     ( $self -> {forum} -> {threads},
 567       $self -> {forum} -> {last_thread},
 568       $self -> {forum} -> {last_message},
 569       $self -> {forum} -> {dtd},
 570       $self -> {forum} -> {unids}
 571     ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
 572   }
 573
 574   # ok, looks good
 575   1;
 576 }
 577
 578 ### sub check_reply_dupe #######################################################
 579 #
 580 # check whether a reply is legal
 581 # (followup posting must exists)
 582 #
 583 # check whether this form request is a dupe
 584 # (unique id already exists)
 585 #
 586 # Return: Status Code (Bool)
 587 #
 588 sub check_reply_dupe {
 589   my $self = shift;
 590   my %unids;
 591
 592   # return true unless it's not a reply
 593   # or an opening
 594   #
 595   return 1 unless (
 596     $self -> {response} -> {reply}
 597     or $self -> {response} -> {new}
 598   );
 599
 600   if ($self -> {response} -> {reply}) {
 601
 602     my ($threads, $ftid, $fmid, $i, %msg) = (
 603           $self -> {forum} -> {threads},
 604           $self -> {fup_tid},
 605           $self -> {fup_mid}
 606        );
 607
 608     # thread doesn't exist
 609     #
 610     unless (exists($threads -> {$ftid})) {
 611       $self -> {error} = {
 612         spec => 'no_reply',
 613         type => 'fatal'
 614       };
 615       return;
 616     }
 617
 618     # build a reverse lookup hash (mid => number in array)
 619     # and ignore invisible messages
 620     # (users can't reply to "deleted" msg)
 621     #
 622     for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
 623
 624       if ($threads -> {$ftid} -> [$i] -> {deleted}) {
 625         $i+=$threads -> {$ftid} -> [$i] -> {answers};
 626       }
 627       else {
 628         $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
 629       }
 630     }
 631
 632     # message doesn't exist
 633     #
 634     unless (exists($msg{$fmid})) {
 635       $self -> {error} = {
 636         spec => 'no_reply',
 637         type => 'fatal'
 638       };
 639       return;
 640     }
 641
 642     # build a unique id lookup hash
 643     # use the unids of parent message's kids
 644     #
 645     %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
 646   }
 647   else {
 648     # build a unique id lookup hash, too
 649     # but use only the level-zero-messages
 650     #
 651     %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
 652   }
 653
 654   # now check on dupe
 655   #
 656   if (exists ($unids{
 657                 $self -> {cgi_object} -> param (
 658                   $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
 659     $self -> {error} = {
 660       spec => 'dupe',
 661       type => 'fatal'
 662     };
 663     return;
 664   }
 665
 666   # ok, looks fine
 667   1;
 668 }
 669
 670 ### sub check_cgi ##############################################################
 671 #
 672 # cgi params are like raw eggs...
 673 #
 674 # Return: Status Code (Bool)
 675 #         creates content for the handle_error method if anything fails
 676 #
 677 sub check_cgi {
 678   my $self = shift;
 679
 680   # count the submitted keys and get the keys themselves
 681   #
 682   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
 683   my $cnt_got_keys = keys %got_keys;
 684   my $formdata     = $self -> {conf} -> {form_data};
 685   my $formmust     = $self -> {conf} -> {form_must};
 686
 687   # user requested the 'new thread' page
 688   # (no params but perhaps the user-ID have been submitted)
 689   #
 690   if ($cnt_got_keys == 0 or (
 691         exists ($formdata -> {userID})
 692         and $cnt_got_keys == 1
 693         and $got_keys{$formdata -> {userID} -> {name}}
 694         )) {
 695     $self -> {response} -> {new_thread} = 1;
 696     $self -> {check_success} = 1;
 697     return 1;
 698   }
 699
 700   # now we know, we've got a filled out form
 701   # we do the following steps to check it:
 702   #
 703   # 1st: create a reverse Hash (CGI-key - identifier)
 704   # 2nd: did we get _all_ must-keys?
 705   #      check whether reply or new message request
 706   # 3rd: did we get too many keys?
 707   # 4th: do _all_ submitted values accord to
 708   #      our expectations?
 709   #      fetch the "missing" keys
 710   #
 711
 712   # 1
 713   #
 714   my %name = map {
 715     exists($formdata -> {$_} -> {name})
 716     ? ($formdata -> {$_} -> {name} => $_)
 717     : ()
 718   } keys %$formdata;
 719
 720   # 2
 721   #
 722   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 723   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 724
 725   # define the fetch array (values to fetch from parent message)
 726   #
 727   $self -> {fetch} = [];
 728
 729   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 730
 731     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 732
 733       # only miss the key unless we're able to fetch it from parent posting
 734       #
 735       unless (
 736         not $self -> {response} -> {reply}
 737         or $formdata -> {$_} -> {errorType} eq 'fetch') {
 738
 739         $self -> {error} = {
 740           spec => 'missing_key',
 741           desc => $_,
 742           type => 'fatal'
 743         };
 744         return;
 745       }
 746       else {
 747         # keep in mind to fetch the value later
 748         #
 749         push @{$self -> {fetch}} => $_;
 750       }
 751     }
 752   }
 753
 754   # I'm lazy - I know...
 755   my $q = $self -> {cgi_object};
 756
 757   # 3
 758   #
 759   for ($q -> param) {
 760     unless (exists ($name {$_})) {
 761       $self -> {error} = {
 762         spec => 'unexpected_key',
 763         desc => $name{$_},
 764         type => 'fatal'
 765       };
 766       return;
 767     }
 768   }
 769
 770   # 4
 771   #
 772   unless ($self -> decode_param) {
 773     $self -> {error} = {
 774       spec => 'unknown_encoding',
 775       type => 'fatal'
 776     };
 777     return;
 778   };
 779
 780   if ($self -> {response} -> {reply}) {
 781
 782     # get the parent-identifiers if we got a reply request
 783     #
 784     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 785
 786     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 787       $self -> {error} = {
 788         spec => 'unknown_followup',
 789         type => 'fatal'
 790       };
 791       return;
 792     }
 793     $self -> {fup_tid} = $ftid;
 794     $self -> {fup_mid} = $fmid;
 795
 796     # fetch the missing keys
 797     # if it fails, they're too short, too... ;)
 798     #
 799     $self -> fetch;
 800     $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
 801   }
 802
 803   # now we can check on length, type etc.
 804   #
 805   for (keys %got_keys) {
 806
 807     # we are sure, we've got only one value for one key
 808     #
 809     my $val = $q -> param ($_);
 810
 811     $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
 812     $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
 813       unless (
 814         exists ($formdata -> {$name {$_}} -> {type})
 815         and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
 816       );
 817
 818     $q -> param ($_ => $val);  # write it back
 819
 820     # too long?
 821     #
 822     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 823       $self -> {error} = {
 824         spec => 'too_long',
 825         desc => $name{$_},
 826         type => $formdata -> {$name {$_}} -> {errorType}
 827       };
 828       $self -> kill_param or return;
 829     }
 830
 831     # too short?
 832     # (only check if there's defined a minimum length)
 833     #
 834     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 835
 836       # kill the whitespaces to get only the visible characters...
 837       #
 838       (my $val_ww = $val) =~ s/\s+//g;
 839
 840       $val_ww =~ y/a-zA-Z//cd
 841         if (exists ($formdata -> {$name {$_}} -> {type}) and $formdata -> {$name {$_}} -> {type} eq 'name');
 842
 843       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 844         $self -> {error} = {
 845           spec => 'too_short',
 846           desc => $name{$_},
 847           type => $formdata -> {$name {$_}} -> {errorType}
 848         };
 849         $self -> kill_param or return;
 850       }
 851     }
 852
 853     # check the values on expected kinds of content
 854     # (email, http-url, url, option)
 855     #
 856     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
 857       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
 858         $self -> {error} = {
 859           spec => 'wrong_mail',
 860           desc => $name{$_},
 861           type => $formdata -> {$name {$_}} -> {errorType}
 862         };
 863         $self -> kill_param or return;
 864       }
 865
 866       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
 867         $self -> {error} = {
 868           spec => 'wrong_http_url',
 869           desc => $name{$_},
 870           type => $formdata -> {$name {$_}} -> {errorType}
 871         };
 872         $self -> kill_param or return;
 873       }
 874
 875       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
 876         $self -> {error} = {
 877           spec => 'wrong_url',
 878           desc => $name{$_},
 879           type => $formdata -> {$name {$_}} -> {errorType}
 880         };
 881         $self -> kill_param or return;
 882       }
 883     }
 884
 885     if (exists ($formdata -> {$name {$_}} -> {values})
 886         and not exists ({map {$_ => undef} @{$formdata -> {$name {$_}} -> {values}}} -> {$val})) {
 887         $self -> {error} = {
 888           spec => 'no_option',
 889           desc => $name{$_},
 890           type => $formdata -> {$name {$_}} -> {errorType}
 891         };
 892         $self -> kill_param or return;
 893     }
 894   }
 895
 896   # ok, looks good.
 897   1;
 898 }
 899 ### sub kill_param #############################################################
 900 #
 901 # kill the param (set it on '') if wrong and declared as 'kill' in config file
 902 #
 903 # Return: true  if killed
 904 #         false otherwise
 905 #
 906 sub kill_param {
 907   my $self = shift;
 908
 909   if ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {errorType} eq 'kill') {
 910     $self -> {cgi_object} -> param ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {name} => '');
 911     $self -> {error} = {};
 912     return 1;
 913   }
 914
 915   return;
 916 }
 917
 918 ### sub fetch ##################################################################
 919 #
 920 # fetch "missing" keys from parent posting
 921 #
 922 sub fetch {
 923   my $self = shift;
 924   my $q = $self -> {cgi_object};
 925   my $formdata = $self -> {conf} -> {form_data};
 926
 927   if (@{$self -> {fetch}}) {
 928     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 929
 930     if (lock_file ($filename)) {
 931       my $xml = parse_xml_file ($filename);
 932       violent_unlock_file($filename) unless unlock_file ($filename);
 933
 934       if ($xml) {
 935         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 936         if ($mnode) {
 937           my $header = get_message_header ($mnode);
 938
 939           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 940             for (@{$self -> {fetch}});
 941
 942           return;
 943         }
 944       }
 945     }
 946   }
 947
 948   # fetching failed:
 949   # fillout the values with an empty string
 950   #
 951   $q -> param ($formdata -> {$_} -> {name} => '')
 952     for (@{$self -> {fetch}});
 953
 954   return;
 955 }
 956
 957 ### sub decode_param ###########################################################
 958 #
 959 # convert submitted form data into UTF-8
 960 # unless it's not encoded yet
 961 #
 962 # Return: Status Code (Bool)
 963 #         false if unknown encoding (like UTF-7 for instance)
 964 #
 965 sub decode_param {
 966   my $self = shift;
 967
 968   my $q = $self -> {cgi_object};
 969   my $formdata = $self -> {conf} -> {form_data};
 970
 971   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 972   my @array;
 973
 974   # Latin 1 (we hope so - there's no real way to find out :-( )
 975   if ($code =~ /^\377/) {
 976     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 977   }
 978   else {
 979     # UTF-8 is (probably) correct,
 980     # other encodings we don't know and fail
 981     return unless $code =~ /^\303\277/;
 982   }
 983
 984   # remove the &#255; (encoded as UTF-8) from quotechars
 985   $q -> param ($formdata -> {quoteChar} -> {name}
 986         => substr $q -> param ($formdata -> {quoteChar} -> {name}),2);
 987
 988   # ok, params now should be UTF-8 encoded
 989   1;
 990 }
 991
 992 sub jerk {
 993   my $text = $_[1] || 'An error has occurred.';
 994   print <<EOF;
 995 Content-type: text/plain
 996
 997
 998
 999  Oops.
1000
1001  $text
1002  We will fix it as soon as possible. Thank you for your patience.
1003
1004  Regards
1005     n.d.p.
1006 EOF
1007 }
1008
1009 #
1010 #
1011 ### end of fo_posting.pl #######################################################