# #
# File: user/fo_posting.pl #
# #
-# Authors: André Malo <nd@o3media.de>, 2001-03-30 #
+# Authors: André Malo <nd@o3media.de>, 2001-03-31 #
# #
# Description: Accept new postings, display "Neue Nachricht" page #
# #
}
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 CheckRFC;
-use Posting::_lib qw(get_all_threads get_message_node get_message_header hr_time parse_xml_file);
-use Posting::Write;
-use Template;
-use Template::Posting;
+use CGI::Carp qw(fatalsToBrowser);
-use CGI;
-use XML::DOM;
+#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 autouse 'Encode::Posting' => qw();
# load script configuration and admin default conf.
my $conf = read_script_conf ($Bin, $Shared, $Script);
my $response = new Posting::Response ($conf, $adminDefault);
# fetch and parse the cgi-params
+#
$response -> parse_cgi;
+# no further checks after fatal errors
+#
+if ($response -> success or $response -> error_type ne 'fatal') {
+ $response -> success (
+ $response -> check_reply
+ && $response -> check_dupe
+ && $response -> success
+ );
+}
+
+
+# handle errors or save the posting
+#
+$response -> handle_error or $response -> save;
+
+# show response
+#
+$response -> response;
+
+#
+#
+### main end ###################################################################
################################################################################
### Posting::Response ##########################################################
package Posting::Response;
+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 autouse 'CheckRFC' => qw(is_email is_URL);
+use CGI;
+
+sub success {$_[0] -> {check_success} = defined $_[1]?$_[1]:$_[0] -> {check_success}}
+sub error_type {$_[0] -> {error} -> {type}}
+
### sub new ####################################################################
#
# initialising the Posting::Response object
form_action => $sp -> {form} -> {action},
},
- template => new Template $sp -> {templateFile}
+ template => new Template $sp -> {templateFile},
+ response => {},
+ forum => {},
+ error => {}
};
bless $self, $class;
}
+### sub save ###################################################################
+#
+# save posting
+# check on legal reply or dupe is released here
+#
+# Return: -none-
+#
+sub save {
+ my $self = shift;
+
+ # if an empty 'new message' document, there's nothing to save
+ #
+ return if ($self -> {response} -> {new_thread});
+
+ # 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 and $self -> check_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 {
+ $self -> {error} = {
+ spec => 'unknown_error',
+ type => 'fatal'
+ };
+ }
+ }
+ }
+
+ # 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} = 0;
+ }
+
+ $self -> handle_error unless $self -> {check_success};
+
+ return;
+}
+
### sub parse_cgi ##############################################################
#
# fetch and decode cgi-parameters,
# find out the kind of response requested by the user (new message, reply)
#
-# Return: Status Code (Bool)
-# try out the error method, if false
+# Return: -none-
#
sub parse_cgi {
my $self = shift;
# create the CGI object
+ #
my $q = new CGI;
$self -> {cgi_object} = $q;
# check the params
- return unless $self -> check_cgi;
+ #
+ $self -> {check_success} = $self -> check_cgi;
+
+ return;
+}
+
+### sub load_main_file #########################################################
+#
+# load and parse the forum main file
+#
+# Return: Success (true/false)
+#
+sub load_main_file {
+ my $self = shift;
+ my $lock_stat;
+
+ unless ($lock_stat = write_lock_file ($self ->{forum_file_name})) {
+ if ($lock_stat == 0) {
+ # occupied or no w-bit set for the directory..., hmmm
+ #
+ violent_unlock_file ($self -> {forum_file_name});
+ $self -> {error} = {
+ spec => 'occupied',
+ type => 'fatal'
+ };
+ 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},
+ undef,
+ $self -> {forum} -> {unids}
+ ) = get_all_threads ($self -> {forum_file_name}, KEEP_DELETED);
+ }
+
+ # ok, looks good
+ 1;
+}
+
+### sub check_reply ############################################################
+#
+# check whether a reply is legal
+# (followup posting must exists)
+#
+# Return: Status Code (Bool)
+#
+sub check_reply {
+ my $self = shift;
+
+ # return true unless it's not a reply
+ #
+ return 1 unless $self -> {response} -> {reply};
+
+
+}
+
+### sub check_dupe #############################################################
+#
+# check whether this form request is a dupe
+# (unique id already exists)
+#
+# Return: Status Code (Bool)
+#
+sub check_dupe {
+ my $self = shift;
+
+ return 1 if ($self -> {response} -> {new_thread});
}
### sub check_cgi ##############################################################
# cgi params are like raw eggs...
#
# Return: Status Code (Bool)
-# creates content for the error method if anything fails
+# creates content for the handle_error method if anything fails
#
sub check_cgi {
my $self = shift;
- # find out the count of the submitted keys and the keys themselves
+ # count the submitted keys and get the keys themselves
#
my %got_keys = map {($_ => 1)} $self -> {cgi_object} -> param;
my $cnt_got_keys = keys %got_keys;
and $got_keys{$formdata -> {userID} -> {name}}
)
) {
- $self -> {response} = {new_thread => 1};
+ $self -> {response} -> {new_thread} = 1;
return 1;
}
- ###################################################
# now we know, we've got a filled out form
# we do the following steps to check it:
#
# 2nd: did we get _all_ must-keys?
# check whether reply or new message request
# 3rd: did we get too many keys?
- # 4th: do _all_ requested values accord to
- # expectations?
+ # 4th: do _all_ submitted values accord to
+ # our expectations?
# fetch the "missing" keys
#
$self -> {response} -> {new}
or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') {
- $self -> {error} = {spec => 'missing_key'};
+ $self -> {error} = {
+ spec => 'missing_key',
+ type => 'fatal'
+ };
return;
}
else {
unless (exists ($name {$_})) {
$self -> {error} = {
spec => 'unexpected_key',
- desc => $name{$_}
+ desc => $name{$_},
+ type => 'fatal'
};
return;
}
# 4
#
unless ($self -> decode_param) {
- $self -> {error} = {spec => 'unknown_encoding'};
+ $self -> {error} = {
+ spec => 'unknown_encoding',
+ type => 'fatal'
+ };
return;
};
if ($self -> {response} -> {reply}) {
- # get the parent-identifiers if we got a reply
+ # get the parent-identifiers if we got a reply request
#
my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
- $self -> {error} = {spec => 'unknown_followup'};
+ $self -> {error} = {
+ spec => 'unknown_followup',
+ type => 'fatal'
+ };
return;
}
$self -> {fup_tid} = $ftid;
$self -> {fup_mid} = $fmid;
- # now fetching the missing keys
+ # fetch the missing keys
# if it fails, they're too short, too... ;)
#
$self -> fetch;
+ $got_keys{$_}=1 for (@{$self -> {fetch}});
}
# now we can check on length, type etc.
#
for (keys %got_keys) {
+ # we are sure, we've got only one value for one key
+ #
my $val = $q -> param ($_);
- $val =~ s/\302\240/ /g; # convert nbsp to normal spaces
+ $val =~ s/\302\240/ /g; # convert nbsp (UTF-8 encoded) into normal spaces
+ $val =~ s/\015\012|\015|\012/ /g # convert \n into spaces unless it's a multiline field
+ unless (
+ exists ($formdata -> {$name {$_}} -> {type})
+ and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
+ );
+
$q -> param ($_ => $val); # write it back
# too long?
if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
$self -> {error} = {
spec => 'too_long',
- desc => $name{$_}
+ desc => $name{$_},
+ type => $formdata -> {$name {$_}} -> {errorType}
};
return;
}
if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
$self -> {error} = {
spec => 'too_short',
- desc => $name{$_}
+ desc => $name{$_},
+ type => $formdata -> {$name {$_}} -> {errorType}
};
return;
}
}
-# return 'wrongMail' if ($formdata -> {$name{$_}} -> {type} eq 'email' and length ($dparam{$_}) and not is_mail_address ($dparam{$_}));
+ # check the values on expected kinds of content
+ # (email, http-url, url)
+ #
+ 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}
+ };
+ 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}
+ };
+ return;
+ }
+
+ elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
+ $self -> {error} = {
+ spec => 'wrong_url',
+ desc => $name{$_},
+ type => $formdata -> {$name {$_}} -> {errorType}
+ };
+ return;
+ }
+ }
}
# ok, looks good.
1;
}
-# delete $dparam {$formdata -> {posterURL} -> {name}}
-# unless ($dparam {$formdata -> {posterURL} -> {name}} =~ /$httpurl/);
-#
-# delete $dparam {$formdata -> {posterImage} -> {name}}
-# unless ($dparam {$formdata -> {posterImage} -> {name}} =~ /$httpurl/);
-
### sub fetch ##################################################################
#
# fetch "missing" keys from parent posting
$q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
for (@{$self -> {fetch}});
+
+ return;
}
}
}
#
$q -> param ($formdata -> {$_} -> {name} => '')
for (@{$self -> {fetch}});
+
+ return;
}
### sub decode_param ###########################################################
git.p6c8.net / selfforum.git / blobdiff