-#!/usr/bin/perl
+#!/usr/bin/perl -w
################################################################################
# #
# File: user/fo_posting.pl #
# #
-# Authors: André Malo <nd@o3media.de>, 2001-01-25 #
+# Authors: André Malo <nd@o3media.de>, 2001-04-08 #
# #
# 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; #$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 CGI::Carp qw(fatalsToBrowser);
-use lib "$Shared";
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;
+# load script configuration and admin default conf.
+#
+my $conf = read_script_conf ($Config, $Shared, $Script);
+my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
-print header (-type => 'text/html');
+# Initialize the request
+#
+my $request = new Posting::Request ($conf, $adminDefault);
-our $conf = read_script_conf ($Bin, $Shared, $Script);
+# fetch and parse the cgi-params
+#
+$request -> parse_cgi;
-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);
+# handle errors or save the posting
+#
+$request -> handle_error or $request -> save;
-sub forum_filename () {$conf -> {files} -> {forum};}
-sub message_path () {$conf -> {files} -> {messagePath};}
+# show response
+#
+$request -> response;
-################################
+# shorten the main file?
+#
+$request -> severance;
-# Formfelder ausfuellen (Namen)
-for (qw(posterBody uniqueID followUp quoteChar userID posterName posterEmail posterCategory posterSubject posterURL posterImage)) {
- $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name});}
+#
+#
+### main end ###################################################################
-my $checked = &check_param;
+################################################################################
+### Posting::Request ###########################################################
+package Posting::Request;
-unless (exists ($subhash {$checked})) {
- &print_fatal ($assign -> {unknownError});}
+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;
-else {
- unless ($checked eq 'newThread') {
- $checked = &check_reply_dupe() || $checked;}
+use CGI;
- unless (exists ($subhash {$checked})) {
- &print_fatal ($assign -> {unknownError});}
- else {
- &{$subhash {$checked}};}
+### 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;
+}
- if ($flocked) {
- violent_unlock_file (forum_filename) unless (write_unlock_file (forum_filename));}}
+sub severance {
+ my $self = shift;
-# ====================================================
-# end of main / Funktionen
-# ====================================================
+ 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);
+}
-### 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, 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;
-sub too_long () {
- if ($formdata -> {$failed} -> {errorType} eq 'repeat') {
- &print_error ($formdata -> {$failed} -> {assign} -> {tooLong},
- $formdata -> {$failed} -> {maxlength});}
+ # 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 -> {$_});
+ }
+ }
+ }
+ }
+ }
- else {
- &print_fatal ($formdata -> {$failed} -> {assign} -> {tooLong});}
-}
+ # 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;
+ }
-sub wrong_mail () {print_error ($formdata -> {$failed} -> {assign} -> {wrong});}
-sub occupied () {print_error ($assign -> {occupied});}
+ $self -> handle_error unless $self -> {check_success};
-################################
-# sub print_fatal
+ return;
+}
+
+### 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
+#
+# Return: Success (true/false)
#
-# Fehlerausgabe, Moeglichkeit
-# zur Korrektur
-################################
+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);
+ }
-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 #######################################################
#
-# Subject und Category besorgen
-# (wenn noch nicht vorhanden)
-################################
+# 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;
-sub fetch_subject () {
- unless (exists ($dparam{$formdata -> {posterCategory} -> {name}}) and
- exists ($dparam{$formdata -> {posterSubject} -> {name}})) {
+ # 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;
+ }
- my $filename = message_path.'t'.$ftid.'.xml';
+ # 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 (lock_file ($filename)) {
- my $xml = new XML::DOM::Parser -> parsefile ($filename);
- violent_unlock_file($filename) unless unlock_file ($filename);
+ 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}};
+ }
- my $mnode = get_message_node ($xml, "t$ftid", "m$fmid");
- my $header = get_message_header ($mnode);
+ # now check on dupe
+ #
+ if (exists ($unids{
+ $self -> {cgi_object} -> param (
+ $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
+ $self -> {error} = {
+ spec => 'dupe',
+ type => 'fatal'
+ };
+ return;
+ }
- $dparam{$formdata -> {posterCategory} -> {name}} = $header -> {category};
- $dparam{$formdata -> {posterSubject} -> {name}} = $header -> {subject};}}
+ # ok, looks fine
+ 1;
}
-################################
-# sub fillin
+### sub check_cgi ##############################################################
#
-# Fuellen von $pars
-# (bereits vorhandene Formdaten)
-################################
+# cgi params are like raw eggs...
+#
+# 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;
+
+ $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',
+ 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 $filename = $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 (lock_file ($filename)) {
+ my $xml = parse_xml_file ($filename);
+ violent_unlock_file($filename) unless unlock_file ($filename);
- # =======================================================
- # 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 = $_[1] || 'An error has occurred.';
+ print <<EOF;
+Content-type: text/plain
-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)?)?)\$";
+
+
+ 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
git.p6c8.net / selfforum.git / blobdiff