-#!/usr/bin/perl -wT
+#!/usr/bin/perl -w
################################################################################
# #
# File: user/fo_posting.pl #
# #
-# Authors: André Malo <nd@o3media.de>, 2001-03-31 #
+# Authors: André Malo <nd@o3media.de> #
# #
# 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
+);
# locate the script
+#
BEGIN {
- my $null = $0; $null =~ s/\\/\//g; # for win :-(
- ($Bin) = ($null =~ /^(.*)\/.*$/)? $1 : '.';
- $Shared = "$Bin/../shared";
- ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null;
+# 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/../../cgi-config/forum";
+ $Shared = "$Bin/../../cgi-shared";
+ $Script = ($null =~ /^.*\/(.*)$/)? $1 : $null;
}
+# setting umask, remove or comment it, if you don't need
+#
+umask 000;
+
use lib "$Shared";
use CGI::Carp qw(fatalsToBrowser);
-#use Conf;
-#use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
-#use Id;
-#use Posting::Write;
-#use Template;
-#use Template::Posting;
+use Conf;
+use Conf::Admin;
+use Posting::Cache;
-#use autouse 'Encode::Posting' => qw();
+################################################################################
+#
+# Version check
+#
+# last modified:
+# $Date$ (GMT)
+# by $Author$
+#
+sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}
# load script configuration and admin default conf.
-my $conf = read_script_conf ($Bin, $Shared, $Script);
+#
+my $conf = read_script_conf ($Config, $Shared, $Script);
my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
# Initialize the request
#
$request -> response;
+# shorten the main file?
+#
+$request -> severance;
+
#
#
### main end ###################################################################
### Posting::Request ###########################################################
package Posting::Request;
-use Lock qw(:ALL);
+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
- );
+ hr_time
+ parse_xml_file
+ get_all_threads
+ get_message_node
+ get_message_header
+ KEEP_DELETED
+);
+use Posting::Write;
+use Id;
+use Template;
+use Template::Posting;
-use autouse 'CheckRFC' => qw[ is_email($) is_URL($@) ];
use CGI;
### sub new ####################################################################
show_posting => $sp,
assign => $sp -> {assign},
+ template => $conf -> {template},
form_must => $sp -> {form} -> {must},
form_data => $sp -> {form} -> {data},
form_action => $sp -> {form} -> {action},
bless $self, $class;
}
+sub severance {
+ my $self = shift;
+
+ start_severance ($self -> {conf} -> {original} -> {files} -> {sev_app});
+}
+
+### sub response ###############################################################
+#
+# print the response to STDOUT
+#
+# Return: -none-
+#
+sub response {
+ my $self = shift;
+ my $formdata = $self -> {conf} -> {form_data};
+ my $formact = $self -> {conf} -> {form_action};
+ my $template = $self -> {template};
+ my $assign = $self -> {conf} -> {assign};
+ my $q = $self -> {cgi_object};
+
+ # fill out the form field names
+ #
+ my $pars = {};
+ for (keys %$formdata) {
+ $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name}) if (
+ exists($formdata -> {$_} -> {name})
+ and exists ($formdata -> {$_} -> {assign})
+ and exists ($formdata -> {$_} -> {assign} -> {name})
+ );
+ }
+
+ # response the 'new message' page
+ #
+ if ($self -> {response} -> {new_thread}) {
+
+ # fill in the default form data
+ # and optionlist(s)
+ #
+ my $default = {};
+ for (keys %$formdata) {
+ unless (exists ($formdata -> {$_} -> {type}) and $formdata -> {$_} -> {type} eq 'internal') {
+ if (exists ($formdata -> {$_} -> {default}) and exists ($formdata -> {$_} -> {assign} -> {value})) {
+ $default -> {$formdata -> {$_} -> {assign} -> {value}}
+ = $formdata -> {$_} -> {default};
+ }
+ elsif (exists($formdata -> {$_} -> {values})) {
+ my ($_name, $val) = $_;
+ $val = exists ($formdata -> {$_} -> {default})
+ ? $formdata -> {$_} -> {default}
+ : undef;
+ $default -> {$formdata -> {$_} -> {assign} -> {value}}
+ = $self -> {template} -> list (
+ $assign -> {option},
+ [ map {
+ { $assign -> {optval} => plain($_),
+ ((defined $val and $_ eq $val)
+ ? ($assign -> {optsel} => 1)
+ : ()
+ )
+ }
+ } @{$formdata -> {$_name} -> {values}}
+ ]
+ );
+ }
+ }
+ }
+
+ print $q -> header (-type => 'text/html');
+ print ${$template -> scrap (
+ $assign -> {docNew},
+ { $formdata->{uniqueID} ->{assign}->{value} => plain(unique_id),
+ $formdata->{quoteChar} ->{assign}->{value} => 'ÿ'.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
#
return if ($self -> {response} -> {new_thread});
+ $self -> {check_success} = 0;
+
# lock and load the forum main file
#
if ($self -> load_main_file) {
#
if ($self -> check_reply_dupe) {
- # we've got an opening
- #
- if ($self -> {response} -> {new}) {
- $self -> save_new;
- }
-
- # we've got a reply
- #
- elsif ($self -> {response} -> {reply}) {
- $self -> save_reply;
- }
-
- # don't know, if we any time come to this branch
- # the script is probably broken
- #
- else {
+ unless ($self -> {response} -> {reply} or $self -> {response} -> {new}) {
+ # don't know, if we any time come to this branch
+ # the script is probably broken
+ #
$self -> {error} = {
spec => 'unknown_error',
type => 'fatal'
};
}
+ 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 -> {forum_file_name}) unless unlock_file ($self -> {forum_file_name});
+ $self -> {forum} -> {flocked} -> unlock;
$self -> {forum} -> {flocked} = 0;
}
# create the CGI object
#
- my $q = new CGI;
- $self -> {cgi_object} = $q;
+ $self -> {cgi_object} = new CGI;
# check the params
#
#
sub load_main_file {
my $self = shift;
- my $lock_stat;
+ my $forum = new Lock ($self -> {conf} -> {forum_file_name});
- unless ($lock_stat = write_lock_file ($self ->{forum_file_name})) {
- if ($lock_stat == 0) {
+ unless ($forum -> lock(LH_EXCL)) {
+ unless ($forum -> masterlocked) {
# occupied or no w-bit set for the directory..., hmmm
#
- violent_unlock_file ($self -> {forum_file_name});
$self -> {error} = {
spec => 'occupied',
- type => 'fatal'
+ type => 'repeat'
};
return;
}
}
}
else {
- $self -> {forum} -> {flocked} = 1;
+ $self -> {forum} -> {flocked} = $forum;
( $self -> {forum} -> {threads},
$self -> {forum} -> {last_thread},
$self -> {forum} -> {last_message},
- undef,
+ $self -> {forum} -> {dtd},
$self -> {forum} -> {unids}
- ) = get_all_threads ($self -> {forum_file_name}, KEEP_DELETED);
+ ) = get_all_threads ($self -> {conf} -> {forum_file_name}, KEEP_DELETED);
}
# ok, looks good
#
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}
- and $self -> {response} -> {new}
+ or $self -> {response} -> {new}
);
- my %unids;
-
if ($self -> {response} -> {reply}) {
- my ($threads, $ftid, $fmid, $i, %msg, %unids) = (
+ my ($threads, $ftid, $fmid, $i, %msg) = (
$self -> {forum} -> {threads},
$self -> {fup_tid},
$self -> {fup_mid}
# build a unique id lookup hash, too
# but use only the level-zero-messages
#
- %unids = map {$_ => 1} @{$self -> {unids}};
+ %unids = map {$_ => 1} @{$self -> {forum} -> {unids}};
}
# now check on dupe
# 1
#
- my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
+ my %name = map {
+ exists($formdata -> {$_} -> {name})
+ ? ($formdata -> {$_} -> {name} => $_)
+ : ()
+ } keys %$formdata;
# 2
#
# 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',
+ 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',
return;
};
- # I'm lazy - I know...
- my $q = $self -> {cgi_object};
-
if ($self -> {response} -> {reply}) {
# get the parent-identifiers if we got a reply request
#
my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
- unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
+ unless ($ftid =~ /^\d+$/ and $fmid =~ /^\d+$/) {
$self -> {error} = {
spec => 'unknown_followup',
type => 'fatal'
# 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.
desc => $name{$_},
type => $formdata -> {$name {$_}} -> {errorType}
};
- return;
+ $self -> kill_param or return;
}
# too short?
#
(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}
};
- 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) {
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') {
desc => $name{$_},
type => $formdata -> {$name {$_}} -> {errorType}
};
- return;
+ $self -> kill_param or return;
}
elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
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 ##################################################################
#
my $formdata = $self -> {conf} -> {form_data};
if (@{$self -> {fetch}}) {
- my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
+ my $thread = new Lock ($self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml');
- if (lock_file ($filename)) {
- my $xml = parse_xml_file ($filename);
- violent_unlock_file($filename) unless unlock_file ($filename);
+ if ($thread -> lock (LH_SHARED)) {
+ my $xml = parse_xml_file ($thread -> filename);
+ $thread -> unlock;
if ($xml) {
my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
}
# 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 = shift;
+ $text = 'An error has occurred.' unless defined $text;
+
+ print <<EOF;
+Content-type: text/plain
+
+
+
+ Oops.
+
+ $text
+ We will fix it as soon as possible. Thank you for your patience.
+
+ Regards
+ n.d.p.
+EOF
+}
+
#
#
### end of fo_posting.pl #######################################################
\ No newline at end of file
git.p6c8.net / selfforum.git / blobdiff