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