X-Git-Url: https://git.p6c8.net/selfforum.git/blobdiff_plain/179c09ecd60241b7e77990d7af0fbdfa93bbc7e9..12cb924004788df3066c77db8a723b32235bccf0:/selfforum-cgi/user/fo_posting.pl diff --git a/selfforum-cgi/user/fo_posting.pl b/selfforum-cgi/user/fo_posting.pl index 8c9f8da..3126881 100644 --- a/selfforum-cgi/user/fo_posting.pl +++ b/selfforum-cgi/user/fo_posting.pl @@ -1,63 +1,111 @@ -#!/usr/bin/perl -wT +#!/usr/bin/perl -w ################################################################################ # # # File: user/fo_posting.pl # # # -# Authors: AndrĂ© Malo , 2001-03-31 # +# Authors: AndrĂ© Malo , 2001-04-08 # # # # Description: Accept new postings, display "Neue Nachricht" page # # # -# not ready, be patient please # -# # ################################################################################ use strict; -use vars qw($Bin $Shared $Script); +use vars qw( + $Bin + $Shared + $Script + $Config + $VERSION +); # locate the script +# 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 CGI::Carp qw(fatalsToBrowser); 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 Conf::Admin; +use Posting::Cache; -use CGI; -use XML::DOM; +# Version check +# +$VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # 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}); -# 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 -$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 #################################################################### # -# initialising the Posting::Response object +# initialising the Posting::Request object # check parameters and fill in object properties # sub new { @@ -75,34 +123,557 @@ sub new { show_posting => $sp, assign => $sp -> {assign}, + template => $conf -> {template}, form_must => $sp -> {form} -> {must}, form_data => $sp -> {form} -> {data}, form_action => $sp -> {form} -> {action}, }, - template => new Template $sp -> {templateFile} + template => new Template $sp -> {templateFile}, + response => {}, + forum => {}, + error => {} }; 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} => 'ÿ'.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}} + = 'ÿ'.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) # -# Return: Status Code (Bool) -# try out the error method, if false +# Return: -none- # 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 - 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 ############################################################## @@ -110,28 +681,28 @@ sub parse_cgi { # 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; - # 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 $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 - # (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}} - ) - ) { - $self -> {response} = {new_thread => 1}; + )) { + $self -> {response} -> {new_thread} = 1; + $self -> {check_success} = 1; return 1; } @@ -149,7 +720,11 @@ sub check_cgi { # 1 # - my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata; + my %name = map { + exists($formdata -> {$_} -> {name}) + ? ($formdata -> {$_} -> {name} => $_) + : () + } keys %$formdata; # 2 # @@ -167,27 +742,35 @@ sub check_cgi { # 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 # - push @{$self -> {fetch}} => $name {$_}; + push @{$self -> {fetch}} => $_; } } } + # I'm lazy - I know... + my $q = $self -> {cgi_object}; + # 3 # - for ($self -> {cgi_object} -> param) { + for ($q -> param) { unless (exists ($name {$_})) { $self -> {error} = { spec => 'unexpected_key', - desc => $name{$_} + desc => $name{$_}, + type => 'fatal' }; return; } @@ -196,21 +779,24 @@ sub check_cgi { # 4 # unless ($self -> decode_param) { - $self -> {error} = {spec => 'unknown_encoding'}; + $self -> {error} = { + spec => 'unknown_encoding', + type => 'fatal' + }; return; }; - # I'm lazy - I know... - my $q = $self -> {cgi_object}; - 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; - 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; @@ -220,13 +806,15 @@ sub check_cgi { # 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. # for (keys %got_keys) { + # we are sure, we've got only one value for one key + # my $val = $q -> param ($_); $val =~ s/\302\240/ /g; # convert nbsp (UTF-8 encoded) into normal spaces @@ -243,9 +831,10 @@ sub check_cgi { 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? @@ -257,48 +846,113 @@ sub check_cgi { # (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{$_} + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} }; - return; + $self -> kill_param or return; } } # 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) { $self -> {error} = { spec => 'wrong_mail', - desc => $name{$_} + 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') { $self -> {error} = { spec => 'wrong_http_url', - desc => $name{$_} + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} }; - return; + $self -> kill_param or return; } elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') { $self -> {error} = { spec => 'wrong_url', - desc => $name{$_} + 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; } +### 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 ################################################################## # @@ -323,6 +977,8 @@ sub fetch { $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}}) for (@{$self -> {fetch}}); + + return; } } } @@ -333,6 +989,8 @@ sub fetch { # $q -> param ($formdata -> {$_} -> {name} => '') for (@{$self -> {fetch}}); + + return; } ### sub decode_param ########################################################### @@ -363,12 +1021,30 @@ sub decode_param { } # remove the ÿ (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; } +sub jerk { + my $text = $_[1] || 'An error has occurred.'; + print <