selfforum-cgi/user/fo_posting.pl

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