]> git.p6c8.net - selfforum.git/blobdiff - selfforum-cgi/user/fo_posting.pl
git.p6c8.net / selfforum.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
added error message for xml-parse-error.
[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 472eaab420cced7af0f1a4ce1ff80cf3d55250f2..3126881d08c028735100323aca7d2b1697a4c373 100644 (file)
--- a/selfforum-cgi/user/fo_posting.pl
+++ b/selfforum-cgi/user/fo_posting.pl
@@ -1,95 +1,111 @@
-#!/usr/bin/perl -wT
+#!/usr/bin/perl -w
 
 ################################################################################
 #                                                                              #
 # File:        user/fo_posting.pl                                              #
 #                                                                              #
 
 ################################################################################
 #                                                                              #
 # File:        user/fo_posting.pl                                              #
 #                                                                              #
-# Authors:     André Malo <nd@o3media.de>, 2001-03-31                          #
+# Authors:     André Malo <nd@o3media.de>, 2001-04-08                          #
 #                                                                              #
 # Description: Accept new postings, display "Neue Nachricht" page              #
 #                                                                              #
 #                                                                              #
 # Description: Accept new postings, display "Neue Nachricht" page              #
 #                                                                              #
-# not ready, be patient please                                                 #
-#                                                                              #
 ################################################################################
 
 use strict;
 ################################################################################
 
 use strict;
-use vars qw($Bin $Shared $Script);
+use vars qw(
+  $Bin
+  $Shared
+  $Script
+  $Config
+  $VERSION
+);
 
 # locate the script
 
 # locate the script
+#
 BEGIN {
   my $null = $0; $null =~ s/\\/\//g; # for win :-(
 BEGIN {
   my $null = $0; $null =~ s/\\/\//g; # for win :-(
-  ($Bin)    = ($null =~ /^(.*)\/.*$/)? $1 : '.';
-  $Shared   = "$Bin/../shared";
-  ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null;
+  $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
+  $Shared  = "$Bin/../shared";
+  $Config  = "$Bin/config";
+  $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
+
+#  my $null = $0;
+#  $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
+#  $Config  = "$Bin/../../daten/forum/config";
+#  $Shared  = "$Bin/../../cgi-shared";
+#  $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
 }
 
 }
 
+# setting umask, remove or comment it, if you don't need
+#
+umask 006;
+
 use lib "$Shared";
 use CGI::Carp qw(fatalsToBrowser);
 
 use lib "$Shared";
 use CGI::Carp qw(fatalsToBrowser);
 
-#use Conf;
-#use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
-#use Id;
-#use Posting::Write;
-#use Template;
-#use Template::Posting;
+use Conf;
+use Conf::Admin;
+use Posting::Cache;
 
 
-#use autouse 'Encode::Posting' => qw();
+# Version check
+#
+$VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
 
 # load script configuration and admin default conf.
 
 # load script configuration and admin default conf.
-my $conf         = read_script_conf ($Bin, $Shared, $Script);
+#
+my $conf         = read_script_conf ($Config, $Shared, $Script);
 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
 
 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
 
-# Initializing the request
-my $response = new Posting::Response ($conf, $adminDefault);
-
-# fetch and parse the cgi-params
+# Initialize the request
 #
 #
-$response -> parse_cgi;
+my $request = new Posting::Request ($conf, $adminDefault);
 
 
-# no further checks after fatal errors
+# fetch and parse the cgi-params
 #
 #
-if ($response -> success or $response -> error_type ne 'fatal') {
-  $response -> success (
-       $response -> check_reply
-    && $response -> check_dupe
-    && $response -> success
-  );
-}
-
+$request -> parse_cgi;
 
 # handle errors or save the posting
 #
 
 # handle errors or save the posting
 #
-$response -> handle_error or $response -> save;
+$request -> handle_error or $request -> save;
 
 # show response
 #
 
 # show response
 #
-$response -> response;
+$request -> response;
+
+# shorten the main file?
+#
+$request -> severance;
 
 #
 #
 ### main end ###################################################################
 
 ################################################################################
 
 #
 #
 ### main end ###################################################################
 
 ################################################################################
-### Posting::Response ##########################################################
-package Posting::Response;
+### Posting::Request ###########################################################
+package Posting::Request;
 
 
+use Arc::Archive;
+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(
 use Lock          qw(:ALL);
 use Posting::_lib qw(
-      hr_time
-      parse_xml_file
-      get_all_threads get_message_node get_message_header
-      KEEP_DELETED
-    );
+  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;
 
 
-use autouse 'CheckRFC' => qw(is_email is_URL);
 use CGI;
 
 use CGI;
 
-sub success {$_[0] -> {check_success} = defined $_[1]?$_[1]:$_[0] -> {check_success}}
-sub error_type {$_[0] -> {error} -> {type}}
-
 ### sub new ####################################################################
 #
 ### sub new ####################################################################
 #
-# initialising the Posting::Response object
+# initialising the Posting::Request object
 # check parameters and fill in object properties
 #
 sub new {
 # check parameters and fill in object properties
 #
 sub new {
@@ -107,6 +123,7 @@ sub new {
 
          show_posting    => $sp,
          assign          => $sp -> {assign},
 
          show_posting    => $sp,
          assign          => $sp -> {assign},
+         template        => $conf -> {template},
          form_must       => $sp -> {form} -> {must},
          form_data       => $sp -> {form} -> {data},
          form_action     => $sp -> {form} -> {action},
          form_must       => $sp -> {form} -> {must},
          form_data       => $sp -> {form} -> {data},
          form_action     => $sp -> {form} -> {action},
@@ -121,6 +138,235 @@ sub new {
   bless $self, $class;
 }
 
   bless $self, $class;
 }
 
+sub severance {
+  my $self = shift;
+
+  my $stat = cut_tail ({
+    forumFile    => $self -> {conf} -> {forum_file_name},
+    messagePath  => $self -> {conf} -> {message_path},
+    archivePath  => $self -> {conf} -> {original} -> {files} -> {archivePath},
+    lockFile     => $self -> {conf} -> {original} -> {files} -> {sev_lock},
+    adminDefault => $self -> {conf} -> {admin},
+    cachePath    => $self -> {conf} -> {original} -> {files} -> {cachePath}
+  });
+#  die $stat->{(keys %$stat)[0]} if (%$stat);
+
+}
+
+### sub response ###############################################################
+#
+# print the response to STDOUT
+#
+# Return: -none-
+#
+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})
+    );
+  }
+
+  # response the 'new message' page
+  #
+  if ($self -> {response} -> {new_thread}) {
+
+    # fill in the default form data
+    # and optionlist(s)
+    #
+    my $default = {};
+    for (keys %$formdata) {
+      unless (exists ($formdata -> {$_} -> {type}) and $formdata -> {$_} -> {type} eq 'internal') {
+        if (exists ($formdata -> {$_} -> {default}) and exists ($formdata -> {$_} -> {assign} -> {value})) {
+          $default -> {$formdata -> {$_} -> {assign} -> {value}}
+          = $formdata -> {$_} -> {default};
+        }
+        elsif (exists($formdata -> {$_} -> {values})) {
+          my ($_name, $val) = $_;
+          $val = exists ($formdata -> {$_} -> {default})
+            ? $formdata -> {$_} -> {default}
+            : undef;
+          $default -> {$formdata -> {$_} -> {assign} -> {value}}
+          = $self -> {template} -> list (
+              $assign -> {option},
+              [ map {
+                  { $assign -> {optval} => plain($_),
+                    ((defined $val and $_ eq $val)
+                      ? ($assign -> {optsel} => 1)
+                      : ()
+                    )
+                  }
+                } @{$formdata -> {$_name} -> {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}),
+        $formact->{post}->{assign}                     => $formact->{post}->{url},
+      },
+      $pars,
+      $default
+    )};
+    return;
+  }
+
+  # check the response -> doc
+  #
+  unless ($self -> {response} -> {doc}) {
+    $self -> {error} = {
+      spec => 'unknown_error',
+      type => 'fatal'
+    };
+
+    $self -> handle_error;
+
+    unless ($self -> {response} -> {doc}) {
+      $self -> jerk ('While producing the HTML response an unknown error has occurred.');
+      return;
+    }
+  }
+
+  # ok, print the response document to STDOUT
+  #
+  print $q -> header (-type => 'text/html');
+  print ${$template -> scrap (
+      $self -> {response} -> {doc},
+      $pars,
+      $self -> {response} -> {pars}
+    )
+  };
+
+  return;
+}
+
+### 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;
+
+  my $spec = $self -> {error} -> {spec};
+
+  return unless ($spec);
+
+  my $assign   = $self -> {conf} -> {assign};
+  my $formdata = $self -> {conf} -> {form_data};
+
+  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 {
+    $emsg = $assign -> {$spec} || '';
+  }
+
+  # fatal errors
+  #
+  if ($type eq 'fatal') {
+    $self -> {response} -> {doc}  = $assign -> {docFatal};
+    $self -> {response} -> {pars} = {
+      $assign -> {errorMessage} => $self -> {template} -> insert ($emsg)
+    };
+  }
+
+  # '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 fillout_form ###########################################################
+#
+# fill out the form using available form data
+#
+# Return: -none-
+#
+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};
+
+  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}}
+            ]
+          );
+      }
+    }
+  }
+
+  $self -> {response} -> {pars} = $pars;
+  return;
+}
+
 ### sub save ###################################################################
 #
 # save posting
 ### sub save ###################################################################
 #
 # save posting
@@ -135,6 +381,8 @@ sub save {
   #
   return if ($self -> {response} -> {new_thread});
 
   #
   return if ($self -> {response} -> {new_thread});
 
+  $self -> {check_success} = 0;
+
   # lock and load the forum main file
   #
   if ($self -> load_main_file) {
   # lock and load the forum main file
   #
   if ($self -> load_main_file) {
@@ -142,36 +390,126 @@ sub save {
     # if a reply - is it legal?
     # is it a dupe?
     #
     # if a reply - is it legal?
     # is it a dupe?
     #
-    if ($self -> check_reply and $self -> check_dupe) {
-
-      # we've got an opening
-      #
-      if ($self -> {response} -> {new}) {
-        $self -> save_new;
-      }
-
-      # we've got a reply
-      #
-      elsif ($self -> {response} -> {reply}) {
-        $self -> save_reply;
-      }
+    if ($self -> check_reply_dupe) {
 
 
-      # don't know, if we any time come to this branch
-      # the script is probably broken
-      #
-      else {
+      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'
         };
       }
         $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     = {
+          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 -> {conf} -> {template} -> {messages} || {},
+          base_uri      => $self -> {conf} -> {original} -> {files} -> {forum_base}
+        };
+
+        # set the variables if defined..
+        #
+        my %may = (
+          author   => 'posterName',
+          email    => 'posterEmail',
+          category => 'posterCategory',
+          subject  => 'posterSubject',
+          body     => 'posterBody',
+          homepage => 'posterURL',
+          image    => 'posterImage'
+        );
+
+        for (keys %may) {
+          $pars -> {$_} = $q -> param ($formdata -> {$may{$_}} -> {name})
+            if (defined $q -> param ($formdata -> {$may{$_}} -> {name}));
+        }
+
+        my ($stat, $xml, $mid, $tid);
+
+        # we've got a fup if it's a reply
+        #
+        if ($self -> {response} -> {reply}) {
+          $pars -> {parentMessage} = $self -> {fup_mid};
+          $pars -> {thread}        = $self -> {fup_tid};
+          ($stat, $xml, $mid, $tid) = write_reply_posting ($pars);
+        }
+        else {
+          ($stat, $xml, $mid, $tid) = write_new_thread ($pars);
+        }
+
+        if ($stat) {
+          $self -> {error} = {
+            spec => 'not_saved',
+            desc => $stat,
+            type => 'fatal'
+          };
+        }
+        else {
+          my $cache = new Posting::Cache ($self->{conf}->{original}->{files}->{cachePath});
+          $cache -> add_posting (
+            { thread  => ($tid =~ /(\d+)/)[0],
+              posting => ($mid =~ /(\d+)/)[0]
+            }
+          );
+
+          $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 -> {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}
+              }) || ''
+          };
+
+          # set the variables if defined..
+          #
+          my %may = (
+            author   => 'posterName',
+            email    => 'posterEmail',
+            category => 'posterCategory',
+            subject  => 'posterSubject',
+            homepage => 'posterURL',
+            image    => 'posterImage'
+          );
+
+          for (keys %may) {
+            my $x = $q -> param ($formdata -> {$may{$_}} -> {name});
+            $x = '' unless (defined $x);
+            $self -> {response} -> {pars} -> {$thx -> {$_}} = plain ($x)
+              if (defined $thx -> {$_});
+          }
+        }
+      }
     }
   }
 
   # unlock forum main file
   #
   if ($self -> {forum} -> {flocked}) {
     }
   }
 
   # unlock forum main file
   #
   if ($self -> {forum} -> {flocked}) {
-    violent_unlock_file($self -> {forum_file_name}) unless unlock_file ($self -> {forum_file_name});
+    violent_unlock_file($self -> {conf} -> {forum_file_name}) unless write_unlock_file ($self -> {conf} -> {forum_file_name});
     $self -> {forum} -> {flocked} = 0;
   }
 
     $self -> {forum} -> {flocked} = 0;
   }
 
@@ -192,8 +530,7 @@ sub parse_cgi {
 
   # create the CGI object
   #
 
   # create the CGI object
   #
-  my $q = new CGI;
-  $self -> {cgi_object} = $q;
+  $self -> {cgi_object} = new CGI;
 
   # check the params
   #
 
   # check the params
   #
@@ -212,14 +549,14 @@ sub load_main_file {
   my $self = shift;
   my $lock_stat;
 
   my $self = shift;
   my $lock_stat;
 
-  unless ($lock_stat = write_lock_file ($self ->{forum_file_name})) {
-    if ($lock_stat == 0) {
+  unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
+    if (defined $lock_stat) {
       # occupied or no w-bit set for the directory..., hmmm
       #
       # occupied or no w-bit set for the directory..., hmmm
       #
-      violent_unlock_file ($self -> {forum_file_name});
+      violent_unlock_file ($self -> {conf} -> {forum_file_name});
       $self -> {error} = {
         spec => 'occupied',
       $self -> {error} = {
         spec => 'occupied',
-        type => 'fatal'
+        type => 'repeat'
       };
       return;
     }
       };
       return;
     }
@@ -238,43 +575,105 @@ sub load_main_file {
     ( $self -> {forum} -> {threads},
       $self -> {forum} -> {last_thread},
       $self -> {forum} -> {last_message},
     ( $self -> {forum} -> {threads},
       $self -> {forum} -> {last_thread},
       $self -> {forum} -> {last_message},
-      undef,
+      $self -> {forum} -> {dtd},
       $self -> {forum} -> {unids}
       $self -> {forum} -> {unids}
-    ) = get_all_threads ($self -> {forum_file_name}, KEEP_DELETED);
+    ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
   }
 
   # ok, looks good
   1;
 }
 
   }
 
   # ok, looks good
   1;
 }
 
-### sub check_reply ############################################################
+### sub check_reply_dupe #######################################################
 #
 # check whether a reply is legal
 # (followup posting must exists)
 #
 #
 # check whether a reply is legal
 # (followup posting must exists)
 #
+# check whether this form request is a dupe
+# (unique id already exists)
+#
 # Return: Status Code (Bool)
 #
 # Return: Status Code (Bool)
 #
-sub check_reply {
+sub check_reply_dupe {
   my $self = shift;
   my $self = shift;
+  my %unids;
 
   # return true unless it's not a reply
 
   # return true unless it's not a reply
+  # or an opening
   #
   #
-  return 1 unless $self -> {response} -> {reply};
+  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}
+       );
 
 
-### sub check_dupe #############################################################
-#
-# check whether this form request is a dupe
-# (unique id already exists)
-#
-# Return: Status Code (Bool)
-#
-sub check_dupe {
-  my $self = shift;
+    # thread doesn't exist
+    #
+    unless (exists($threads -> {$ftid})) {
+      $self -> {error} = {
+        spec => 'no_reply',
+        type => 'fatal'
+      };
+      return;
+    }
+
+    # 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++) {
 
 
-  return 1 if ($self -> {response} -> {new_thread});
+      if ($threads -> {$ftid} -> [$i] -> {deleted}) {
+        $i+=$threads -> {$ftid} -> [$i] -> {answers};
+      }
+      else {
+        $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
+      }
+    }
+
+    # 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}};
+  }
+
+  # now check on dupe
+  #
+  if (exists ($unids{
+                $self -> {cgi_object} -> param (
+                  $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
+    $self -> {error} = {
+      spec => 'dupe',
+      type => 'fatal'
+    };
+    return;
+  }
+
+  # ok, looks fine
+  1;
 }
 
 ### sub check_cgi ##############################################################
 }
 
 ### sub check_cgi ##############################################################
@@ -291,19 +690,19 @@ sub check_cgi {
   #
   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
   my $cnt_got_keys = keys %got_keys;
   #
   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 $formdata     = $self -> {conf} -> {form_data};
+  my $formmust     = $self -> {conf} -> {form_must};
 
   # user requested the 'new thread' page
 
   # user requested the 'new thread' page
-  # (no params or only the user-ID has been submitted)
+  # (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}}
   #
   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 -> {response} -> {new_thread} = 1;
+    $self -> {check_success} = 1;
     return 1;
   }
 
     return 1;
   }
 
@@ -321,7 +720,11 @@ sub check_cgi {
 
   # 1
   #
 
   # 1
   #
-  my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
+  my %name = map {
+    exists($formdata -> {$_} -> {name})
+    ? ($formdata -> {$_} -> {name} => $_)
+    : ()
+  } keys %$formdata;
 
   # 2
   #
 
   # 2
   #
@@ -339,11 +742,12 @@ sub check_cgi {
       # only miss the key unless we're able to fetch it from parent posting
       #
       unless (
       # only miss the key unless we're able to fetch it from parent posting
       #
       unless (
-           $self -> {response} -> {new}
-        or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') {
+        not $self -> {response} -> {reply}
+        or $formdata -> {$_} -> {errorType} eq 'fetch') {
 
         $self -> {error} = {
           spec => 'missing_key',
 
         $self -> {error} = {
           spec => 'missing_key',
+          desc => $_,
           type => 'fatal'
         };
         return;
           type => 'fatal'
         };
         return;
@@ -351,14 +755,17 @@ sub check_cgi {
       else {
         # keep in mind to fetch the value later
         #
       else {
         # keep in mind to fetch the value later
         #
-        push @{$self -> {fetch}} => $name {$_};
+        push @{$self -> {fetch}} => $_;
       }
     }
   }
 
       }
     }
   }
 
+  # I'm lazy - I know...
+  my $q = $self -> {cgi_object};
+
   # 3
   #
   # 3
   #
-  for ($self -> {cgi_object} -> param) {
+  for ($q -> param) {
     unless (exists ($name {$_})) {
       $self -> {error} = {
         spec => 'unexpected_key',
     unless (exists ($name {$_})) {
       $self -> {error} = {
         spec => 'unexpected_key',
@@ -379,16 +786,13 @@ sub check_cgi {
     return;
   };
 
     return;
   };
 
-  # I'm lazy - I know...
-  my $q = $self -> {cgi_object};
-
   if ($self -> {response} -> {reply}) {
 
     # get the parent-identifiers if we got a reply request
     #
     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 
   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+/) {
+    unless ($ftid =~ /^\d+$/ and $fmid =~ /^\d+$/) {
       $self -> {error} = {
         spec => 'unknown_followup',
         type => 'fatal'
       $self -> {error} = {
         spec => 'unknown_followup',
         type => 'fatal'
@@ -402,7 +806,7 @@ sub check_cgi {
     # if it fails, they're too short, too... ;)
     #
     $self -> fetch;
     # if it fails, they're too short, too... ;)
     #
     $self -> fetch;
-    $got_keys{$_}=1 for (@{$self -> {fetch}});
+    $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
   }
 
   # now we can check on length, type etc.
   }
 
   # now we can check on length, type etc.
@@ -430,7 +834,7 @@ sub check_cgi {
         desc => $name{$_},
         type => $formdata -> {$name {$_}} -> {errorType}
       };
         desc => $name{$_},
         type => $formdata -> {$name {$_}} -> {errorType}
       };
-      return;
+      $self -> kill_param or return;
     }
 
     # too short?
     }
 
     # too short?
@@ -442,18 +846,41 @@ sub check_cgi {
       #
       (my $val_ww = $val) =~ s/\s+//g;
 
       #
       (my $val_ww = $val) =~ s/\s+//g;
 
+      if (exists ($formdata -> {$name {$_}} -> {type}) and $formdata -> {$name {$_}} -> {type} eq 'name') {
+        $val_ww =~ y/a-zA-Z//cd;
+
+        my @badlist = map {qr/\Q$_/i} qw (
+          # insert badmatchlist here
+        );
+
+        push @badlist => map {qr/\b\Q$_\E\b/i} qw(
+          # insert badwordlist here
+        );
+
+        for (@badlist) {
+          if ($val_ww =~ /$_/) {
+            $self -> {error} = {
+              spec => 'undesired',
+              desc => $name{$_},
+              type => 'fatal'
+            };
+            return;
+          }
+        }
+      }
+
       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
         $self -> {error} = {
           spec => 'too_short',
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
         $self -> {error} = {
           spec => 'too_short',
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
-        return;
+        $self -> kill_param or return;
       }
     }
 
     # check the values on expected kinds of content
       }
     }
 
     # check the values on expected kinds of content
-    # (email, http-url, url)
+    # (email, http-url, url, option)
     #
     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
     #
     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
@@ -462,7 +889,7 @@ sub check_cgi {
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
-        return;
+        $self -> kill_param or return;
       }
 
       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
       }
 
       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
@@ -471,7 +898,7 @@ sub check_cgi {
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
-        return;
+        $self -> kill_param or return;
       }
 
       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
       }
 
       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
@@ -480,14 +907,52 @@ sub check_cgi {
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
           desc => $name{$_},
           type => $formdata -> {$name {$_}} -> {errorType}
         };
-        return;
+        $self -> kill_param or return;
+      }
+
+      elsif ($formdata -> {$name {$_}} -> {type} eq 'unique-id' and not may_id $val) {
+        $self -> {error} = {
+          spec => 'wrong_unique_id',
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
+        };
+          print STDERR "Manipuliert!";
+        $self -> kill_param or return;
       }
     }
       }
     }
+
+    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;
+    }
   }
 
   # ok, looks good.
   1;
 }
   }
 
   # ok, looks good.
   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 fetch ##################################################################
 #
 
 ### sub fetch ##################################################################
 #
@@ -556,12 +1021,30 @@ sub decode_param {
   }
 
   # remove the &#255; (encoded as UTF-8) from quotechars
   }
 
   # remove the &#255; (encoded as UTF-8) from quotechars
-  $q -> param ($formdata -> {quoteChar} -> {name} => substr ($code, 2));
+  $q -> param ($formdata -> {quoteChar} -> {name}
+        => substr $q -> param ($formdata -> {quoteChar} -> {name}),2);
 
   # ok, params now should be UTF-8 encoded
   1;
 }
 
 
   # ok, params now should be UTF-8 encoded
   1;
 }
 
+sub jerk {
+  my $text = $_[1] || 'An error has occurred.';
+  print <<EOF;
+Content-type: text/plain
+
+
+
+ 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
Converted CVS repository of SELF's XML based forum

patrick-canterino.de