]> 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
-n/a-
[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 e59d2c4340a72081392d51c5608927b4f45d63aa..1fe42a9d8104a3b612c5e1780221cc2e0db8b8d8 100644 (file)
--- a/selfforum-cgi/user/fo_posting.pl
+++ b/selfforum-cgi/user/fo_posting.pl
@@ -1,63 +1,102 @@
-#!/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-30                          #
+# 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
+);
 
 # 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; #$null =~ s/\\/\//g; # for win :-(
+#  $Bin     = ($null =~ /^(.*)\/.*$/)? $1 : '.';
+#  $Config  = "$Bin/../../../cgi-config/devforum";
+#  $Shared  = "$Bin/../../../cgi-shared";
+#  $Script  = ($null =~ /^.*\/(.*)$/)? $1 : $null;
 }
 
 use lib "$Shared";
 }
 
 use lib "$Shared";
-#use CGI::Carp qw(fatalsToBrowser);
+use CGI::Carp qw(fatalsToBrowser);
 
 use Conf;
 
 use Conf;
-use Encode::Plain; $Encode::Plain::utf8 = 1;
-use Encode::Posting;
-use Id;
-use Lock qw(:ALL);
-use CheckRFC;
-use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time parse_xml_file);
-use Posting::Write;
-use Template;
-use Template::Posting;
-
-use CGI;
-use XML::DOM;
+use Conf::Admin;
+use Posting::Cache;
 
 # 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);
+# Initialize the request
+#
+my $request = new Posting::Request ($conf, $adminDefault);
 
 # fetch and parse the cgi-params
 
 # fetch and parse the cgi-params
-$response -> parse_cgi;
+#
+$request -> parse_cgi;
 
 
+# handle errors or save the posting
+#
+$request -> handle_error or $request -> save;
+
+# show response
+#
+$request -> response;
+
+# shorten the main file?
+#
+$request -> severance;
+
+#
+#
+### 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(
+  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 CGI;
 
 ### 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 {
@@ -75,34 +114,557 @@ 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},
        },
 
-       template => new Template $sp -> {templateFile}
+       template => new Template $sp -> {templateFile},
+       response => {},
+       forum    => {},
+       error    => {}
      };
 
   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
+# check on legal reply or dupe is released here
+#
+# Return: -none-
+#
+sub save {
+  my $self = shift;
+
+  # if an empty 'new message' document, there's nothing to save
+  #
+  return if ($self -> {response} -> {new_thread});
+
+  $self -> {check_success} = 0;
+
+  # 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     = {
+          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}) {
+    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};
+
+  return;
+}
+
 ### sub parse_cgi ##############################################################
 #
 # fetch and decode cgi-parameters,
 # find out the kind of response requested by the user (new message, reply)
 #
 ### sub parse_cgi ##############################################################
 #
 # fetch and decode cgi-parameters,
 # find out the kind of response requested by the user (new message, reply)
 #
-# Return: Status Code (Bool)
-#         try out the error method, if false
+# Return: -none-
 #
 sub parse_cgi {
   my $self = shift;
 
   # create the CGI object
 #
 sub parse_cgi {
   my $self = shift;
 
   # create the CGI object
-  my $q = new CGI;
-  $self -> {cgi_object} = $q;
+  #
+  $self -> {cgi_object} = new CGI;
 
   # check the params
 
   # check the params
-  return unless $self -> check_cgi;
+  #
+  $self -> {check_success} = $self -> check_cgi;
+
+  return;
+}
+
+### sub load_main_file #########################################################
+#
+# 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) {
+      # 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);
+  }
+
+  # ok, looks good
+  1;
+}
+
+### sub check_reply_dupe #######################################################
+#
+# 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)
+#
+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;
+    }
+
+    # 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++) {
+
+      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 ##############################################################
@@ -110,32 +672,31 @@ sub parse_cgi {
 # cgi params are like raw eggs...
 #
 # Return: Status Code (Bool)
 # cgi params are like raw eggs...
 #
 # Return: Status Code (Bool)
-#         creates content for the error method if anything fails
+#         creates content for the handle_error method if anything fails
 #
 sub check_cgi {
   my $self = shift;
 
 #
 sub check_cgi {
   my $self = shift;
 
-  # find out the count of the submitted keys and the keys themselves
+  # 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 %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;
   }
 
-  ###################################################
   # now we know, we've got a filled out form
   # we do the following steps to check it:
   #
   # now we know, we've got a filled out form
   # we do the following steps to check it:
   #
@@ -143,14 +704,18 @@ sub check_cgi {
   # 2nd: did we get _all_ must-keys?
   #      check whether reply or new message request
   # 3rd: did we get too many keys?
   # 2nd: did we get _all_ must-keys?
   #      check whether reply or new message request
   # 3rd: did we get too many keys?
-  # 4th: do _all_ requested values accord to
-  #      expectations?
+  # 4th: do _all_ submitted values accord to
+  #      our expectations?
   #      fetch the "missing" keys
   #
 
   # 1
   #
   #      fetch the "missing" keys
   #
 
   # 1
   #
-  my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
+  my %name = map {
+    exists($formdata -> {$_} -> {name})
+    ? ($formdata -> {$_} -> {name} => $_)
+    : ()
+  } keys %$formdata;
 
   # 2
   #
 
   # 2
   #
@@ -168,27 +733,35 @@ 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;
       }
       else {
         # keep in mind to fetch the value later
         #
         return;
       }
       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',
-        desc => $name{$_}
+        desc => $name{$_},
+        type => 'fatal'
       };
       return;
     }
       };
       return;
     }
@@ -197,39 +770,51 @@ sub check_cgi {
   # 4
   #
   unless ($self -> decode_param) {
   # 4
   #
   unless ($self -> decode_param) {
-    $self -> {error} = {spec => 'unknown_encoding'};
+    $self -> {error} = {
+      spec => 'unknown_encoding',
+      type => 'fatal'
+    };
     return;
   };
 
     return;
   };
 
-  # I'm lazy - I know...
-  my $q = $self -> {cgi_object};
-
   if ($self -> {response} -> {reply}) {
 
   if ($self -> {response} -> {reply}) {
 
-    # get the parent-identifiers if we got a reply
+    # get the parent-identifiers if we got a reply request
     #
     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 
     #
     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 
-    unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
-      $self -> {error} = {spec => 'unknown_followup'};
+    unless ($ftid =~ /^\d+$/ and $fmid =~ /^\d+$/) {
+      $self -> {error} = {
+        spec => 'unknown_followup',
+        type => 'fatal'
+      };
       return;
     }
     $self -> {fup_tid} = $ftid;
     $self -> {fup_mid} = $fmid;
 
       return;
     }
     $self -> {fup_tid} = $ftid;
     $self -> {fup_mid} = $fmid;
 
-    # now fetching the missing keys
+    # fetch the missing keys
     # if it fails, they're too short, too... ;)
     #
     $self -> fetch;
     # if it fails, they're too short, too... ;)
     #
     $self -> fetch;
+    $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}});
   }
 
   # now we can check on length, type etc.
   #
   for (keys %got_keys) {
 
   }
 
   # 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 ($_);
 
     my $val = $q -> param ($_);
 
-    $val =~ s/\302\240/ /g;    # convert nbsp to normal spaces
+    $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?
     $q -> param ($_ => $val);  # write it back
 
     # too long?
@@ -237,9 +822,10 @@ sub check_cgi {
     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
       $self -> {error} = {
         spec => 'too_long',
     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
       $self -> {error} = {
         spec => 'too_long',
-        desc => $name{$_}
+        desc => $name{$_},
+        type => $formdata -> {$name {$_}} -> {errorType}
       };
       };
-      return;
+      $self -> kill_param or return;
     }
 
     # too short?
     }
 
     # too short?
@@ -251,27 +837,93 @@ sub check_cgi {
       #
       (my $val_ww = $val) =~ s/\s+//g;
 
       #
       (my $val_ww = $val) =~ s/\s+//g;
 
+      $val_ww =~ y/a-zA-Z//cd
+        if (exists ($formdata -> {$name {$_}} -> {type}) and $formdata -> {$name {$_}} -> {type} eq 'name');
+
       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
         $self -> {error} = {
           spec => 'too_short',
       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
         $self -> {error} = {
           spec => 'too_short',
-          desc => $name{$_}
+          desc => $name{$_},
+          type => $formdata -> {$name {$_}} -> {errorType}
         };
         };
-        return;
+        $self -> kill_param or return;
+      }
+    }
+
+    # 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;
+      }
+
+      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;
       }
     }
 
       }
     }
 
-#    return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
+    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;
 }
-
-#  delete $dparam {$formdata -> {posterURL} -> {name}}
-#    unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
+### sub kill_param #############################################################
 #
 #
-#  delete $dparam {$formdata -> {posterImage} -> {name}}
-#    unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
+# 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 ##################################################################
 #
@@ -296,6 +948,8 @@ sub fetch {
 
           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
             for (@{$self -> {fetch}});
 
           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
             for (@{$self -> {fetch}});
+
+          return;
         }
       }
     }
         }
       }
     }
@@ -306,6 +960,8 @@ sub fetch {
   #
   $q -> param ($formdata -> {$_} -> {name} => '')
     for (@{$self -> {fetch}});
   #
   $q -> param ($formdata -> {$_} -> {name} => '')
     for (@{$self -> {fetch}});
+
+  return;
 }
 
 ### sub decode_param ###########################################################
 }
 
 ### sub decode_param ###########################################################
@@ -336,12 +992,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