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 $show_posting -> {templateFile};
  48 our $pars = {};
  49 our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked);
  50
  51 sub forum_filename () {$conf -> {files} -> {forum};}
  52 sub message_path () {$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, undef, 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           $i+=$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
 331   my %must = map {$_ => 1} @{$formmust -> {exists $dparam{$formdata -> {followUp} -> {name}}?'reply':'new'}};
 332
 333   if ( ($must{posterCategory} and not exists ($dparam{$formdata -> {posterCategory} -> {name}})) or
 334        ($must{posterSubject} and not exists ($dparam{$formdata -> {posterSubject} -> {name}})))
 335   {
 336     my $filename = message_path.'t'.$ftid.'.xml';
 337
 338     if (-f $filename and lock_file ($filename))
 339     {
 340       my $xml = new XML::DOM::Parser -> parsefile ($filename);
 341       violent_unlock_file($filename) unless unlock_file ($filename);
 342
 343       my $mnode = get_message_node ($xml, "t$ftid", "m$fmid");
 344       my $header = get_message_header ($mnode);
 345
 346       $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category};
 347       $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};
 348     }
 349   }
 350 }
 351
 352 ################################
 353 # sub fillin
 354 #
 355 # Fuellen von $pars
 356 # (bereits vorhandene Formdaten)
 357 ################################
 358
 359 sub fillin () {
 360   fetch_subject;
 361
 362   my $list = [map {{$assign -> {optval} => plain($_),
 363                     (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}}
 364                 @{$formdata -> {posterCategory} -> {values}}];
 365
 366   $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list);
 367   $pars -> {$formact ->{post}->{assign}}                    = $formact->{post}->{url};
 368   $pars -> {$formdata->{quoteChar}->{assign}->{value}}      = '&#255;'.plain($dparam {$formdata -> {quoteChar} -> {name}} or '');
 369
 370   # Formfelder ausfuellen (Werte)
 371   for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) {
 372     $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});}
 373 }
 374
 375 ################################
 376 # sub decode_param
 377 #
 378 # CGI-Parameter decodieren
 379 # (rudimentaerer UTF8-support)
 380 ################################
 381
 382 sub decode_param () {
 383   my $code = param ($formdata -> {quoteChar} -> {name});
 384   my @array;
 385
 386   # UTF-8 ([hoechst-]wahrscheinlich)
 387   if ($code =~ /^\303\277/) {
 388
 389     foreach (param) {
 390       @array=param ($_);
 391
 392       if (@array == 1) {
 393         $dparam{$_} = $array[0];}
 394
 395       else {
 396         $dparam{$_} = \@array;}}}
 397
 398   # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...)
 399   elsif ($code =~ /^\377/) {
 400     foreach (param) {
 401       @array=param ($_);
 402
 403       if (@array == 1) {
 404         $dparam{$_} = toUTF8($array[0]);}
 405
 406       else {
 407         $dparam{$_} = [map {toUTF8($_)} @array];}}}
 408
 409   # unbekannte Codierung
 410   else {
 411     return;}
 412
 413   # ersten beiden Zeichen der Quotechars loeschen (Indikator [&#255; (als UTF8)])
 414   $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0];
 415
 416   delete $dparam {$formdata -> {posterURL} -> {name}}
 417     unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
 418
 419   delete $dparam {$formdata -> {posterImage} -> {name}}
 420     unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
 421
 422   # Codierung erkannt, alles klar
 423   1;
 424 }
 425
 426 ################################
 427 # sub check_param
 428 #
 429 # CGI-Parameter pruefen
 430 ################################
 431
 432 sub check_param () {
 433   my %gotKeys    = map {($_ => 1)} param;
 434   my $numGotKeys = keys %gotKeys;
 435
 436   # Threaderoeffnung, Ersteingabe (leere Seite)
 437   return 'newThread' if ($numGotKeys == 0 or
 438                          (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}})));
 439
 440   # =======================================================
 441   # ab hier steht fest, wir haben ein ausgefuelltes
 442   # Formular bekommen
 443   #
 444   # 1. Umrechnungshash bauen (CGI-Key => Identifier)
 445   # 2. alle must-keys vorhanden?
 446   # 3. zuviele Parameter uebermittelt?
 447   # 4. entsprechen die Daten den Anforderungen?
 448   #    (alle, nicht nur die must-Daten)
 449
 450   # 1
 451   # ===
 452   my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
 453
 454   # 2
 455   # ===
 456   $failed=1;
 457   foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) {
 458     return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}});
 459   }
 460
 461   # 3
 462   # ===
 463   foreach (param) {
 464     $failed = $name {$_};
 465     return 'unexpectedKey' unless (exists ($name {$_}));
 466   }
 467
 468   # 4
 469   # ===
 470   return 'unknownEncoding' unless (decode_param);
 471
 472   foreach (keys %dparam) {
 473     $failed = $name {$_};
 474
 475     return 'tooLong'   if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength});
 476     return 'tooShort'  if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength});
 477     return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
 478   }
 479
 480   $failed=0;
 481   return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew';
 482 }
 483
 484 # ====================================================
 485 # Initialisierung
 486 # ====================================================
 487
 488 BEGIN {
 489   %subhash = (newThread       => \&new_thread,
 490               missingKey      => \&missing_key,
 491               unexpectedKey   => \&unexpected_key,
 492               unknownEncoding => \&unknown_encoding,
 493               tooShort        => \&too_short,
 494               tooLong         => \&too_long,
 495               wrongMail       => \&wrong_mail,
 496               Occupied        => \&occupied,
 497               Dupe            => \&dupe_posting,
 498               noReply         => \&no_reply,
 499               gotReply        => \&got_reply,
 500               gotNew          => \&got_new
 501               );
 502
 503   # Die RFC-gerechte URL-Erkennung ist aus dem Forum
 504   # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-)
 505   my $lowalpha       =  '(?:[a-z])';
 506   my $hialpha        =  '(?:[A-Z])';
 507   my $alpha          =  "(?:$lowalpha|$hialpha)";
 508   my $digit          =  '(?:\d)';
 509   my $safe           =  '(?:[$_.+-])';
 510   my $hex            =  '(?:[\dA-Fa-f])';
 511   my $escape         =  "(?:%$hex$hex)";
 512   my $digits         =  '(?:\d+)';
 513   my $alphadigit     =  "(?:$alpha|\\d)";
 514
 515   # URL schemeparts for ip based protocols:
 516   my $port           =  "(?:$digits)";
 517   my $hostnumber     =  "(?:$digits\\.$digits\\.$digits\\.$digits)";
 518   my $toplabel       =  "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
 519   my $domainlabel    =  "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
 520   my $hostname       =  "(?:(?:$domainlabel\\.)*$toplabel)";
 521   my $host           =  "(?:(?:$hostname)|(?:$hostnumber))";
 522   my $hostport       =  "(?:(?:$host)(?::$port)?)";
 523
 524   my $httpuchar      =  "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
 525   my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 526   my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 527   my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
 528
 529   # das alles ergibt eine gueltige URL :-)
 530   $httpurl           =  "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$";
 531 }
 532
 533 # ====================================================
 534 # end of fo_posting.pl
 535 # ====================================================