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