X-Git-Url: https://git.p6c8.net/selfforum.git/blobdiff_plain/b2f1ca8d9367d38b919afebbdc2e1b7002dc2563..a466ec6b00525ca85c6a8c40e5497f567cfa1f77:/selfforum-cgi/user/fo_posting.pl diff --git a/selfforum-cgi/user/fo_posting.pl b/selfforum-cgi/user/fo_posting.pl index 89e0e24..defbbf0 100644 --- a/selfforum-cgi/user/fo_posting.pl +++ b/selfforum-cgi/user/fo_posting.pl @@ -1,529 +1,1048 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w ################################################################################ # # # File: user/fo_posting.pl # # # -# Authors: André Malo , 2001-01-25 # +# Authors: André Malo # # # # Description: Accept new postings, display "Neue Nachricht" page # # # ################################################################################ use strict; -use vars qw($Bin $Shared $Script %subhash $httpurl $flocked); - +use vars qw( + $Bin + $Shared + $Script + $Config +); + +# locate the script +# BEGIN { - ($Bin) = ($0 =~ /^(.*)\/.*$/)? $1 : '.'; - $Shared = "$Bin/../shared"; - ($Script) = ($0 =~ /^.*\/(.*)$/)? $1 : $0;} + my $null = $0; $null =~ s/\\/\//g; # for win :-( + $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; +} -use CGI::Carp qw(fatalsToBrowser); +# setting umask, remove or comment it, if you don't need +# +umask 006; use lib "$Shared"; +use CGI::Carp qw(fatalsToBrowser); + use Conf; -use Encode::Plain; $Encode::Plain::utf8 = 1; -use Encode::Posting; -use Id; -use Lock qw(:ALL); -use Mail; -use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time); -use Posting::Write; -use Template; -use Template::Posting; +use Conf::Admin; +use Posting::Cache; -use CGI qw(param header); -use XML::DOM; +################################################################################ +# +# Version check +# +# last modified: +# $Date$ (GMT) +# by $Author$ +# +sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'} -print header (-type => 'text/html'); +# load script configuration and admin default conf. +# +my $conf = read_script_conf ($Config, $Shared, $Script); +my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault}); -our $conf = read_script_conf ($Bin, $Shared, $Script); +# Initialize the request +# +my $request = new Posting::Request ($conf, $adminDefault); -our $show_posting = $conf -> {show} -> {Posting}; -our $assign = $show_posting -> {assign}; -our $formmust = $show_posting -> {form} -> {must}; -our $formdata = $show_posting -> {form} -> {data}; -our $formact = $show_posting -> {form} -> {action}; -our $template = new Template $show_posting -> {templateFile}; -our $pars = {}; -our ($failed, %dparam, $threads, $last_thread, $last_message, $ftid, $fmid, $flocked); +# fetch and parse the cgi-params +# +$request -> parse_cgi; -sub forum_filename () {$conf -> {files} -> {forum};} -sub message_path () {$conf -> {files} -> {messagePath};} +# handle errors or save the posting +# +$request -> handle_error or $request -> save; -################################ +# show response +# +$request -> response; -# Formfelder ausfuellen (Namen) -for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) { - $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});} +# shorten the main file? +# +$request -> severance; -my $checked = &check_param; +# +# +### main end ################################################################### -unless (exists ($subhash {$checked})) { - &print_fatal ($assign -> {unknownError});} +################################################################################ +### Posting::Request ########################################################### +package Posting::Request; -else { - unless ($checked eq 'newThread') { - $checked = &check_reply_dupe() || $checked;} +use Arc::Starter; +use CheckRFC; +use Encode::Plain; $Encode::Plain::utf8 = 1; +use Encode::Posting; +use Lock; +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; - unless (exists ($subhash {$checked})) { - &print_fatal ($assign -> {unknownError});} - else { - &{$subhash {$checked}};} +use CGI; - if ($flocked) { - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}} +### sub new #################################################################### +# +# initialising the Posting::Request object +# check parameters and fill in object properties +# +sub new { + my ($class, $conf, $adminDefault) = @_; + + my $sp = $conf -> {show} -> {Posting}; + + my $self = { + conf => { + original => $conf, + admin => $adminDefault, + + message_path => $conf -> {files} -> {messagePath}, + forum_file_name => $conf -> {files} -> {forum}, + + show_posting => $sp, + assign => $sp -> {assign}, + template => $conf -> {template}, + form_must => $sp -> {form} -> {must}, + form_data => $sp -> {form} -> {data}, + form_action => $sp -> {form} -> {action}, + }, + + template => new Template $sp -> {templateFile}, + response => {}, + forum => {}, + error => {} + }; + + bless $self, $class; +} -# ==================================================== -# end of main / Funktionen -# ==================================================== +sub severance { + my $self = shift; + start_severance ($self -> {conf} -> {original} -> {files} -> {sev_app}); +} -### check_reply_dupe () ######################################################## +### sub response ############################################################### # -# Reply moeglich? Doppelposting? +# print the response to STDOUT # -# Params: -none- -# Return: Dupe check result -# 'Dupe' - Posting is a dupe -# Nothing - ok. +# Return: -none- # -sub check_reply_dupe () { - my $stat; +sub response { + my $self = shift; + my $formdata = $self -> {conf} -> {form_data}; + my $formact = $self -> {conf} -> {form_action}; + my $template = $self -> {template}; + my $assign = $self -> {conf} -> {assign}; + my $q = $self -> {cgi_object}; + + # fill out the form field names + # + my $pars = {}; + for (keys %$formdata) { + $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name}) if ( + exists($formdata -> {$_} -> {name}) + and exists ($formdata -> {$_} -> {assign}) + and exists ($formdata -> {$_} -> {assign} -> {name}) + ); + } - unless ($stat = write_lock_file (forum_filename)) { - if ($stat == 0) { - # ueberlastet oder so - violent_unlock_file (forum_filename); - return 'Occupied'; - } else { - return 'masterLock'; + # 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}} + ] + ); + } + } } - } else { - my ($i, %msg, %unids); - - $flocked = 1; - - ($threads, $last_thread, $last_message, undef, my $unids) = get_all_threads (forum_filename, 1, 0); - ($ftid,$fmid) = split /;/,$dparam{$formdata -> {followUp} -> {name}},2; - - # Thread existiert nicht - if (exists($dparam{$formdata -> {followUp} -> {name}})) { - return 'noReply' unless (exists($threads -> {$ftid})); - # nur nicht geloeschte Messages beachten - for ($i=0; $i < @{$threads -> {$ftid}}; $i++) { - if ($threads -> {$ftid} -> [$i] -> {deleted}) { - $i+=$threads -> {$ftid} -> [$i] -> {answers};} + 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; + } - else { - $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;}} + # check the response -> doc + # + unless ($self -> {response} -> {doc}) { + $self -> {error} = { + spec => 'unknown_error', + type => 'fatal' + }; - # Message existiert nicht - if (exists($dparam{$formdata -> {followUp} -> {name}})) { - return 'noReply' unless (exists($msg{$fmid}));} + $self -> handle_error; - %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}}; - } else { - %unids = map {$_ => 1} @$unids; + unless ($self -> {response} -> {doc}) { + $self -> jerk ('While producing the HTML response an unknown error has occurred.'); + return; } - - # jetzt endlich - return 'Dupe' if (exists ($unids{$dparam{$formdata -> {uniqueID} -> {name}}})); } + # 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 got_new -# -# Eroeffnungsposting speichern -################################ - -sub got_new () { - - my $time = time; - my $pars = {author => $dparam {$formdata -> {posterName} -> {name}}, - email => $dparam {$formdata -> {posterEmail} -> {name}}, - category => $dparam {$formdata -> {posterCategory} -> {name}}, - subject => $dparam {$formdata -> {posterSubject} -> {name}}, - body => $dparam {$formdata -> {posterBody} -> {name}}, - homepage => $dparam {$formdata -> {posterURL} -> {name}}, - image => $dparam {$formdata -> {posterImage} -> {name}}, - time => $time, - uniqueID => $dparam {$formdata -> {uniqueID} -> {name}}, - ip => $ENV{REMOTE_ADDR}, - forumFile => forum_filename, - messagePath => message_path, - lastThread => $last_thread, - lastMessage => $last_message, - parsedThreads => $threads, - dtd => 'forum.dtd', - quoteChars => toUTF8('»» '), - messages => $conf -> {template} -> {messages}}; - - my ($stat, $xml, $mid) = write_posting ($pars); - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename)); - $flocked = undef; - - if ($stat) { - print "Och noe...: $stat";} +### 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 { - my $thx = $show_posting -> {thanx}; - - print ${$template -> scrap ($assign -> {docThx}, - {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}), - $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}), - $thx -> {time} => plain (hr_time($time)), - $thx -> {body} => message_as_HTML ($xml, $template, - {posting => $mid, - assign => $assign}), - $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}), - $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}), - $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}), - $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})}; + $emsg = $assign -> {$spec} || ''; } - return; -} -################################ -# sub got_reply -# -# Antwortposting speichern -################################ - -sub got_reply () { - my $stat; - - my $time = time; - my $pars = {author => $dparam {$formdata -> {posterName} -> {name}}, - email => $dparam {$formdata -> {posterEmail} -> {name}}, - category => $dparam {$formdata -> {posterCategory} -> {name}}, - subject => $dparam {$formdata -> {posterSubject} -> {name}}, - body => $dparam {$formdata -> {posterBody} -> {name}}, - homepage => $dparam {$formdata -> {posterURL} -> {name}}, - image => $dparam {$formdata -> {posterImage} -> {name}}, - time => $time, - uniqueID => $dparam {$formdata -> {uniqueID} -> {name}}, - ip => $ENV{REMOTE_ADDR}, - parentMessage => $fmid, - thread => $ftid, - forumFile => forum_filename, - messagePath => message_path, - lastThread => $last_thread, - lastMessage => $last_message, - parsedThreads => $threads, - dtd => 'forum.dtd', - quoteChars => toUTF8('»» '), - messages => $conf -> {template} -> {messages}}; - - ($stat, my $xml, my $mid) = write_posting ($pars); - violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename)); - $flocked = undef; - - if ($stat) { - print "Och noe...: $stat";} + # fatal errors + # + if ($type eq 'fatal') { + $self -> {response} -> {doc} = $assign -> {docFatal}; + $self -> {response} -> {pars} = { + $assign -> {errorMessage} => $self -> {template} -> insert ($emsg) + }; + } - else { - my $thx = $show_posting -> {thanx}; - - print ${$template -> scrap ($assign -> {docThx}, - {$thx -> {author} => plain ($dparam {$formdata -> {posterName} -> {name}}), - $thx -> {email} => plain ($dparam {$formdata -> {posterEmail} -> {name}}), - $thx -> {time} => plain (hr_time($time)), - $thx -> {body} => message_as_HTML ($xml, $template, - {posting => $mid, - assign => $assign}), - $thx -> {category} => plain ($dparam {$formdata -> {posterCategory} -> {name}}), - $thx -> {home} => plain ($dparam {$formdata -> {posterURL} -> {name}}), - $thx -> {image} => plain ($dparam {$formdata -> {posterImage} -> {name}}), - $thx -> {subject} => plain ($dparam {$formdata -> {posterSubject} -> {name}})})};} + # 'soft' errors + # user is able to repair his request + # + elsif ($type eq 'repeat' or $type eq 'fetch') { + $self -> {response} -> {doc} = $assign -> {docError}; + $self -> fillout_form; + $self -> {response} -> {pars} -> {$assign -> {errorMessage}} = $self -> {template} -> insert ($emsg); + my $num = $spec eq 'too_long' + ? $formdata -> {$desc} -> {maxlength} + : ($spec eq 'too_short' + ? $formdata -> {$desc} -> {minlength} + : undef + ); + + $self -> {response} -> {pars} -> {$assign -> {charNum}} = $num + if $num; + } + + 1; } -################################ -# sub new_thread +### sub fillout_form ########################################################### +# +# fill out the form using available form data +# +# Return: -none- # -# HTML fuer Eroeffnungsposting -################################ +sub fillout_form { + my $self = shift; -sub new_thread () { - my $list = [map {{$assign -> {optval} => plain($_)}} @{$formdata -> {posterCategory} -> {values}}]; + my $assign = $self -> {conf} -> {assign}; + my $formdata = $self -> {conf} -> {form_data}; + my $formact = $self -> {conf} -> {form_action}; + my $q = $self -> {cgi_object}; + my $pars = {}; - # spaeter kommen noch userspezifische Daten dazu... - print ${$template -> scrap ($assign -> {docNew}, - {$formdata->{uniqueID} ->{assign}->{value} => plain(unique_id), - $formdata->{quoteChar} ->{assign}->{value} => 'ÿ'.plain(toUTF8('»» ')), - $formact->{post}->{assign} => $formact->{post}->{url}, - $formdata->{posterCategory}->{assign}->{value} => $template->list ($assign -> {option}, $list) - },$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; } -################################ -# diverse subs +### sub save ################################################################### +# +# save posting +# check on legal reply or dupe is released here # -# Fehlermeldungen -################################ +# Return: -none- +# +sub save { + my $self = shift; -sub no_reply () {&print_fatal ($assign -> {noReply});} -sub dupe_posting () {&print_fatal ($assign -> {dupe});} -sub missing_key () {&print_fatal ($assign -> {wrongPar});} -sub unexpected_key () {&print_fatal ($assign -> {wrongPar});} -sub unknown_encoding () {&print_fatal ($assign -> {wrongCode});} -sub too_short () { - if ($formdata -> {$failed} -> {errorType} eq 'repeat') { - &print_error ($formdata -> {$failed} -> {assign} -> {tooShort}, - $formdata -> {$failed} -> {minlength});} + # if an empty 'new message' document, there's nothing to save + # + return if ($self -> {response} -> {new_thread}); - else { - &print_fatal ($formdata -> {$failed} -> {assign} -> {tooShort});} -} + $self -> {check_success} = 0; + + # 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 -> {$_}); + } + } + } + } + } -sub too_long () { - if ($formdata -> {$failed} -> {errorType} eq 'repeat') { - &print_error ($formdata -> {$failed} -> {assign} -> {tooLong}, - $formdata -> {$failed} -> {maxlength});} + # unlock forum main file + # + if ($self -> {forum} -> {flocked}) { + $self -> {forum} -> {flocked} -> unlock; + $self -> {forum} -> {flocked} = 0; + } - else { - &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});} -} + $self -> handle_error unless $self -> {check_success}; -sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});} -sub occupied () {print_error ($assign -> {occupied});} + return; +} -################################ -# sub print_fatal +### sub parse_cgi ############################################################## +# +# fetch and decode cgi-parameters, +# find out the kind of response requested by the user (new message, reply) # -# fatale Fehlerausgabe -################################ +# Return: -none- +# +sub parse_cgi { + my $self = shift; + + # create the CGI object + # + $self -> {cgi_object} = new CGI; -sub print_fatal ($) { - print ${$template -> scrap ($assign -> {docFatal}, - {$assign -> {errorMessage} => $template -> insert ($_[0]) - },$pars)}; + # check the params + # + $self -> {check_success} = $self -> check_cgi; + + return; } -################################ -# sub print_error +### sub load_main_file ######################################################### +# +# load and parse the forum main file # -# Fehlerausgabe, Moeglichkeit -# zur Korrektur -################################ +# Return: Success (true/false) +# +sub load_main_file { + my $self = shift; + my $forum = new Lock ($self -> {conf} -> {forum_file_name}); + + unless ($forum -> lock(LH_EXCL)) { + unless ($forum -> masterlocked) { + # occupied or no w-bit set for the directory..., hmmm + # + $self -> {error} = { + spec => 'occupied', + type => 'repeat' + }; + return; + } + else { + # master lock is set + # + $self -> {error} = { + spec => 'master_lock', + type => 'fatal' + }; + return; + } + } + else { + $self -> {forum} -> {flocked} = $forum; + ( $self -> {forum} -> {threads}, + $self -> {forum} -> {last_thread}, + $self -> {forum} -> {last_message}, + $self -> {forum} -> {dtd}, + $self -> {forum} -> {unids} + ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED); + } -sub print_error ($;$) { - &fillin; - print ${$template -> scrap ($assign -> {docError}, - {$assign -> {errorMessage} => $template -> insert ($_[0]), - $assign -> {charNum} => $_[1] - },$pars)}; + # ok, looks good + 1; } -################################ -# sub fetch_subject +### sub check_reply_dupe ####################################################### +# +# check whether a reply is legal +# (followup posting must exists) +# +# check whether this form request is a dupe +# (unique id already exists) # -# Subject und Category besorgen -# (wenn noch nicht vorhanden) -################################ +# Return: Status Code (Bool) +# +sub check_reply_dupe { + my $self = shift; + my %unids; + + # return true unless it's not a reply + # or an opening + # + return 1 unless ( + $self -> {response} -> {reply} + or $self -> {response} -> {new} + ); + + if ($self -> {response} -> {reply}) { + + my ($threads, $ftid, $fmid, $i, %msg) = ( + $self -> {forum} -> {threads}, + $self -> {fup_tid}, + $self -> {fup_mid} + ); + + # thread doesn't exist + # + unless (exists($threads -> {$ftid})) { + $self -> {error} = { + spec => 'no_reply', + type => 'fatal' + }; + return; + } -sub fetch_subject () { - unless (exists ($dparam{$formdata -> {posterCategory} -> {name}}) and - exists ($dparam{$formdata -> {posterSubject} -> {name}})) { + # build a reverse lookup hash (mid => number in array) + # and ignore invisible messages + # (users can't reply to "deleted" msg) + # + for ($i=0; $i < @{$threads -> {$ftid}}; $i++) { - my $filename = message_path.'t'.$ftid.'.xml'; + if ($threads -> {$ftid} -> [$i] -> {deleted}) { + $i+=$threads -> {$ftid} -> [$i] -> {answers}; + } + else { + $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i; + } + } - if (lock_file ($filename)) { - my $xml = new XML::DOM::Parser -> parsefile ($filename); - violent_unlock_file($filename) unless unlock_file ($filename); + # message doesn't exist + # + unless (exists($msg{$fmid})) { + $self -> {error} = { + spec => 'no_reply', + type => 'fatal' + }; + return; + } - my $mnode = get_message_node ($xml, "t$ftid", "m$fmid"); - my $header = get_message_header ($mnode); + # 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}}; + } - $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category}; - $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};}} + # 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 fillin +### sub check_cgi ############################################################## +# +# cgi params are like raw eggs... # -# Fuellen von $pars -# (bereits vorhandene Formdaten) -################################ +# Return: Status Code (Bool) +# creates content for the handle_error method if anything fails +# +sub check_cgi { + my $self = shift; -sub fillin () { - fetch_subject; + # count the submitted keys and get the keys themselves + # + my %got_keys = map {($_ => 1)} $self -> {cgi_object} -> param; + my $cnt_got_keys = keys %got_keys; + my $formdata = $self -> {conf} -> {form_data}; + my $formmust = $self -> {conf} -> {form_must}; - my $list = [map {{$assign -> {optval} => plain($_), - (($_ eq $dparam{$formdata -> {posterCategory} -> {name}})?($assign -> {optsel} => 1):())}} - @{$formdata -> {posterCategory} -> {values}}]; + # user requested the 'new thread' page + # (no params but perhaps the user-ID have been submitted) + # + if ($cnt_got_keys == 0 or ( + exists ($formdata -> {userID}) + and $cnt_got_keys == 1 + and $got_keys{$formdata -> {userID} -> {name}} + )) { + $self -> {response} -> {new_thread} = 1; + $self -> {check_success} = 1; + return 1; + } - $pars -> {$formdata->{posterCategory}->{assign}->{value}} = $template->list ($assign -> {option}, $list); - $pars -> {$formact ->{post}->{assign}} = $formact->{post}->{url}; - $pars -> {$formdata->{quoteChar}->{assign}->{value}} = 'ÿ'.plain($dparam {$formdata -> {quoteChar} -> {name}} or ''); + # now we know, we've got a filled out form + # we do the following steps to check it: + # + # 1st: create a reverse Hash (CGI-key - identifier) + # 2nd: did we get _all_ must-keys? + # check whether reply or new message request + # 3rd: did we get too many keys? + # 4th: do _all_ submitted values accord to + # our expectations? + # fetch the "missing" keys + # - # Formfelder ausfuellen (Werte) - for (qw(uniqueID userID followUp posterName posterEmail posterSubject posterBody posterURL posterImage)) { - $pars -> {$formdata->{$_}->{assign}->{value}} = plain($dparam {$formdata -> {$_} -> {name}});} -} + # 1 + # + my %name = map { + exists($formdata -> {$_} -> {name}) + ? ($formdata -> {$_} -> {name} => $_) + : () + } keys %$formdata; -################################ -# sub decode_param -# -# CGI-Parameter decodieren -# (rudimentaerer UTF8-support) -################################ + # 2 + # + $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0; + $self -> {response} -> {new} = not $self -> {response} -> {reply}; -sub decode_param () { - my $code = param ($formdata -> {quoteChar} -> {name}); - my @array; + # define the fetch array (values to fetch from parent message) + # + $self -> {fetch} = []; - # UTF-8 ([hoechst-]wahrscheinlich) - if ($code =~ /^\303\277/) { + for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) { - foreach (param) { - @array=param ($_); + unless ($got_keys {$formdata -> {$_} -> {name}}) { - if (@array == 1) { - $dparam{$_} = $array[0];} + # only miss the key unless we're able to fetch it from parent posting + # + unless ( + not $self -> {response} -> {reply} + or $formdata -> {$_} -> {errorType} eq 'fetch') { + $self -> {error} = { + spec => 'missing_key', + desc => $_, + type => 'fatal' + }; + return; + } else { - $dparam{$_} = \@array;}}} + # keep in mind to fetch the value later + # + push @{$self -> {fetch}} => $_; + } + } + } - # Latin 1 (hoffentlich - eigentlich ist es gar keine Codierung...) - elsif ($code =~ /^\377/) { - foreach (param) { - @array=param ($_); + # I'm lazy - I know... + my $q = $self -> {cgi_object}; - if (@array == 1) { - $dparam{$_} = toUTF8($array[0]);} + # 3 + # + for ($q -> param) { + unless (exists ($name {$_})) { + $self -> {error} = { + spec => 'unexpected_key', + desc => $name{$_}, + type => 'fatal' + }; + return; + } + } - else { - $dparam{$_} = [map {toUTF8($_)} @array];}}} + # 4 + # + unless ($self -> decode_param) { + $self -> {error} = { + spec => 'unknown_encoding', + type => 'fatal' + }; + return; + }; + + if ($self -> {response} -> {reply}) { + + # get the parent-identifiers if we got a reply request + # + my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2; + + unless ($ftid =~ /^\d+$/ and $fmid =~ /^\d+$/) { + $self -> {error} = { + spec => 'unknown_followup', + type => 'fatal' + }; + return; + } + $self -> {fup_tid} = $ftid; + $self -> {fup_mid} = $fmid; + + # fetch the missing keys + # if it fails, they're too short, too... ;) + # + $self -> fetch; + $got_keys{$formdata -> {$_} -> {name}} = 1 for (@{$self -> {fetch}}); + } - # unbekannte Codierung - else { - return;} + # now we can check on length, type etc. + # + for (keys %got_keys) { + + # we are sure, we've got only one value for one key + # + my $val = $q -> param ($_); + + $val =~ s/\302\240/ /g; # convert nbsp (UTF-8 encoded) into normal spaces + $val =~ s/\015\012|\015|\012/ /g # convert \n into spaces unless it's a multiline field + unless ( + exists ($formdata -> {$name {$_}} -> {type}) + and $formdata -> {$name {$_}} -> {type} eq 'multiline-text' + ); + + $q -> param ($_ => $val); # write it back + + # too long? + # + if (length $val > $formdata -> {$name {$_}} -> {maxlength}) { + $self -> {error} = { + spec => 'too_long', + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} + }; + $self -> kill_param or return; + } - # ersten beiden Zeichen der Quotechars loeschen (Indikator [ÿ (als UTF8)]) - $dparam {$formdata -> {quoteChar} -> {name}} = ($dparam {$formdata -> {quoteChar} -> {name}} =~ /..(.*)/)[0]; + # too short? + # (only check if there's defined a minimum length) + # + if (exists ($formdata -> {$name {$_}} -> {minlength})) { + + # kill the whitespaces to get only the visible characters... + # + (my $val_ww = $val) =~ s/\s+//g; + + if (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} + }; + $self -> kill_param or return; + } + } - delete $dparam {$formdata -> {posterURL} -> {name}} - unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/); + # check the values on expected kinds of content + # (email, http-url, url, option) + # + if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) { + if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) { + $self -> {error} = { + spec => 'wrong_mail', + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} + }; + $self -> kill_param or return; + } + + elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') { + $self -> {error} = { + spec => 'wrong_http_url', + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} + }; + $self -> kill_param or return; + } + + elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') { + $self -> {error} = { + spec => 'wrong_url', + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} + }; + $self -> kill_param or return; + } + + 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; + } + } - delete $dparam {$formdata -> {posterImage} -> {name}} - unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/); + if (exists ($formdata -> {$name {$_}} -> {values}) + and not exists ({map {$_ => undef} @{$formdata -> {$name {$_}} -> {values}}} -> {$val})) { + $self -> {error} = { + spec => 'no_option', + desc => $name{$_}, + type => $formdata -> {$name {$_}} -> {errorType} + }; + $self -> kill_param or return; + } + } - # Codierung erkannt, alles klar + # ok, looks good. 1; } +### sub kill_param ############################################################# +# +# kill the param (set it on '') if wrong and declared as 'kill' in config file +# +# Return: true if killed +# false otherwise +# +sub kill_param { + my $self = shift; + + if ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {errorType} eq 'kill') { + $self -> {cgi_object} -> param ($self -> {conf} -> {form_data} -> {$self -> {error} -> {desc}} -> {name} => ''); + $self -> {error} = {}; + return 1; + } + + return; +} -################################ -# sub check_param +### sub fetch ################################################################## +# +# fetch "missing" keys from parent posting # -# CGI-Parameter pruefen -################################ +sub fetch { + my $self = shift; + my $q = $self -> {cgi_object}; + my $formdata = $self -> {conf} -> {form_data}; -sub check_param () { - my %gotKeys = map {($_ => 1)} param; - my $numGotKeys = keys %gotKeys; + if (@{$self -> {fetch}}) { + my $thread = new Lock ($self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml'); - # Threaderoeffnung, Ersteingabe (leere Seite) - return 'newThread' if ($numGotKeys == 0 or - (($numGotKeys == 1) and ($gotKeys {$formdata -> {userID} -> {name}}))); + if ($thread -> lock (LH_SHARED)) { + my $xml = parse_xml_file ($thread -> filename); + $thread -> unlock; - # ======================================================= - # ab hier steht fest, wir haben ein ausgefuelltes - # Formular bekommen - # - # 1. Umrechnungshash bauen (CGI-Key => Identifier) - # 2. alle must-keys vorhanden? - # 3. zuviele Parameter uebermittelt? - # 4. entsprechen die Daten den Anforderungen? - # (alle, nicht nur die must-Daten) + if ($xml) { + my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid}); + if ($mnode) { + my $header = get_message_header ($mnode); - # 1 - # === - my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata; + $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}}) + for (@{$self -> {fetch}}); - # 2 - # === - $failed=1; - foreach (@{$formmust -> {$gotKeys {$formdata -> {followUp} -> {name}}?'reply':'new'}}) { - return 'missingKey' unless ($gotKeys {$formdata -> {$_} -> {name}}); + return; + } + } + } } - # 3 - # === - foreach (param) { - $failed = $name {$_}; - return 'unexpectedKey' unless (exists ($name {$_})); - } + # fetching failed: + # fillout the values with an empty string + # + $q -> param ($formdata -> {$_} -> {name} => '') + for (@{$self -> {fetch}}); - # 4 - # === - return 'unknownEncoding' unless (decode_param); + return; +} - foreach (keys %dparam) { - $failed = $name {$_}; +### sub decode_param ########################################################### +# +# convert submitted form data into UTF-8 +# unless it's not encoded yet +# +# Return: Status Code (Bool) +# false if unknown encoding (like UTF-7 for instance) +# +sub decode_param { + my $self = shift; + + my $q = $self -> {cgi_object}; + my $formdata = $self -> {conf} -> {form_data}; + + my $code = $q -> param ($formdata -> {quoteChar} -> {name}); + my @array; - return 'tooLong' if (length($dparam{$_}) > $formdata -> {$name {$_}} -> {maxlength}); - return 'tooShort' if (@{[$dparam{$_} =~ /(\S)/g]} < $formdata -> {$name {$_}} -> {minlength}); - return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_})); + # Latin 1 (we hope so - there's no real way to find out :-( ) + if ($code =~ /^\377/) { + $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param); } + else { + # UTF-8 is (probably) correct, + # other encodings we don't know and fail + return unless $code =~ /^\303\277/; + } + + # remove the ÿ (encoded as UTF-8) from quotechars + $q -> param ($formdata -> {quoteChar} -> {name} + => substr $q -> param ($formdata -> {quoteChar} -> {name}),2); - $failed=0; - return $gotKeys {$formdata -> {followUp} -> {name}}?'gotReply':'gotNew'; + # ok, params now should be UTF-8 encoded + 1; } -# ==================================================== -# Initialisierung -# ==================================================== +sub jerk { + my $text = shift; + $text = 'An error has occurred.' unless defined $text; -BEGIN { - %subhash = (newThread => \&new_thread, - missingKey => \&missing_key, - unexpectedKey => \&unexpected_key, - unknownEncoding => \&unknown_encoding, - tooShort => \&too_short, - tooLong => \&too_long, - wrongMail => \&wrong_mail, - Occupied => \&occupied, - Dupe => \&dupe_posting, - noReply => \&no_reply, - gotReply => \&got_reply, - gotNew => \&got_new - ); - - # Die RFC-gerechte URL-Erkennung ist aus dem Forum - # (thx2Cheatah - wo auch immer er sie (in der Form) her hat :-) - my $lowalpha = '(?:[a-z])'; - my $hialpha = '(?:[A-Z])'; - my $alpha = "(?:$lowalpha|$hialpha)"; - my $digit = '(?:\d)'; - my $safe = '(?:[$_.+-])'; - my $hex = '(?:[\dA-Fa-f])'; - my $escape = "(?:%$hex$hex)"; - my $digits = '(?:\d+)'; - my $alphadigit = "(?:$alpha|\\d)"; - - # URL schemeparts for ip based protocols: - my $port = "(?:$digits)"; - my $hostnumber = "(?:$digits\\.$digits\\.$digits\\.$digits)"; - my $toplabel = "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)"; - my $domainlabel = "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)"; - my $hostname = "(?:(?:$domainlabel\\.)*$toplabel)"; - my $host = "(?:(?:$hostname)|(?:$hostnumber))"; - my $hostport = "(?:(?:$host)(?::$port)?)"; - - my $httpuchar = "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)"; - my $hsegment = "(?:(?:$httpuchar|[;:\@&=~])*)"; - my $search = "(?:(?:$httpuchar|[;:\@&=~])*)"; - my $hpath = "(?:$hsegment(?:/$hsegment)*)"; - - # das alles ergibt eine gueltige URL :-) - $httpurl = "^(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)\$"; + print <