fo_posting.pl now runs without warnings, it's yet too special, this will be fixed...

[selfforum.git] / selfforum-cgi / user / fo_posting.pl

diff --git a/selfforum-cgi/user/fo_posting.pl b/selfforum-cgi/user/fo_posting.pl
index 388963217963f6e1166f8579d4a5e2fd81bcddfc..77bcb239d352adaf7eb0bc503a79be75c39cdf37 100644 (file)
--- a/selfforum-cgi/user/fo_posting.pl
+++ b/selfforum-cgi/user/fo_posting.pl
@@ -1,529 +1,926 @@
-#!/usr/bin/perl
+#!/usr/bin/perl -w

 
 ################################################################################
 #                                                                              #
 # File:        user/fo_posting.pl                                              #
 #                                                                              #
 
 ################################################################################
 #                                                                              #
 # File:        user/fo_posting.pl                                              #
 #                                                                              #

-# Authors:     André Malo <nd@o3media.de>, 2001-01-25                          #
+# Authors:     André Malo <nd@o3media.de>, 2001-03-31                          #

 #                                                                              #
 # Description: Accept new postings, display "Neue Nachricht" page              #
 #                                                                              #
 #                                                                              #
 # Description: Accept new postings, display "Neue Nachricht" page              #
 #                                                                              #

+# not ready, be patient please                                                 #
+#                                                                              #

 ################################################################################
 
 ################################################################################
 

+#unknown_error
+#not_saved
+#no_option
+#occupied
+#master_lock
+#no_reply
+#dupe
+#missing_key
+#unexpected_key
+#unknown_encoding
+#unknown_followup
+#too_long
+#too_short
+#wrong_mail
+#wrong_http_url
+#wrong_url
+

 use strict;
 use strict;

-use vars qw($Bin $Shared $Script %subhash $httpurl $flocked);
+use vars qw($Bin $Shared $Script);

 
 

+# locate the script
+#

 BEGIN {
 BEGIN {

-  ($Bin)    = ($0 =~ /^(.*)\/.*$/)? $1 : '.';
+  my $null = $0; $null =~ s/\\/\//g; # for win :-(
+  ($Bin)    = ($null =~ /^(.*)\/.*$/)? $1 : '.';

   $Shared   = "$Bin/../shared";
   $Shared   = "$Bin/../shared";

-  ($Script) = ($0 =~ /^.*\/(.*)$/)? $1 : $0;}
+  ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null;
+}

 
 

+use lib "$Shared";

 use CGI::Carp qw(fatalsToBrowser);
 
 use CGI::Carp qw(fatalsToBrowser);
 

-use lib "$Shared";

 use Conf;
 use Conf;

-use Encode::Plain; $Encode::Plain::utf8 = 1;
-use Encode::Posting;
-use Id;
-use Lock qw(:ALL);
-use Mail;
-use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time);
-use Posting::Write;
-use Template;
-use Template::Posting;
-
-use CGI qw(param header);
-use XML::DOM;
+use Conf::Admin;

 
 

-print header (-type => 'text/html');
-
-our $conf = read_script_conf ($Bin, $Shared, $Script);
-
-our $show_posting = $conf -> {show} -> {Posting};
-our $assign   = $show_posting -> {assign};
-our $formmust = $show_posting -> {form} -> {must};
-our $formdata = $show_posting -> {form} -> {data};
-our $formact  = $show_posting -> {form} -> {action};
-our $template = new Template "$Bin/".$show_posting -> {templateFile};
-our $pars = {};
-our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked);
-
-sub forum_filename () {$conf -> {wwwRoot} . $conf -> {files} -> {forum};}
-sub message_path () {$conf -> {wwwRoot} . $conf -> {files} -> {messagePath};}
+# load script configuration and admin default conf.
+#
+my $conf         = read_script_conf ($Bin, $Shared, $Script);
+my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});

 
 

-################################
+# Initialize the request
+#
+my $request = new Posting::Request ($conf, $adminDefault);

 
 

-# Formfelder ausfuellen (Namen)
-for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) {
-  $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});}
+# fetch and parse the cgi-params
+#
+$request -> parse_cgi;

 
 

-my $checked = &check_param;
+# handle errors or save the posting
+#
+$request -> handle_error or $request -> save;

 
 

-unless (exists ($subhash {$checked})) {
-  &print_fatal ($assign -> {unknownError});}
+# show response
+#
+$request -> response;

 
 

-else {
-  unless ($checked eq 'newThread') {
-    $checked = &check_reply_dupe() || $checked;}
+#
+#
+### main end ###################################################################

 
 

-  unless (exists ($subhash {$checked})) {
-    &print_fatal ($assign -> {unknownError});}
-  else {
-    &{$subhash {$checked}};}
+################################################################################
+### Posting::Request ###########################################################
+package Posting::Request;

 
 

-  if ($flocked) {
-    violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}}
+use CheckRFC;
+use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
+use Encode::Posting;
+use Lock          qw(:ALL);
+use Posting::_lib qw(
+  hr_time
+  parse_xml_file
+  get_all_threads
+  get_message_node
+  get_message_header
+  KEEP_DELETED
+);
+use Posting::Write;
+use Id;
+use Template;
+use Template::Posting;

 
 

-# ====================================================
-# end of main / Funktionen
-# ====================================================
+use CGI;

 
 

+### sub new ####################################################################
+#
+# initialising the Posting::Request object
+# check parameters and fill in object properties
+#
+sub new {
+  my ($class, $conf, $adminDefault) = @_;
+
+  my $sp = $conf -> {show} -> {Posting};
+
+  my $self = {
+       conf => {
+         original => $conf,
+         admin    => $adminDefault,
+
+         message_path    => $conf -> {files} -> {messagePath},
+         forum_file_name => $conf -> {files} -> {forum},
+
+         show_posting    => $sp,
+         assign          => $sp -> {assign},
+         template        => $conf -> {template},
+         form_must       => $sp -> {form} -> {must},
+         form_data       => $sp -> {form} -> {data},
+         form_action     => $sp -> {form} -> {action},
+       },
+
+       template => new Template $sp -> {templateFile},
+       response => {},
+       forum    => {},
+       error    => {}
+     };
+
+  bless $self, $class;
+}

 
 

-### check_reply_dupe () ########################################################
+### sub response ###############################################################

 #
 #

-# Reply moeglich? Doppelposting?
+# print the response to STDOUT

 #
 #

-# Params: -none-
-# Return: Dupe check result
-#         'Dupe'  - Posting is a dupe
-#         Nothing - ok.
+# Return: -none-

 #
 #

-sub check_reply_dupe () {
-  my $stat;
+sub response {
+  my $self = shift;
+  my $formdata = $self -> {conf} -> {form_data};
+  my $formact  = $self -> {conf} -> {form_action};
+  my $template = $self -> {template};
+  my $assign   = $self -> {conf} -> {assign};
+  my $q        = $self -> {cgi_object};
+
+  # fill out the form field names
+  #
+  my $pars = {};
+  for (keys %$formdata) {
+    $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name}) if (
+      exists($formdata -> {$_} -> {name})
+      and exists ($formdata -> {$_} -> {assign})
+      and exists ($formdata -> {$_} -> {assign} -> {name})
+    );
+  }

 
 

-  unless ($stat = write_lock_file (forum_filename)) {
-    if ($stat == 0) {
-      # ueberlastet oder so
-      violent_unlock_file (forum_filename);
-      return 'Occupied';
-    } else {
-      return 'masterLock';
-    }
-  } else {
-    my ($i, %msg, %unids);
+  # response the 'new message' page
+  #
+  if ($self -> {response} -> {new_thread}) {
+    my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}];
+
+    print $q -> header (-type => 'text/html');
+    print ${$template -> scrap (
+      $assign -> {docNew},
+      { $formdata->{uniqueID}      ->{assign}->{value} => plain(unique_id),
+        $formdata->{quoteChar}     ->{assign}->{value} =>
+          '&#255;'.plain($self -> {conf} -> {admin} -> {View} -> {quoteChars}),
+        $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list),
+        $formact->{post}->{assign}                     => $formact->{post}->{url}
+      },
+      $pars
+    )};
+    return;
+  }

 
 

-    $flocked = 1;
+  # check the response -> doc
+  #
+  unless ($self -> {response} -> {doc}) {
+    $self -> {error} = {
+      spec => 'unknown_error',
+      type => 'fatal'
+    };

 
 

-    ($threads, $last_thread, $last_message, my $unids) = get_all_threads (forum_filename, 1, 0);
-    ($ftid,$fmid) = split /;/,$dparam{$formdata -> {followUp} -> {name}},2;
+    $self -> handle_error;

 
 

-    # Thread existiert nicht
-    if (exists($dparam{$formdata -> {followUp} -> {name}})) {
-      return 'noReply' unless (exists($threads -> {$ftid}));
+    unless ($self -> {response} -> {doc}) {
+      $self -> jerk ('While producing the HTML response an unknown error has occurred.');
+      return;
+    }
+  }

 
 

-      # nur nicht geloeschte Messages beachten
-      for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
-        if ($threads -> {$ftid} -> [$i] -> {deleted}) {
-          $i+=$threads -> {$ftid} -> [$i] -> {answers};}
+  # ok, print the response document to STDOUT
+  #
+  print $q -> header (-type => 'text/html');
+  print ${$template -> scrap (
+      $self -> {response} -> {doc},
+      $pars,
+      $self -> {response} -> {pars}
+    )
+  };

 
 

-        else {
-          $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;}}
+  return;
+}

 
 

-      # Message existiert nicht
-      if (exists($dparam{$formdata -> {followUp} -> {name}})) {
-        return 'noReply' unless (exists($msg{$fmid}));}
+### sub handle_error ###########################################################
+#
+# analyze error data and create content for the response method
+#
+# Return: true  if error detected
+#         false otherwise
+#
+sub handle_error {
+  my $self = shift;

 
 

-      %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
-    } else {
-      %unids = map {$_ => 1} @$unids;
-    }
+  my $spec = $self -> {error} -> {spec};

 
 

-    # jetzt endlich
-    return 'Dupe' if (exists ($unids{$dparam{$formdata -> {uniqueID} -> {name}}}));
-  }
+  return unless ($spec);

 
 

-  return;
-}
+  my $assign   = $self -> {conf} -> {assign};
+  my $formdata = $self -> {conf} -> {form_data};

 
 

-################################
-# sub got_new
-#
-# Eroeffnungsposting speichern
-################################
-
-sub got_new () {
-
-  my $time = time;
-  my $pars = {author        => $dparam {$formdata -> {posterName} -> {name}},
-              email         => $dparam {$formdata -> {posterEmail} -> {name}},
-              category      => $dparam {$formdata -> {posterCategory} -> {name}},
-              subject       => $dparam {$formdata -> {posterSubject} -> {name}},
-              body          => $dparam {$formdata -> {posterBody} -> {name}},
-              homepage      => $dparam {$formdata -> {posterURL} -> {name}},
-              image         => $dparam {$formdata -> {posterImage} -> {name}},
-              time          => $time,
-              uniqueID      => $dparam {$formdata -> {uniqueID} -> {name}},
-              ip            => $ENV{REMOTE_ADDR},
-              forumFile     => forum_filename,
-              messagePath   => message_path,
-              lastThread    => $last_thread,
-              lastMessage   => $last_message,
-              parsedThreads => $threads,
-              dtd           => 'forum.dtd',
-              quoteChars    => toUTF8('»» '),
-              messages      => $conf -> {template} -> {messages}};
-
-  my ($stat, $xml, $mid) = write_posting ($pars);
-  violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
-  $flocked = undef;
-
-  if ($stat) {
-    print "Och noe...: $stat";}
+  my $desc = $self -> {error} -> {desc} || '';
+  my $type = $self -> {error} -> {type};
+  my $emsg;

 
 

+  if (exists ($formdata -> {$desc})
+      and exists ($formdata -> {$desc} -> {assign} -> {$spec})) {
+    $emsg = $formdata -> {$desc} -> {assign} -> {$spec};
+  }

   else {
   else {

-    my $thx = $show_posting -> {thanx};
-
-    print ${$template -> scrap ($assign -> {docThx},
-                               {$thx -> {author}   => plain ($dparam {$formdata -> {posterName} -> {name}}),
-                                $thx -> {email}    => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
-                                $thx -> {time}     => plain (hr_time($time)),
-                                $thx -> {body}     => message_as_HTML ($xml, $template,
-                                                                      {posting => $mid,
-                                                                       assign  => $assign}),
-                                $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
-                                $thx -> {home}     => plain ($dparam {$formdata -> {posterURL} -> {name}}),
-                                $thx -> {image}    => plain ($dparam {$formdata -> {posterImage} -> {name}}),
-                                $thx -> {subject}  => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};
+    $emsg = $assign -> {$spec} || '';

   }
   }

-  return;
-}

 
 

-################################
-# sub got_reply
-#
-# Antwortposting speichern
-################################
-
-sub got_reply () {
-  my $stat;
-
-  my $time = time;
-  my $pars = {author        => $dparam {$formdata -> {posterName} -> {name}},
-              email         => $dparam {$formdata -> {posterEmail} -> {name}},
-              category      => $dparam {$formdata -> {posterCategory} -> {name}},
-              subject       => $dparam {$formdata -> {posterSubject} -> {name}},
-              body          => $dparam {$formdata -> {posterBody} -> {name}},
-              homepage      => $dparam {$formdata -> {posterURL} -> {name}},
-              image         => $dparam {$formdata -> {posterImage} -> {name}},
-              time          => $time,
-              uniqueID      => $dparam {$formdata -> {uniqueID} -> {name}},
-              ip            => $ENV{REMOTE_ADDR},
-              parentMessage => $fmid,
-              thread        => $ftid,
-              forumFile     => forum_filename,
-              messagePath   => message_path,
-              lastThread    => $last_thread,
-              lastMessage   => $last_message,
-              parsedThreads => $threads,
-              dtd           => 'forum.dtd',
-              quoteChars    => toUTF8('»» '),
-              messages      => $conf -> {template} -> {messages}};
-
-  ($stat, my $xml, my $mid) = write_posting ($pars);
-  violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));
-  $flocked = undef;
-
-  if ($stat) {
-    print "Och noe...: $stat";}
+  # fatal errors
+  #
+  if ($type eq 'fatal') {
+    $self -> {response} -> {doc}  = $assign -> {docFatal};
+    $self -> {response} -> {pars} = {
+      $assign -> {errorMessage} => $self -> {template} -> insert ($emsg)
+    };
+  }

 
 

-  else {
-    my $thx = $show_posting -> {thanx};
-
-    print ${$template -> scrap ($assign -> {docThx},
-                               {$thx -> {author}   => plain ($dparam {$formdata -> {posterName} -> {name}}),
-                                $thx -> {email}    => plain ($dparam {$formdata -> {posterEmail} -> {name}}),
-                                $thx -> {time}     => plain (hr_time($time)),
-                                $thx -> {body}     => message_as_HTML ($xml, $template,
-                                                                      {posting => $mid,
-                                                                       assign  => $assign}),
-                                $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}),
-                                $thx -> {home}     => plain ($dparam {$formdata -> {posterURL} -> {name}}),
-                                $thx -> {image}    => plain ($dparam {$formdata -> {posterImage} -> {name}}),
-                                $thx -> {subject}  => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};}
+  # 'soft' errors
+  # user is able to repair his request
+  #
+  elsif ($type eq 'repeat' or $type eq 'fetch') {
+    $self -> {response} -> {doc} = $assign -> {docError};
+    $self -> fillout_form;
+    $self -> {response} -> {pars} -> {$assign -> {errorMessage}} = $self -> {template} -> insert ($emsg);
+    my $num = $spec eq 'too_long'
+      ? $formdata -> {$desc} -> {maxlength}
+      : ($spec eq 'too_short'
+          ? $formdata -> {$desc} -> {minlength}
+          : undef
+        );
+
+    $self -> {response} -> {pars} -> {$assign -> {charNum}} = $num
+      if $num;
+  }
+
+  1;

 }
 
 }
 

-################################
-# sub new_thread
+### sub fillout_form ###########################################################
+#
+# fill out the form using available form data
+#
+# Return: -none-

 #
 #

-# HTML fuer Eroeffnungsposting
-################################
+sub fillout_form {
+  my $self = shift;
+
+  my $assign   = $self -> {conf} -> {assign};
+  my $formdata = $self -> {conf} -> {form_data};
+  my $formact  = $self -> {conf} -> {form_action};
+  my $q        = $self -> {cgi_object};
+  my $pars     = {};
+
+  # fill out the form
+  #
+  $pars -> {$formact -> {post} -> {assign}} = $formact -> {post} -> {url};

 
 

-sub new_thread () {
-  my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}];
+  for (keys %$formdata) {
+    if ($_ eq 'quoteChar') {
+      $pars -> {$formdata->{$_}->{assign}->{value}}
+      = '&#255;'.plain($q -> param ($formdata -> {quoteChar} -> {name}) or '');
+    }
+    elsif (exists ($formdata -> {$_} -> {name})) {
+      unless (exists ($formdata -> {$_} -> {values})) {
+        $pars -> {$formdata -> {$_} -> {assign} -> {value}}
+        = plain($q -> param ($formdata -> {$_} -> {name}));
+      }
+      else {
+        my $_name = $_;
+        $pars -> {$formdata -> {$_} -> {assign} -> {value}}
+        = $self -> {template} -> list (
+            $assign -> {option},
+            [ map {
+                { $assign -> {optval} => plain($_),
+                  (( $_ eq $q -> param ($formdata -> {$_name} -> {name}))
+                    ? ($assign -> {optsel} => 1)
+                    : ()
+                  )
+                }
+              } @{$formdata -> {$_name} -> {values}}
+            ]
+          );
+      }
+    }
+  }

 
 

-  # spaeter kommen noch userspezifische Daten dazu...
-  print ${$template -> scrap ($assign -> {docNew},
-                             {$formdata->{uniqueID}      ->{assign}->{value} => plain(unique_id),
-                              $formdata->{quoteChar}     ->{assign}->{value} => '&#255;'.plain(toUTF8('»» ')),
-                              $formact->{post}->{assign}                     => $formact->{post}->{url},
-                              $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list)
-                             },$pars)};
+  $self -> {response} -> {pars} = $pars;
+  return;

 }
 
 }
 

-################################
-# diverse subs
+### sub save ###################################################################
+#
+# save posting
+# check on legal reply or dupe is released here

 #
 #

-# Fehlermeldungen
-################################
+# Return: -none-
+#
+sub save {
+  my $self = shift;

 
 

-sub no_reply ()         {&print_fatal ($assign -> {noReply});}
-sub dupe_posting ()     {&print_fatal ($assign -> {dupe});}
-sub missing_key ()      {&print_fatal ($assign -> {wrongPar});}
-sub unexpected_key ()   {&print_fatal ($assign -> {wrongPar});}
-sub unknown_encoding () {&print_fatal ($assign -> {wrongCode});}
-sub too_short () {
-  if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
-    &print_error ($formdata -> {$failed} -> {assign} -> {tooShort},
-                  $formdata -> {$failed} -> {minlength});}
+  # if an empty 'new message' document, there's nothing to save
+  #
+  return if ($self -> {response} -> {new_thread});

 
 

-  else {
-    &print_fatal ($formdata -> {$failed} -> {assign} -> {tooShort});}
-}
+  $self -> {check_success} = 0;

 
 

-sub too_long () {
-  if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
-    &print_error ($formdata -> {$failed} -> {assign} -> {tooLong},
-                  $formdata -> {$failed} -> {maxlength});}
+  # lock and load the forum main file
+  #
+  if ($self -> load_main_file) {
+
+    # if a reply - is it legal?
+    # is it a dupe?
+    #
+    if ($self -> check_reply_dupe) {
+
+      unless ($self -> {response} -> {reply} or $self -> {response} -> {new}) {
+        # don't know, if we any time come to this branch
+        # the script is probably broken
+        #
+        $self -> {error} = {
+          spec => 'unknown_error',
+          type => 'fatal'
+        };
+      }
+      else {
+        my $time     = time;
+        my $formdata = $self -> {conf} -> {form_data};
+        my $q        = $self -> {cgi_object};
+        my $f        = $self -> {forum};
+        my $pars     = {
+          author        => $q -> param ($formdata -> {posterName} -> {name}),
+          email         => $q -> param ($formdata -> {posterEmail} -> {name}),
+          category      => $q -> param ($formdata -> {posterCategory} -> {name}),
+          subject       => $q -> param ($formdata -> {posterSubject} -> {name}),
+          body          => $q -> param ($formdata -> {posterBody} -> {name}),
+          homepage      => $q -> param ($formdata -> {posterURL} -> {name}),
+          image         => $q -> param ($formdata -> {posterImage} -> {name}),
+          quoteChars    => $q -> param ($formdata -> {quoteChar} -> {name}),
+          uniqueID      => $q -> param ($formdata -> {uniqueID} -> {name}),
+          time          => $time,
+          ip            => $q -> remote_addr,
+          forumFile     => $self -> {conf} -> {forum_file_name},
+          messagePath   => $self -> {conf} -> {message_path},
+          lastThread    => $f -> {last_thread},
+          lastMessage   => $f -> {last_message},
+          parsedThreads => $f -> {threads},
+          dtd           => $f -> {dtd},
+          messages      => $self -> {template} -> {messages}
+        };
+
+        if ($self -> {response} -> {reply}) {
+          $pars -> {parentMessage} = $self -> {fup_mid};
+          $pars -> {thread}        = $self -> {fup_tid};
+        }
+
+        my ($stat, $xml, $mid) = write_posting ($pars);
+
+        if ($stat) {
+          $self -> {error} = {
+            spec => 'not_saved',
+            desc => $stat,
+            type => 'fatal'
+          };
+        }
+        else {
+          $self -> {check_success} = 1;
+          my $thx      = $self -> {conf} -> {show_posting} -> {thanx};
+
+          # define special response data
+          #
+          $self -> {response} -> {doc}  = $self -> {conf} -> {assign} -> {docThx};
+          $self -> {response} -> {pars} = {
+            $thx -> {subject}  => plain ($q -> param ($formdata -> {posterSubject} -> {name})),
+            $thx -> {author}   => plain ($q -> param ($formdata -> {posterName} -> {name})),
+            $thx -> {email}    => plain ($q -> param ($formdata -> {posterEmail} -> {name})),
+            $thx -> {time}     => plain (hr_time($time)),
+            $thx -> {body}     => message_as_HTML (
+              $xml,
+              $self -> {template},
+              { posting    => $mid,
+                assign     => $self -> {conf} -> {assign},
+                quoteChars => $q -> param ($formdata -> {quoteChar} -> {name}),
+                quoting    => $self -> {conf} -> {admin} -> {View} -> {quoting}
+              }),
+            $thx -> {category} => plain ($q -> param ($formdata -> {posterCategory} -> {name})),
+            $thx -> {home}     => plain ($q -> param ($formdata -> {posterURL} -> {name})),
+            $thx -> {image}    => plain ($q -> param ($formdata -> {posterImage} -> {name}))
+          };
+        }
+      }
+    }
+  }

 
 

-  else {
-    &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});}
-}
+  # unlock forum main file
+  #
+  if ($self -> {forum} -> {flocked}) {
+    violent_unlock_file($self -> {conf} -> {forum_file_name}) unless write_unlock_file ($self -> {conf} -> {forum_file_name});
+    $self -> {forum} -> {flocked} = 0;
+  }
+
+  $self -> handle_error unless $self -> {check_success};

 
 

-sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});}
-sub occupied () {print_error ($assign -> {occupied});}
+  return;
+}

 
 

-################################
-# sub print_fatal
+### sub parse_cgi ##############################################################
+#
+# fetch and decode cgi-parameters,
+# find out the kind of response requested by the user (new message, reply)
+#
+# Return: -none-

 #
 #

-# fatale Fehlerausgabe
-################################
+sub parse_cgi {
+  my $self = shift;

 
 

-sub print_fatal ($) {
-  print ${$template -> scrap ($assign -> {docFatal},
-                             {$assign -> {errorMessage} => $template -> insert ($_[0])
-                             },$pars)};
+  # create the CGI object
+  #
+  $self -> {cgi_object} = new CGI;
+
+  # check the params
+  #
+  $self -> {check_success} = $self -> check_cgi;
+
+  return;

 }
 
 }
 

-################################
-# sub print_error
+### sub load_main_file #########################################################

 #
 #

-# Fehlerausgabe, Moeglichkeit
-# zur Korrektur
-################################
+# load and parse the forum main file
+#
+# Return: Success (true/false)
+#
+sub load_main_file {
+  my $self = shift;
+  my $lock_stat;
+
+  unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
+    if (defined $lock_stat and $lock_stat == 0) {
+      # occupied or no w-bit set for the directory..., hmmm
+      #
+      violent_unlock_file ($self -> {conf} -> {forum_file_name});
+      $self -> {error} = {
+        spec => 'occupied',
+        type => 'repeat'
+      };
+      return;
+    }
+    else {
+      # master lock is set
+      #
+      $self -> {error} = {
+        spec => 'master_lock',
+        type => 'fatal'
+      };
+      return;
+    }
+  }
+  else {
+    $self -> {forum} -> {flocked} = 1;
+    ( $self -> {forum} -> {threads},
+      $self -> {forum} -> {last_thread},
+      $self -> {forum} -> {last_message},
+      $self -> {forum} -> {dtd},
+      $self -> {forum} -> {unids}
+    ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
+  }

 
 

-sub print_error ($;$) {
-  &fillin;
-  print ${$template -> scrap ($assign -> {docError},
-                             {$assign -> {errorMessage} => $template -> insert ($_[0]),
-                              $assign -> {charNum}      => $_[1]
-                             },$pars)};
+  # ok, looks good
+  1;

 }
 
 }
 

-################################
-# sub fetch_subject
+### sub check_reply_dupe #######################################################
+#
+# check whether a reply is legal
+# (followup posting must exists)

 #
 #

-# Subject und Category besorgen
-# (wenn noch nicht vorhanden)
-################################
+# check whether this form request is a dupe
+# (unique id already exists)
+#
+# Return: Status Code (Bool)
+#
+sub check_reply_dupe {
+  my $self = shift;
+  my %unids;
+
+  # return true unless it's not a reply
+  # or an opening
+  #
+  return 1 unless (
+    $self -> {response} -> {reply}
+    or $self -> {response} -> {new}
+  );
+
+  if ($self -> {response} -> {reply}) {
+
+    my ($threads, $ftid, $fmid, $i, %msg) = (
+          $self -> {forum} -> {threads},
+          $self -> {fup_tid},
+          $self -> {fup_mid}
+       );
+
+    # thread doesn't exist
+    #
+    unless (exists($threads -> {$ftid})) {
+      $self -> {error} = {
+        spec => 'no_reply',
+        type => 'fatal'
+      };
+      return;
+    }

 
 

-sub fetch_subject () {
-  unless (exists ($dparam{$formdata -> {posterCategory} -> {name}}) and
-          exists ($dparam{$formdata -> {posterSubject} -> {name}})) {
+    # build a reverse lookup hash (mid => number in array)
+    # and ignore invisible messages
+    # (users can't reply to "deleted" msg)
+    #
+    for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {

 
 

-    my $filename = message_path.'t'.$ftid.'.xml';
+      if ($threads -> {$ftid} -> [$i] -> {deleted}) {
+        $i+=$threads -> {$ftid} -> [$i] -> {answers};
+      }
+      else {
+        $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
+      }
+    }

 
 

-    if (lock_file ($filename)) {
-      my $xml = new XML::DOM::Parser -> parsefile ($filename);
-      violent_unlock_file($filename) unless unlock_file ($filename);
+    # message doesn't exist
+    #
+    unless (exists($msg{$fmid})) {
+      $self -> {error} = {
+        spec => 'no_reply',
+        type => 'fatal'
+      };
+      return;
+    }
+
+    # build a unique id lookup hash
+    # use the unids of parent message's kids
+    #
+    %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
+  }
+  else {
+    # build a unique id lookup hash, too
+    # but use only the level-zero-messages
+    #
+    %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
+  }

 
 

-      my $mnode = get_message_node ($xml, "t$ftid", "m$fmid");
-      my $header = get_message_header ($mnode);
+  # now check on dupe
+  #
+  if (exists ($unids{
+                $self -> {cgi_object} -> param (
+                  $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
+    $self -> {error} = {
+      spec => 'dupe',
+      type => 'fatal'
+    };
+    return;
+  }

 
 

-      $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category};
-      $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};}}
+  # ok, looks fine
+  1;

 }
 
 }
 

-################################
-# sub fillin
+### sub check_cgi ##############################################################
+#
+# cgi params are like raw eggs...

 #
 #

-# Fuellen von $pars
-# (bereits vorhandene Formdaten)
-################################
+# Return: Status Code (Bool)
+#         creates content for the handle_error method if anything fails
+#
+sub check_cgi {
+  my $self = shift;

 
 

-sub fillin () {
-  fetch_subject;
+  # count the submitted keys and get the keys themselves
+  #
+  my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
+  my $cnt_got_keys = keys %got_keys;
+  my $formdata     = $self -> {conf} -> {form_data};
+  my $formmust     = $self -> {conf} -> {form_must};

 
 

-  my $list = [map {{$assign -> {optval} => plain($_),
-                    (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}}
-                @{$formdata -> {posterCategory} -> {values}}];
+  # user requested the 'new thread' page
+  # (no params but perhaps the user-ID have been submitted)
+  #
+  if ($cnt_got_keys == 0 or (
+        exists ($formdata -> {userID})
+        and $cnt_got_keys == 1
+        and $got_keys{$formdata -> {userID} -> {name}}
+        )) {
+    $self -> {response} -> {new_thread} = 1;
+    $self -> {check_success} = 1;
+    return 1;
+  }

 
 

-  $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list);
-  $pars -> {$formact ->{post}->{assign}}                    = $formact->{post}->{url};
-  $pars -> {$formdata->{quoteChar}->{assign}->{value}}      = '&#255;'.plain($dparam {$formdata -> {quoteChar} -> {name}} or '');
+  # now we know, we've got a filled out form
+  # we do the following steps to check it:
+  #
+  # 1st: create a reverse Hash (CGI-key - identifier)
+  # 2nd: did we get _all_ must-keys?
+  #      check whether reply or new message request
+  # 3rd: did we get too many keys?
+  # 4th: do _all_ submitted values accord to
+  #      our expectations?
+  #      fetch the "missing" keys
+  #

 
 

-  # Formfelder ausfuellen (Werte)
-  for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) {
-    $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});}
-}
+  # 1
+  #
+  my %name = map {
+    exists($formdata -> {$_} -> {name})
+    ? ($formdata -> {$_} -> {name} => $_)
+    : ()
+  } keys %$formdata;

 
 

-################################
-# sub decode_param
-#
-# CGI-Parameter decodieren
-# (rudimentaerer UTF8-support)
-################################
+  # 2
+  #
+  $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
+  $self -> {response} -> {new}   = not $self -> {response} -> {reply};

 
 

-sub decode_param () {
-  my $code = param ($formdata -> {quoteChar} -> {name});
-  my @array;
+  # define the fetch array (values to fetch from parent message)
+  #
+  $self -> {fetch} = [];

 
 

-  # UTF-8 ([hoechst-]wahrscheinlich)
-  if ($code =~ /^\303\277/) {
+  for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {

 
 

-    foreach (param) {
-      @array=param ($_);
+    unless ($got_keys {$formdata -> {$_} -> {name}}) {

 
 

-      if (@array == 1) {
-        $dparam{$_} = $array[0];}
+      # only miss the key unless we're able to fetch it from parent posting
+      #
+      unless (
+        not $self -> {response} -> {reply}
+        or $formdata -> {$_} -> {errorType} eq 'fetch') {

 
 

+        $self -> {error} = {
+          spec => 'missing_key',
+          desc => $_,
+          type => 'fatal'
+        };
+        return;
+      }

       else {
       else {

-        $dparam{$_} = \@array;}}}
+        # keep in mind to fetch the value later
+        #
+        push @{$self -> {fetch}} => $_;
+      }
+    }
+  }

 
 

-  # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...)
-  elsif ($code =~ /^\377/) {
-    foreach (param) {
-      @array=param ($_);
+  # I'm lazy - I know...
+  my $q = $self -> {cgi_object};

 
 

-      if (@array == 1) {
-        $dparam{$_} = toUTF8($array[0]);}
+  # 3
+  #
+  for ($q -> param) {
+    unless (exists ($name {$_})) {
+      $self -> {error} = {
+        spec => 'unexpected_key',
+        desc => $name{$_},
+        type => 'fatal'
+      };
+      return;
+    }
+  }

 
 

-      else {
-        $dparam{$_} = [map {toUTF8($_)} @array];}}}
+  # 4
+  #
+  unless ($self -> decode_param) {
+    $self -> {error} = {
+      spec => 'unknown_encoding',
+      type => 'fatal'
+    };
+    return;
+  };
+
+  if ($self -> {response} -> {reply}) {
+
+    # get the parent-identifiers if we got a reply request
+    #
+    my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
+
+    unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
+      $self -> {error} = {
+        spec => 'unknown_followup',
+        type => 'fatal'
+      };
+      return;
+    }
+    $self -> {fup_tid} = $ftid;
+    $self -> {fup_mid} = $fmid;
+
+    # fetch the missing keys
+    # if it fails, they're too short, too... ;)
+    #
+    $self -> fetch;
+    $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
+  }

 
 

-  # unbekannte Codierung
-  else {
-    return;}
+  # now we can check on length, type etc.
+  #
+  for (keys %got_keys) {
+
+    # we are sure, we've got only one value for one key
+    #
+    my $val = $q -> param ($_);
+
+    $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
+    $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
+      unless (
+        exists ($formdata -> {$name {$_}} -> {type})
+        and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
+      );
+
+    $q -> param ($_ => $val);  # write it back
+
+    # too long?
+    #
+    if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
+      $self -> {error} = {
+        spec => 'too_long',
+        desc => $name{$_},
+        type => $formdata -> {$name {$_}} -> {errorType}
+      };
+      $self -> kill_param or return;
+    }

 
 

-  # ersten beiden Zeichen der Quotechars loeschen (Indikator [&#255; (als UTF8)])
-  $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0];
+    # too short?
+    # (only check if there's defined a minimum length)
+    #
+    if (exists ($formdata -> {$name {$_}} -> {minlength})) {
+
+      # kill the whitespaces to get only the visible characters...
+      #
+      (my $val_ww = $val) =~ s/\s+//g;
+
+      if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
+        $self -> {error} = {
+          spec => 'too_short',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+        $self -> kill_param or return;
+      }
+    }

 
 

-  delete $dparam {$formdata -> {posterURL} -> {name}}
-    unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
+    # check the values on expected kinds of content
+    # (email, http-url, url, option)
+    #
+    if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
+      if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
+        $self -> {error} = {
+          spec => 'wrong_mail',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+        $self -> kill_param or return;
+      }
+
+      elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
+        $self -> {error} = {
+          spec => 'wrong_http_url',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+        $self -> kill_param or return;
+      }
+
+      elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
+        $self -> {error} = {
+          spec => 'wrong_url',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+        $self -> kill_param or return;
+      }
+    }

 
 

-  delete $dparam {$formdata -> {posterImage} -> {name}}
-    unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
+    if (exists ($formdata -> {$name {$_}} -> {values})
+        and not exists ({map {$_ => undef} @{$formdata -> {$name {$_}} -> {values}}} -> {$val})) {
+        $self -> {error} = {
+          spec => 'no_option',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+        $self -> kill_param or return;
+    }
+  }

 
 

-  # Codierung erkannt, alles klar
+  # ok, looks good.

   1;
 }
   1;
 }

+### sub kill_param #############################################################
+#
+# kill the param (set it on '') if wrong and declared as 'kill' in config file
+#
+# Return: true  if killed
+#         false otherwise
+#
+sub kill_param {
+  my $self = shift;
+
+  if ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {errorType} eq 'kill') {
+    $self -> {cgi_object} -> param ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {name} => '');
+    $self -> {error} = {};
+    return 1;
+  }
+
+  return;
+}

 
 

-################################
-# sub check_param
+### sub fetch ##################################################################
+#
+# fetch "missing" keys from parent posting

 #
 #

-# CGI-Parameter pruefen
-################################
+sub fetch {
+  my $self = shift;
+  my $q = $self -> {cgi_object};
+  my $formdata = $self -> {conf} -> {form_data};

 
 

-sub check_param () {
-  my %gotKeys    = map {($_ => 1)} param;
-  my $numGotKeys = keys %gotKeys;
+  if (@{$self -> {fetch}}) {
+    my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';

 
 

-  # Threaderoeffnung, Ersteingabe (leere Seite)
-  return 'newThread' if ($numGotKeys == 0 or
-                         (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}})));
+    if (lock_file ($filename)) {
+      my $xml = parse_xml_file ($filename);
+      violent_unlock_file($filename) unless unlock_file ($filename);

 
 

-  # =======================================================
-  # ab hier steht fest, wir haben ein ausgefuelltes
-  # Formular bekommen
-  #
-  # 1. Umrechnungshash bauen (CGI-Key => Identifier)
-  # 2. alle must-keys vorhanden?
-  # 3. zuviele Parameter uebermittelt?
-  # 4. entsprechen die Daten den Anforderungen?
-  #    (alle, nicht nur die must-Daten)
+      if ($xml) {
+        my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
+        if ($mnode) {
+          my $header = get_message_header ($mnode);

 
 

-  # 1
-  # ===
-  my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
+          $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
+            for (@{$self -> {fetch}});

 
 

-  # 2
-  # ===
-  $failed=1;
-  foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) {
-    return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}});
+          return;
+        }
+      }
+    }

   }
 
   }
 

-  # 3
-  # ===
-  foreach (param) {
-    $failed = $name {$_};
-    return 'unexpectedKey' unless (exists ($name {$_}));
-  }
+  # fetching failed:
+  # fillout the values with an empty string
+  #
+  $q -> param ($formdata -> {$_} -> {name} => '')
+    for (@{$self -> {fetch}});

 
 

-  # 4
-  # ===
-  return 'unknownEncoding' unless (decode_param);
+  return;
+}
+
+### sub decode_param ###########################################################
+#
+# convert submitted form data into UTF-8
+# unless it's not encoded yet
+#
+# Return: Status Code (Bool)
+#         false if unknown encoding (like UTF-7 for instance)
+#
+sub decode_param {
+  my $self = shift;

 
 

-  foreach (keys %dparam) {
-    $failed = $name {$_};
+  my $q = $self -> {cgi_object};
+  my $formdata = $self -> {conf} -> {form_data};

 
 

-    return 'tooLong'   if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength});
-    return 'tooShort'  if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength});
-    return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
+  my $code = $q -> param ($formdata -> {quoteChar} -> {name});
+  my @array;
+
+  # Latin 1 (we hope so - there's no real way to find out :-( )
+  if ($code =~ /^\377/) {
+    $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
+  }
+  else {
+    # UTF-8 is (probably) correct,
+    # other encodings we don't know and fail
+    return unless $code =~ /^\303\277/;

   }
 
   }
 

-  $failed=0;
-  return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew';
+  # remove the &#255; (encoded as UTF-8) from quotechars
+  $q -> param ($formdata -> {quoteChar} -> {name}
+        => substr $q -> param ($formdata -> {quoteChar} -> {name}),2);
+
+  # ok, params now should be UTF-8 encoded
+  1;

 }
 
 }
 

-# ====================================================
-# Initialisierung
-# ====================================================
+sub jerk {
+  my $text = $_[1] || 'An error has occurred.';
+  print <<EOF;
+Content-type: text/plain\n\n

 
 

-BEGIN {
-  %subhash = (newThread       => \&new_thread,
-              missingKey      => \&missing_key,
-              unexpectedKey   => \&unexpected_key,
-              unknownEncoding => \&unknown_encoding,
-              tooShort        => \&too_short,
-              tooLong         => \&too_long,
-              wrongMail       => \&wrong_mail,
-              Occupied        => \&occupied,
-              Dupe            => \&dupe_posting,
-              noReply         => \&no_reply,
-              gotReply        => \&got_reply,
-              gotNew          => \&got_new
-              );
-
-  # Die RFC-gerechte URL-Erkennung ist aus dem Forum
-  # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-)
-  my $lowalpha       =  '(?:[a-z])';
-  my $hialpha        =  '(?:[A-Z])';
-  my $alpha          =  "(?:$lowalpha|$hialpha)";
-  my $digit          =  '(?:\d)';
-  my $safe           =  '(?:[$_.+-])';
-  my $hex            =  '(?:[\dA-Fa-f])';
-  my $escape         =  "(?:%$hex$hex)";
-  my $digits         =  '(?:\d+)';
-  my $alphadigit     =  "(?:$alpha|\\d)";
-
-  # URL schemeparts for ip based protocols:
-  my $port           =  "(?:$digits)";
-  my $hostnumber     =  "(?:$digits\\.$digits\\.$digits\\.$digits)";
-  my $toplabel       =  "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
-  my $domainlabel    =  "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
-  my $hostname       =  "(?:(?:$domainlabel\\.)*$toplabel)";
-  my $host           =  "(?:(?:$hostname)|(?:$hostnumber))";
-  my $hostport       =  "(?:(?:$host)(?::$port)?)";
-
-  my $httpuchar      =  "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
-  my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
-  my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
-  my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
-
-  # das alles ergibt eine gueltige URL :-)
-  $httpurl           =  "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$";
+ Oops.
+
+ $text
+ We will fix it as soon as possible. Thank you for your patience.
+
+ Regards
+    n.d.p.
+EOF

 }
 
 }
 

-# ====================================================
-# end of fo_posting.pl
-# ====================================================
\ No newline at end of file
+#
+#
+### end of fo_posting.pl #######################################################
\ No newline at end of file