selfforum-cgi/user/fo_posting.pl

   1 #!/usr/bin/perl
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        user/fo_posting.pl                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-01-25                          #
   8 #                                                                              #
   9 # Description: Accept new postings, display "Neue Nachricht" page              #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw($Bin $Shared $Script %subhash $httpurl $flocked);
  15
  16 BEGIN {
  17   ($Bin)    = ($0 =~ /^(.*)\/.*$/)? $1 : '.';
  18   $Shared   = "$Bin/../shared";
  19   ($Script) = ($0 =~ /^.*\/(.*)$/)? $1 : $0;}
  20
  21 use CGI::Carp qw(fatalsToBrowser);
  22
  23 use lib "$Shared";
  24 use Conf;
  25 use Encode::Plain; $Encode::Plain::utf8 = 1;
  26 use Encode::Posting;
  27 use Id;
  28 use Lock qw(:ALL);
  29 use Mail;
  30 use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time);
  31 use Posting::Write;
  32 use Template;
  33 use Template::Posting;
  34
  35 use CGI qw(param header);
  36 use XML::DOM;
  37
  38 print header (-type => 'text/html');
  39
  40 our $conf = read_script_conf ($Bin, $Shared, $Script);
  41
  42 our $show_posting = $conf -> {show} -> {Posting};
  43 our $assign   = $show_posting -> {assign};
  44 our $formmust = $show_posting -> {form} -> {must};
  45 our $formdata = $show_posting -> {form} -> {data};
  46 our $formact  = $show_posting -> {form} -> {action};
  47 our $template = new Template "$Bin/".$show_posting -> {templateFile};
  48 our $pars = {};
  49 our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked);
  50
  51 sub forum_filename () {$conf -> {wwwRoot} . $conf -> {files} -> {forum};}
  52 sub message_path () {$conf -> {wwwRoot} . $conf -> {files} -> {messagePath};}
  53
  54 ################################
  55
  56 # Formfelder ausfuellen (Namen)
  57 for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) {
  58   $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});}
  59
  60 my $checked = &check_param;
  61
  62 unless (exists ($subhash {$checked})) {
  63   &print_fatal ($assign -> {unknownError});}
  64
  65 else {
  66   unless ($checked eq 'newThread') {
  67     $checked = &check_reply_dupe() || $checked;}
  68
  69   unless (exists ($subhash {$checked})) {
  70     &print_fatal ($assign -> {unknownError});}
  71   else {
  72     &{$subhash {$checked}};}
  73
  74   if ($flocked) {
  75     violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}}
  76
  77 # ====================================================
  78 # end of main / Funktionen
  79 # ====================================================
  80
  81
  82 ### check_reply_dupe () ########################################################
  83 #
  84 # Reply moeglich? Doppelposting?
  85 #
  86 # Params: -none-
  87 # Return: Dupe check result
  88 #         'Dupe'  - Posting is a dupe
  89 #         Nothing - ok.
  90 #
  91 sub check_reply_dupe () {
  92   my $stat;
  93
  94   unless ($stat = write_lock_file (forum_filename)) {
  95     if ($stat == 0) {
  96       # ueberlastet oder so
  97       violent_unlock_file (forum_filename);
  98       return 'Occupied';
  99     } else {
 100       return 'masterLock';
 101     }
 102   } else {
 103     my ($i, %msg, %unids);
 104
 105     $flocked = 1;
 106
 107     ($threads, $last_thread, $last_message, my $unids) = get_all_threads (forum_filename, 1, 0);
 108     ($ftid,$fmid) = split /;/,$dparam{$formdata -> {followUp} -> {name}},2;
 109
 110     # Thread existiert nicht
 111     if (exists($dparam{$formdata -> {followUp} -> {name}})) {
 112       return 'noReply' unless (exists($threads -> {$ftid}));
 113
 114       # nur nicht geloeschte Messages beachten
 115       for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
 116         if ($threads -> {$ftid} -> [$i] -> {deleted}) {
 117           $+=$threads -> {$ftid} -> [$i] -> {answers};}
 118
 119         else {
 120           $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;}}
 121
 122       # Message existiert nicht
 123       if (exists($dparam{$formdata -> {followUp} -> {name}})) {
 124         return 'noReply' unless (exists($msg{$fmid}));}
 125
 126       %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
 127     } else {
 128       %unids = map {$_ => 1} @$unids;
 129     }
 130
 131     # jetzt endlich
 132     return 'Dupe' if (exists ($unids{$dparam{$formdata -> {uniqueID} -> {name}}}));
 133   }
 134
 135   return;
 136 }
 137
 138 ################################
 139 # sub got_new
 140 #
 141 # Eroeffnungsposting speichern
 142 ################################
 143
 144 sub got_new () {
 145
 146   my $time = time;
 147   my $pars = {author        => $dparam {$formdata -> {posterName} -> {name}},
 148               email         => $dparam {$formdata -> {posterEmail} -> {name}},
 149               category      => $dparam {$formdata -> {posterCategory} -> {name}},
 150               subject       => $dparam {$formdata -> {posterSubject} -> {name}},
 151               body          => $dparam {$formdata -> {posterBody} -> {name}},
 152               homepage      => $dparam {$formdata -> {posterURL} -> {name}},
 153               image         => $dparam {$formdata -> {posterImage} -> {name}},
 154               time          => $time,
 155               uniqueID      => $dparam {$formdata -> {uniqueID} -> {name}},
 156               ip            => $ENV{REMOTE_ADDR},
 157               forumFile     => forum_filename,
 158               messagePath   => message_path,
 159               lastThread    => $last_thread,
 160               lastMessage   => $last_message,
 161               parsedThreads => $threads,
 162               dtd           => 'forum.dtd',
 163               quoteChars    => toUTF8('»» '),
 164               messages      => $conf -> {template} -> {messages}};
 165
 166   my ($stat, $xml, $mid) = write_posting ($pars);
 167   violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
 168   $flocked = undef;
 169
 170   if ($stat) {
 171     print "Och noe...: $stat";}
 172
 173   else {
 174     my $thx = $show_posting -> {thanx};
 175
 176     print ${$template -> scrap ($assign -> {docThx},
 177                                {$thx -> {author}   => plain ($dparam {$formdata -> {posterName} -> {name}}),
 178                                 $thx -> {email}    => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
 179                                 $thx -> {time}     => plain (hr_time($time)),
 180                                 $thx -> {body}     => message_as_HTML ($xml, $template,
 181                                                                       {posting => $mid,
 182                                                                        assign  => $assign}),
 183                                 $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
 184                                 $thx -> {home}     => plain ($dparam {$formdata -> {posterURL} -> {name}}),
 185                                 $thx -> {image}    => plain ($dparam {$formdata -> {posterImage} -> {name}}),
 186                                 $thx -> {subject}  => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};
 187   }
 188   return;
 189 }
 190
 191 ################################
 192 # sub got_reply
 193 #
 194 # Antwortposting speichern
 195 ################################
 196
 197 sub got_reply () {
 198   my $stat;
 199
 200   my $time = time;
 201   my $pars = {author        => $dparam {$formdata -> {posterName} -> {name}},
 202               email         => $dparam {$formdata -> {posterEmail} -> {name}},
 203               category      => $dparam {$formdata -> {posterCategory} -> {name}},
 204               subject       => $dparam {$formdata -> {posterSubject} -> {name}},
 205               body          => $dparam {$formdata -> {posterBody} -> {name}},
 206               homepage      => $dparam {$formdata -> {posterURL} -> {name}},
 207               image         => $dparam {$formdata -> {posterImage} -> {name}},
 208               time          => $time,
 209               uniqueID      => $dparam {$formdata -> {uniqueID} -> {name}},
 210               ip            => $ENV{REMOTE_ADDR},
 211               parentMessage => $fmid,
 212               thread        => $ftid,
 213               forumFile     => forum_filename,
 214               messagePath   => message_path,
 215               lastThread    => $last_thread,
 216               lastMessage   => $last_message,
 217               parsedThreads => $threads,
 218               dtd           => 'forum.dtd',
 219               quoteChars    => toUTF8('»» '),
 220               messages      => $conf -> {template} -> {messages}};
 221
 222   ($stat, my $xml, my $mid) = write_posting ($pars);
 223   violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
 224   $flocked = undef;
 225
 226   if ($stat) {
 227     print "Och noe...: $stat";}
 228
 229   else {
 230     my $thx = $show_posting -> {thanx};
 231
 232     print ${$template -> scrap ($assign -> {docThx},
 233                                {$thx -> {author}   => plain ($dparam {$formdata -> {posterName} -> {name}}),
 234                                 $thx -> {email}    => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
 235                                 $thx -> {time}     => plain (hr_time($time)),
 236                                 $thx -> {body}     => message_as_HTML ($xml, $template,
 237                                                                       {posting => $mid,
 238                                                                        assign  => $assign}),
 239                                 $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
 240                                 $thx -> {home}     => plain ($dparam {$formdata -> {posterURL} -> {name}}),
 241                                 $thx -> {image}    => plain ($dparam {$formdata -> {posterImage} -> {name}}),
 242                                 $thx -> {subject}  => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};}
 243 }
 244
 245 ################################
 246 # sub new_thread
 247 #
 248 # HTML fuer Eroeffnungsposting
 249 ################################
 250
 251 sub new_thread () {
 252   my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}];
 253
 254   # spaeter kommen noch userspezifische Daten dazu...
 255   print ${$template -> scrap ($assign -> {docNew},
 256                              {$formdata->{uniqueID}      ->{assign}->{value} => plain(unique_id),
 257                               $formdata->{quoteChar}     ->{assign}->{value} => '&#255;'.plain(toUTF8('»» ')),
 258                               $formact->{post}->{assign}                     => $formact->{post}->{url},
 259                               $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list)
 260                              },$pars)};
 261 }
 262
 263 ################################
 264 # diverse subs
 265 #
 266 # Fehlermeldungen
 267 ################################
 268
 269 sub no_reply ()         {&print_fatal ($assign -> {noReply});}
 270 sub dupe_posting ()     {&print_fatal ($assign -> {dupe});}
 271 sub missing_key ()      {&print_fatal ($assign -> {wrongPar});}
 272 sub unexpected_key ()   {&print_fatal ($assign -> {wrongPar});}
 273 sub unknown_encoding () {&print_fatal ($assign -> {wrongCode});}
 274 sub too_short () {
 275   if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
 276     &print_error ($formdata -> {$failed} -> {assign} -> {tooShort},
 277                   $formdata -> {$failed} -> {minlength});}
 278
 279   else {
 280     &print_fatal ($formdata -> {$failed} -> {assign} -> {tooShort});}
 281 }
 282
 283 sub too_long () {
 284   if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
 285     &print_error ($formdata -> {$failed} -> {assign} -> {tooLong},
 286                   $formdata -> {$failed} -> {maxlength});}
 287
 288   else {
 289     &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});}
 290 }
 291
 292 sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});}
 293 sub occupied () {print_error ($assign -> {occupied});}
 294
 295 ################################
 296 # sub print_fatal
 297 #
 298 # fatale Fehlerausgabe
 299 ################################
 300
 301 sub print_fatal ($) {
 302   print ${$template -> scrap ($assign -> {docFatal},
 303                              {$assign -> {errorMessage} => $template -> insert ($_[0])
 304                              },$pars)};
 305 }
 306
 307 ################################
 308 # sub print_error
 309 #
 310 # Fehlerausgabe, Moeglichkeit
 311 # zur Korrektur
 312 ################################
 313
 314 sub print_error ($;$) {
 315   &fillin;
 316   print ${$template -> scrap ($assign -> {docError},
 317                              {$assign -> {errorMessage} => $template -> insert ($_[0]),
 318                               $assign -> {charNum}      => $_[1]
 319                              },$pars)};
 320 }
 321
 322 ################################
 323 # sub fetch_subject
 324 #
 325 # Subject und Category besorgen
 326 # (wenn noch nicht vorhanden)
 327 ################################
 328
 329 sub fetch_subject () {
 330   unless (exists ($dparam{$formdata -> {posterCategory} -> {name}}) and
 331           exists ($dparam{$formdata -> {posterSubject} -> {name}})) {
 332
 333     my $filename = message_path.'t'.$ftid.'.xml';
 334
 335     if (lock_file ($filename)) {
 336       my $xml = new XML::DOM::Parser -> parsefile ($filename);
 337       violent_unlock_file($filename) unless unlock_file ($filename);
 338
 339       my $mnode = get_message_node ($xml, "t$ftid", "m$fmid");
 340       my $header = get_message_header ($mnode);
 341
 342       $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category};
 343       $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};}}
 344 }
 345
 346 ################################
 347 # sub fillin
 348 #
 349 # Fuellen von $pars
 350 # (bereits vorhandene Formdaten)
 351 ################################
 352
 353 sub fillin () {
 354   fetch_subject;
 355
 356   my $list = [map {{$assign -> {optval} => plain($_),
 357                     (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}}
 358                 @{$formdata -> {posterCategory} -> {values}}];
 359
 360   $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list);
 361   $pars -> {$formact ->{post}->{assign}}                    = $formact->{post}->{url};
 362   $pars -> {$formdata->{quoteChar}->{assign}->{value}}      = '&#255;'.plain($dparam {$formdata -> {quoteChar} -> {name}} or '');
 363
 364   # Formfelder ausfuellen (Werte)
 365   for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) {
 366     $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});}
 367 }
 368
 369 ################################
 370 # sub decode_param
 371 #
 372 # CGI-Parameter decodieren
 373 # (rudimentaerer UTF8-support)
 374 ################################
 375
 376 sub decode_param () {
 377   my $code = param ($formdata -> {quoteChar} -> {name});
 378   my @array;
 379
 380   # UTF-8 ([hoechst-]wahrscheinlich)
 381   if ($code =~ /^\303\277/) {
 382
 383     foreach (param) {
 384       @array=param ($_);
 385
 386       if (@array == 1) {
 387         $dparam{$_} = $array[0];}
 388
 389       else {
 390         $dparam{$_} = \@array;}}}
 391
 392   # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...)
 393   elsif ($code =~ /^\377/) {
 394     foreach (param) {
 395       @array=param ($_);
 396
 397       if (@array == 1) {
 398         $dparam{$_} = toUTF8($array[0]);}
 399
 400       else {
 401         $dparam{$_} = [map {toUTF8($_)} @array];}}}
 402
 403   # unbekannte Codierung
 404   else {
 405     return;}
 406
 407   # ersten beiden Zeichen der Quotechars loeschen (Indikator [&#255; (als UTF8)])
 408   $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0];
 409
 410   delete $dparam {$formdata -> {posterURL} -> {name}}
 411     unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
 412
 413   delete $dparam {$formdata -> {posterImage} -> {name}}
 414     unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
 415
 416   # Codierung erkannt, alles klar
 417   1;
 418 }
 419
 420 ################################
 421 # sub check_param
 422 #
 423 # CGI-Parameter pruefen
 424 ################################
 425
 426 sub check_param () {
 427   my %gotKeys    = map {($_ => 1)} param;
 428   my $numGotKeys = keys %gotKeys;
 429
 430   # Threaderoeffnung, Ersteingabe (leere Seite)
 431   return 'newThread' if ($numGotKeys == 0 or
 432                          (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}})));
 433
 434   # =======================================================
 435   # ab hier steht fest, wir haben ein ausgefuelltes
 436   # Formular bekommen
 437   #
 438   # 1. Umrechnungshash bauen (CGI-Key => Identifier)
 439   # 2. alle must-keys vorhanden?
 440   # 3. zuviele Parameter uebermittelt?
 441   # 4. entsprechen die Daten den Anforderungen?
 442   #    (alle, nicht nur die must-Daten)
 443
 444   # 1
 445   # ===
 446   my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
 447
 448   # 2
 449   # ===
 450   $failed=1;
 451   foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) {
 452     return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}});
 453   }
 454
 455   # 3
 456   # ===
 457   foreach (param) {
 458     $failed = $name {$_};
 459     return 'unexpectedKey' unless (exists ($name {$_}));
 460   }
 461
 462   # 4
 463   # ===
 464   return 'unknownEncoding' unless (decode_param);
 465
 466   foreach (keys %dparam) {
 467     $failed = $name {$_};
 468
 469     return 'tooLong'   if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength});
 470     return 'tooShort'  if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength});
 471     return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
 472   }
 473
 474   $failed=0;
 475   return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew';
 476 }
 477
 478 # ====================================================
 479 # Initialisierung
 480 # ====================================================
 481
 482 BEGIN {
 483   %subhash = (newThread       => \&new_thread,
 484               missingKey      => \&missing_key,
 485               unexpectedKey   => \&unexpected_key,
 486               unknownEncoding => \&unknown_encoding,
 487               tooShort        => \&too_short,
 488               tooLong         => \&too_long,
 489               wrongMail       => \&wrong_mail,
 490               Occupied        => \&occupied,
 491               Dupe            => \&dupe_posting,
 492               noReply         => \&no_reply,
 493               gotReply        => \&got_reply,
 494               gotNew          => \&got_new
 495               );
 496
 497   # Die RFC-gerechte URL-Erkennung ist aus dem Forum
 498   # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-)
 499   my $lowalpha       =  '(?:[a-z])';
 500   my $hialpha        =  '(?:[A-Z])';
 501   my $alpha          =  "(?:$lowalpha|$hialpha)";
 502   my $digit          =  '(?:\d)';
 503   my $safe           =  '(?:[$_.+-])';
 504   my $hex            =  '(?:[\dA-Fa-f])';
 505   my $escape         =  "(?:%$hex$hex)";
 506   my $digits         =  '(?:\d+)';
 507   my $alphadigit     =  "(?:$alpha|\\d)";
 508
 509   # URL schemeparts for ip based protocols:
 510   my $port           =  "(?:$digits)";
 511   my $hostnumber     =  "(?:$digits\\.$digits\\.$digits\\.$digits)";
 512   my $toplabel       =  "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
 513   my $domainlabel    =  "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
 514   my $hostname       =  "(?:(?:$domainlabel\\.)*$toplabel)";
 515   my $host           =  "(?:(?:$hostname)|(?:$hostnumber))";
 516   my $hostport       =  "(?:(?:$host)(?::$port)?)";
 517
 518   my $httpuchar      =  "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
 519   my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 520   my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 521   my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
 522
 523   # das alles ergibt eine gueltige URL :-)
 524   $httpurl           =  "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$";
 525 }
 526
 527 # ====================================================
 528 # end of fo_posting.pl
 529 # ====================================================