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