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