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 -> {conf} -> {template} -> {messages} || {},
 379           base_uri      => $self -> {conf} -> {original} -> {files} -> {forum_base}
 380         };
 381
 382         # set the variables if defined..
 383         #
 384         my %may = (
 385           author   => 'posterName',
 386           email    => 'posterEmail',
 387           category => 'posterCategory',
 388           subject  => 'posterSubject',
 389           body     => 'posterBody',
 390           homepage => 'posterURL',
 391           image    => 'posterImage'
 392         );
 393
 394         for (keys %may) {
 395           $pars -> {$_} = $q -> param ($formdata -> {$may{$_}} -> {name})
 396             if (defined $q -> param ($formdata -> {$may{$_}} -> {name}));
 397         }
 398
 399         my ($stat, $xml, $mid);
 400
 401         # we've got a fup if it's a reply
 402         #
 403         if ($self -> {response} -> {reply}) {
 404           $pars -> {parentMessage} = $self -> {fup_mid};
 405           $pars -> {thread}        = $self -> {fup_tid};
 406           ($stat, $xml, $mid) = write_reply_posting ($pars);
 407         }
 408         else {
 409           ($stat, $xml, $mid) = write_new_thread ($pars);
 410         }
 411
 412         if ($stat) {
 413           $self -> {error} = {
 414             spec => 'not_saved',
 415             desc => $stat,
 416             type => 'fatal'
 417           };
 418         }
 419         else {
 420           $self -> {check_success} = 1;
 421           my $thx = $self -> {conf} -> {show_posting} -> {thanx};
 422
 423           # define special response data
 424           #
 425           $self -> {response} -> {doc}  = $self -> {conf} -> {assign} -> {docThx};
 426           $self -> {response} -> {pars} = {
 427             $thx -> {time} => plain (hr_time($time)),
 428             $thx -> {body} => message_as_HTML (
 429               $xml,
 430               $self -> {template},
 431               { posting    => $mid,
 432                 assign     => $self -> {conf} -> {assign},
 433                 quoteChars => $q -> param ($formdata -> {quoteChar} -> {name}),
 434                 quoting    => $self -> {conf} -> {admin} -> {View} -> {quoting}
 435               }) || ''
 436           };
 437
 438           # set the variables if defined..
 439           #
 440           my %may = (
 441             author   => 'posterName',
 442             email    => 'posterEmail',
 443             category => 'posterCategory',
 444             subject  => 'posterSubject',
 445             homepage => 'posterURL',
 446             image    => 'posterImage'
 447           );
 448
 449           for (keys %may) {
 450             my $x = $q -> param ($formdata -> {$may{$_}} -> {name});
 451             $x = '' unless (defined $x);
 452             $self -> {response} -> {pars} -> {$thx -> {$_}} = plain ($x)
 453               if (defined $thx -> {$_});
 454           }
 455         }
 456       }
 457     }
 458   }
 459
 460   # unlock forum main file
 461   #
 462   if ($self -> {forum} -> {flocked}) {
 463     violent_unlock_file($self -> {conf} -> {forum_file_name}) unless write_unlock_file ($self -> {conf} -> {forum_file_name});
 464     $self -> {forum} -> {flocked} = 0;
 465   }
 466
 467   $self -> handle_error unless $self -> {check_success};
 468
 469   return;
 470 }
 471
 472 ### sub parse_cgi ##############################################################
 473 #
 474 # fetch and decode cgi-parameters,
 475 # find out the kind of response requested by the user (new message, reply)
 476 #
 477 # Return: -none-
 478 #
 479 sub parse_cgi {
 480   my $self = shift;
 481
 482   # create the CGI object
 483   #
 484   $self -> {cgi_object} = new CGI;
 485
 486   # check the params
 487   #
 488   $self -> {check_success} = $self -> check_cgi;
 489
 490   return;
 491 }
 492
 493 ### sub load_main_file #########################################################
 494 #
 495 # load and parse the forum main file
 496 #
 497 # Return: Success (true/false)
 498 #
 499 sub load_main_file {
 500   my $self = shift;
 501   my $lock_stat;
 502
 503   unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
 504     if (defined $lock_stat) {
 505       # occupied or no w-bit set for the directory..., hmmm
 506       #
 507       violent_unlock_file ($self -> {conf} -> {forum_file_name});
 508       $self -> {error} = {
 509         spec => 'occupied',
 510         type => 'repeat'
 511       };
 512       return;
 513     }
 514     else {
 515       # master lock is set
 516       #
 517       $self -> {error} = {
 518         spec => 'master_lock',
 519         type => 'fatal'
 520       };
 521       return;
 522     }
 523   }
 524   else {
 525     $self -> {forum} -> {flocked} = 1;
 526     ( $self -> {forum} -> {threads},
 527       $self -> {forum} -> {last_thread},
 528       $self -> {forum} -> {last_message},
 529       $self -> {forum} -> {dtd},
 530       $self -> {forum} -> {unids}
 531     ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
 532   }
 533
 534   # ok, looks good
 535   1;
 536 }
 537
 538 ### sub check_reply_dupe #######################################################
 539 #
 540 # check whether a reply is legal
 541 # (followup posting must exists)
 542 #
 543 # check whether this form request is a dupe
 544 # (unique id already exists)
 545 #
 546 # Return: Status Code (Bool)
 547 #
 548 sub check_reply_dupe {
 549   my $self = shift;
 550   my %unids;
 551
 552   # return true unless it's not a reply
 553   # or an opening
 554   #
 555   return 1 unless (
 556     $self -> {response} -> {reply}
 557     or $self -> {response} -> {new}
 558   );
 559
 560   if ($self -> {response} -> {reply}) {
 561
 562     my ($threads, $ftid, $fmid, $i, %msg) = (
 563           $self -> {forum} -> {threads},
 564           $self -> {fup_tid},
 565           $self -> {fup_mid}
 566        );
 567
 568     # thread doesn't exist
 569     #
 570     unless (exists($threads -> {$ftid})) {
 571       $self -> {error} = {
 572         spec => 'no_reply',
 573         type => 'fatal'
 574       };
 575       return;
 576     }
 577
 578     # build a reverse lookup hash (mid => number in array)
 579     # and ignore invisible messages
 580     # (users can't reply to "deleted" msg)
 581     #
 582     for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
 583
 584       if ($threads -> {$ftid} -> [$i] -> {deleted}) {
 585         $i+=$threads -> {$ftid} -> [$i] -> {answers};
 586       }
 587       else {
 588         $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
 589       }
 590     }
 591
 592     # message doesn't exist
 593     #
 594     unless (exists($msg{$fmid})) {
 595       $self -> {error} = {
 596         spec => 'no_reply',
 597         type => 'fatal'
 598       };
 599       return;
 600     }
 601
 602     # build a unique id lookup hash
 603     # use the unids of parent message's kids
 604     #
 605     %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
 606   }
 607   else {
 608     # build a unique id lookup hash, too
 609     # but use only the level-zero-messages
 610     #
 611     %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
 612   }
 613
 614   # now check on dupe
 615   #
 616   if (exists ($unids{
 617                 $self -> {cgi_object} -> param (
 618                   $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
 619     $self -> {error} = {
 620       spec => 'dupe',
 621       type => 'fatal'
 622     };
 623     return;
 624   }
 625
 626   # ok, looks fine
 627   1;
 628 }
 629
 630 ### sub check_cgi ##############################################################
 631 #
 632 # cgi params are like raw eggs...
 633 #
 634 # Return: Status Code (Bool)
 635 #         creates content for the handle_error method if anything fails
 636 #
 637 sub check_cgi {
 638   my $self = shift;
 639
 640   # count the submitted keys and get the keys themselves
 641   #
 642   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
 643   my $cnt_got_keys = keys %got_keys;
 644   my $formdata     = $self -> {conf} -> {form_data};
 645   my $formmust     = $self -> {conf} -> {form_must};
 646
 647   # user requested the 'new thread' page
 648   # (no params but perhaps the user-ID have been submitted)
 649   #
 650   if ($cnt_got_keys == 0 or (
 651         exists ($formdata -> {userID})
 652         and $cnt_got_keys == 1
 653         and $got_keys{$formdata -> {userID} -> {name}}
 654         )) {
 655     $self -> {response} -> {new_thread} = 1;
 656     $self -> {check_success} = 1;
 657     return 1;
 658   }
 659
 660   # now we know, we've got a filled out form
 661   # we do the following steps to check it:
 662   #
 663   # 1st: create a reverse Hash (CGI-key - identifier)
 664   # 2nd: did we get _all_ must-keys?
 665   #      check whether reply or new message request
 666   # 3rd: did we get too many keys?
 667   # 4th: do _all_ submitted values accord to
 668   #      our expectations?
 669   #      fetch the "missing" keys
 670   #
 671
 672   # 1
 673   #
 674   my %name = map {
 675     exists($formdata -> {$_} -> {name})
 676     ? ($formdata -> {$_} -> {name} => $_)
 677     : ()
 678   } keys %$formdata;
 679
 680   # 2
 681   #
 682   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 683   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 684
 685   # define the fetch array (values to fetch from parent message)
 686   #
 687   $self -> {fetch} = [];
 688
 689   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 690
 691     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 692
 693       # only miss the key unless we're able to fetch it from parent posting
 694       #
 695       unless (
 696         not $self -> {response} -> {reply}
 697         or $formdata -> {$_} -> {errorType} eq 'fetch') {
 698
 699         $self -> {error} = {
 700           spec => 'missing_key',
 701           desc => $_,
 702           type => 'fatal'
 703         };
 704         return;
 705       }
 706       else {
 707         # keep in mind to fetch the value later
 708         #
 709         push @{$self -> {fetch}} => $_;
 710       }
 711     }
 712   }
 713
 714   # I'm lazy - I know...
 715   my $q = $self -> {cgi_object};
 716
 717   # 3
 718   #
 719   for ($q -> param) {
 720     unless (exists ($name {$_})) {
 721       $self -> {error} = {
 722         spec => 'unexpected_key',
 723         desc => $name{$_},
 724         type => 'fatal'
 725       };
 726       return;
 727     }
 728   }
 729
 730   # 4
 731   #
 732   unless ($self -> decode_param) {
 733     $self -> {error} = {
 734       spec => 'unknown_encoding',
 735       type => 'fatal'
 736     };
 737     return;
 738   };
 739
 740   if ($self -> {response} -> {reply}) {
 741
 742     # get the parent-identifiers if we got a reply request
 743     #
 744     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 745
 746     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 747       $self -> {error} = {
 748         spec => 'unknown_followup',
 749         type => 'fatal'
 750       };
 751       return;
 752     }
 753     $self -> {fup_tid} = $ftid;
 754     $self -> {fup_mid} = $fmid;
 755
 756     # fetch the missing keys
 757     # if it fails, they're too short, too... ;)
 758     #
 759     $self -> fetch;
 760     $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
 761   }
 762
 763   # now we can check on length, type etc.
 764   #
 765   for (keys %got_keys) {
 766
 767     # we are sure, we've got only one value for one key
 768     #
 769     my $val = $q -> param ($_);
 770
 771     $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
 772     $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
 773       unless (
 774         exists ($formdata -> {$name {$_}} -> {type})
 775         and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
 776       );
 777
 778     $q -> param ($_ => $val);  # write it back
 779
 780     # too long?
 781     #
 782     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 783       $self -> {error} = {
 784         spec => 'too_long',
 785         desc => $name{$_},
 786         type => $formdata -> {$name {$_}} -> {errorType}
 787       };
 788       $self -> kill_param or return;
 789     }
 790
 791     # too short?
 792     # (only check if there's defined a minimum length)
 793     #
 794     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 795
 796       # kill the whitespaces to get only the visible characters...
 797       #
 798       (my $val_ww = $val) =~ s/\s+//g;
 799
 800       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 801         $self -> {error} = {
 802           spec => 'too_short',
 803           desc => $name{$_},
 804           type => $formdata -> {$name {$_}} -> {errorType}
 805         };
 806         $self -> kill_param or return;
 807       }
 808     }
 809
 810     # check the values on expected kinds of content
 811     # (email, http-url, url, option)
 812     #
 813     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
 814       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
 815         $self -> {error} = {
 816           spec => 'wrong_mail',
 817           desc => $name{$_},
 818           type => $formdata -> {$name {$_}} -> {errorType}
 819         };
 820         $self -> kill_param or return;
 821       }
 822
 823       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
 824         $self -> {error} = {
 825           spec => 'wrong_http_url',
 826           desc => $name{$_},
 827           type => $formdata -> {$name {$_}} -> {errorType}
 828         };
 829         $self -> kill_param or return;
 830       }
 831
 832       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
 833         $self -> {error} = {
 834           spec => 'wrong_url',
 835           desc => $name{$_},
 836           type => $formdata -> {$name {$_}} -> {errorType}
 837         };
 838         $self -> kill_param or return;
 839       }
 840     }
 841
 842     if (exists ($formdata -> {$name {$_}} -> {values})
 843         and not exists ({map {$_ => undef} @{$formdata -> {$name {$_}} -> {values}}} -> {$val})) {
 844         $self -> {error} = {
 845           spec => 'no_option',
 846           desc => $name{$_},
 847           type => $formdata -> {$name {$_}} -> {errorType}
 848         };
 849         $self -> kill_param or return;
 850     }
 851   }
 852
 853   # ok, looks good.
 854   1;
 855 }
 856 ### sub kill_param #############################################################
 857 #
 858 # kill the param (set it on '') if wrong and declared as 'kill' in config file
 859 #
 860 # Return: true  if killed
 861 #         false otherwise
 862 #
 863 sub kill_param {
 864   my $self = shift;
 865
 866   if ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {errorType} eq 'kill') {
 867     $self -> {cgi_object} -> param ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {name} => '');
 868     $self -> {error} = {};
 869     return 1;
 870   }
 871
 872   return;
 873 }
 874
 875 ### sub fetch ##################################################################
 876 #
 877 # fetch "missing" keys from parent posting
 878 #
 879 sub fetch {
 880   my $self = shift;
 881   my $q = $self -> {cgi_object};
 882   my $formdata = $self -> {conf} -> {form_data};
 883
 884   if (@{$self -> {fetch}}) {
 885     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 886
 887     if (lock_file ($filename)) {
 888       my $xml = parse_xml_file ($filename);
 889       violent_unlock_file($filename) unless unlock_file ($filename);
 890
 891       if ($xml) {
 892         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 893         if ($mnode) {
 894           my $header = get_message_header ($mnode);
 895
 896           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 897             for (@{$self -> {fetch}});
 898
 899           return;
 900         }
 901       }
 902     }
 903   }
 904
 905   # fetching failed:
 906   # fillout the values with an empty string
 907   #
 908   $q -> param ($formdata -> {$_} -> {name} => '')
 909     for (@{$self -> {fetch}});
 910
 911   return;
 912 }
 913
 914 ### sub decode_param ###########################################################
 915 #
 916 # convert submitted form data into UTF-8
 917 # unless it's not encoded yet
 918 #
 919 # Return: Status Code (Bool)
 920 #         false if unknown encoding (like UTF-7 for instance)
 921 #
 922 sub decode_param {
 923   my $self = shift;
 924
 925   my $q = $self -> {cgi_object};
 926   my $formdata = $self -> {conf} -> {form_data};
 927
 928   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 929   my @array;
 930
 931   # Latin 1 (we hope so - there's no real way to find out :-( )
 932   if ($code =~ /^\377/) {
 933     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 934   }
 935   else {
 936     # UTF-8 is (probably) correct,
 937     # other encodings we don't know and fail
 938     return unless $code =~ /^\303\277/;
 939   }
 940
 941   # remove the &#255; (encoded as UTF-8) from quotechars
 942   $q -> param ($formdata -> {quoteChar} -> {name}
 943         => substr $q -> param ($formdata -> {quoteChar} -> {name}),2);
 944
 945   # ok, params now should be UTF-8 encoded
 946   1;
 947 }
 948
 949 sub jerk {
 950   my $text = $_[1] || 'An error has occurred.';
 951   print <<EOF;
 952 Content-type: text/plain
 953
 954
 955
 956  Oops.
 957
 958  $text
 959  We will fix it as soon as possible. Thank you for your patience.
 960
 961  Regards
 962     n.d.p.
 963 EOF
 964 }
 965
 966 #
 967 #
 968 ### end of fo_posting.pl #######################################################