]> 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
now severancer will be splittet from cgi application, fo_posting.pl uses now Arc...
[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 41099deef32aa1fe2f146c48d2508cc03125f06f..5046a5c3a68560fd8548da635378e88a69dde07f 100644 (file)
--- a/selfforum-cgi/user/fo_posting.pl
+++ b/selfforum-cgi/user/fo_posting.pl
@@ -1,42 +1,58 @@
-#!/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});
 
 # Initialize the request
 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
 
 # Initialize the request
@@ -55,6 +71,10 @@ $request -> handle_error or $request -> save;
 #
 $request -> response;
 
 #
 $request -> response;
 
+# shorten the main file?
+#
+$request -> severance;
+
 #
 #
 ### main end ###################################################################
 #
 #
 ### main end ###################################################################
@@ -63,15 +83,24 @@ $request -> response;
 ### Posting::Request ###########################################################
 package Posting::Request;
 
 ### Posting::Request ###########################################################
 package Posting::Request;
 
-use Lock          qw(:ALL);
+use Arc::Starter;
+use CheckRFC;
+use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
+use Encode::Posting;
+use Lock;
 use Posting::_lib qw(
 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;
 
 ### sub new ####################################################################
 use CGI;
 
 ### sub new ####################################################################
@@ -94,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},
@@ -108,6 +138,226 @@ sub new {
   bless $self, $class;
 }
 
   bless $self, $class;
 }
 
+sub severance {
+  my $self = shift;
+
+  start_severance ($self -> {conf} -> {original} -> {files} -> {sev_app});
+}
+
+### 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
@@ -122,6 +372,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) {
@@ -131,34 +383,124 @@ sub save {
     #
     if ($self -> check_reply_dupe) {
 
     #
     if ($self -> check_reply_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;
-      }
-
-      # 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});
+    $self -> {forum} -> {flocked} -> unlock;
     $self -> {forum} -> {flocked} = 0;
   }
 
     $self -> {forum} -> {flocked} = 0;
   }
 
@@ -179,8 +521,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
   #
@@ -197,16 +538,15 @@ sub parse_cgi {
 #
 sub load_main_file {
   my $self = shift;
 #
 sub load_main_file {
   my $self = shift;
-  my $lock_stat;
+  my $forum = new Lock ($self -> {conf} -> {forum_file_name});
 
 
-  unless ($lock_stat = write_lock_file ($self ->{forum_file_name})) {
-    if ($lock_stat == 0) {
+  unless ($forum -> lock(LH_EXCL)) {
+    unless ($forum -> masterlocked) {
       # 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});
       $self -> {error} = {
         spec => 'occupied',
       $self -> {error} = {
         spec => 'occupied',
-        type => 'fatal'
+        type => 'repeat'
       };
       return;
     }
       };
       return;
     }
@@ -221,13 +561,13 @@ sub load_main_file {
     }
   }
   else {
     }
   }
   else {
-    $self -> {forum} -> {flocked} = 1;
+    $self -> {forum} -> {flocked} = $forum;
     ( $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
   }
 
   # ok, looks good
@@ -246,19 +586,19 @@ sub load_main_file {
 #
 sub check_reply_dupe {
   my $self = shift;
 #
 sub check_reply_dupe {
   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}
-    and $self -> {response} -> {new}
+    or $self -> {response} -> {new}
   );
 
   );
 
-  my %unids;
-
   if ($self -> {response} -> {reply}) {
 
   if ($self -> {response} -> {reply}) {
 
-    my ($threads, $ftid, $fmid, $i, %msg, %unids) = (
+    my ($threads, $ftid, $fmid, $i, %msg) = (
           $self -> {forum} -> {threads},
           $self -> {fup_tid},
           $self -> {fup_mid}
           $self -> {forum} -> {threads},
           $self -> {fup_tid},
           $self -> {fup_mid}
@@ -307,7 +647,7 @@ sub check_reply_dupe {
     # build a unique id lookup hash, too
     # but use only the level-zero-messages
     #
     # build a unique id lookup hash, too
     # but use only the level-zero-messages
     #
-    %unids = map {$_ => 1} @{$self -> {unids}};
+    %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
   }
 
   # now check on dupe
   }
 
   # now check on dupe
@@ -370,7 +710,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
   #
@@ -388,11 +732,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;
@@ -400,14 +745,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',
@@ -428,16 +776,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'
@@ -451,7 +796,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.
@@ -479,7 +824,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?
@@ -491,18 +836,42 @@ 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;
+#        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) {
@@ -511,7 +880,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') {
@@ -520,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 'url' and not is_URL $val => ':ALL') {
       }
 
       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
@@ -529,14 +898,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 ##################################################################
 #
@@ -548,11 +955,11 @@ sub fetch {
   my $formdata = $self -> {conf} -> {form_data};
 
   if (@{$self -> {fetch}}) {
   my $formdata = $self -> {conf} -> {form_data};
 
   if (@{$self -> {fetch}}) {
-    my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
+    my $thread = new Lock ($self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml');
 
 
-    if (lock_file ($filename)) {
-      my $xml = parse_xml_file ($filename);
-      violent_unlock_file($filename) unless unlock_file ($filename);
+    if ($thread -> lock (LH_SHARED)) {
+      my $xml = parse_xml_file ($thread -> filename);
+      $thread -> unlock;
 
       if ($xml) {
         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 
       if ($xml) {
         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
@@ -605,12 +1012,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