summaryrefslogtreecommitdiff
path: root/lib/TUWF.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/TUWF.pm')
-rw-r--r--lib/TUWF.pm149
1 files changed, 100 insertions, 49 deletions
diff --git a/lib/TUWF.pm b/lib/TUWF.pm
index 4d95135..1c67ab3 100644
--- a/lib/TUWF.pm
+++ b/lib/TUWF.pm
@@ -331,6 +331,9 @@ sub _handle_request {
my $start = [Time::HiRes::gettimeofday()] if $self->debug || $OBJ->{_TUWF}{log_slow_pages};
+ $self->{_TUWF}{captures_pos} = [];
+ $self->{_TUWF}{captures_named} = {};
+
# put everything in an eval to catch any error, even
# those caused by a TUWF core module
my $eval = eval {
@@ -345,15 +348,7 @@ sub _handle_request {
);
# initialize request
- my $err = $self->reqInit();
- if($err) {
- warn "Client sent non-UTF-8-encoded data. Generating HTTP 400 response.\n" if $err eq 'utf8';
- warn "Client sent an invalid JSON object. Generating HTTP 400 response.\n" if $err eq 'json';
- $self->{_TUWF}{error_400_handler}->($self) if $err eq 'utf8' || $err eq 'json';
- $self->{_TUWF}{error_405_handler}->($self) if $err eq 'method';
- $self->{_TUWF}{error_413_handler}->($self) if $err eq 'maxpost';
- return 1;
- }
+ $self->reqInit();
# make sure our DB connection is still there and start a new transaction
$self->dbCheck() if $self->{_TUWF}{db_login};
@@ -363,31 +358,40 @@ sub _handle_request {
# run 'before' hooks
for (@{$self->{_TUWF}{hooks}{before}}) {
- return 1 if !$_->();
+ my $ok = eval { $_->(); 1; };
+ next if $ok;
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ return 1 if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
}
# find the handler
my $loc = sprintf '%s %s', $self->reqMethod(), $self->reqPath();
study $loc;
- my $han = $self->{_TUWF}{error_404_handler};
- $self->{_TUWF}{captures_pos} = [];
- $self->{_TUWF}{captures_named} = {};
+ my $han = 0;
my $handlers = $self->{_TUWF}{route_handlers};
for (@$handlers ? 0..$#$handlers/2 : ()) {
if($loc =~ $handlers->[$_*2]) {
+ $han = 1;
$self->{_TUWF}{captures_pos} = [
map defined $-[$_] ? substr $loc, $-[$_], $+[$_]-$-[$_] : undef, 1..$#-
];
$self->{_TUWF}{captures_named} = { %+ };
- $han = $handlers->[$_*2+1];
- last;
+
+ my $ok = eval { $handlers->[$_*2+1]->($self); 1 };
+ last if $ok;
+ ($han = 0, next) if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ last if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
}
}
- # execute handler
- $han->($self);
+ die TUWF::Exception->new(404) if !$han;
- # execute post request handler, if any
+ # execute post request handler, if any (no need to bother doing this if the
+ # handler threw a TUWF::Exception like with the after hooks. The
+ # post_request_handler is deprecated and that mechanism didn't exist back
+ # then anyway).
$self->{_TUWF}{post_request_handler}->($self) if $self->{_TUWF}{post_request_handler};
1;
};
@@ -395,7 +399,13 @@ sub _handle_request {
# always run 'after' hooks
my $cleanup = eval {
- $_->() for (@{$self->{_TUWF}{hooks}{after}});
+ for (@{$self->{_TUWF}{hooks}{after}}) {
+ my $ok = eval { $_->(); 1 };
+ next if $ok;
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'pass';
+ next if ref $@ eq 'TUWF::Exception' && ${$@} eq 'done';
+ die $@;
+ }
1;
};
my $cleanuperr = $@;
@@ -410,35 +420,7 @@ sub _handle_request {
my $commiterr = $@;
# error handling
- if(!$eval || !$cleanup || !$commit) {
- chomp( my $err = $evalerr || $cleanuperr || $commiterr );
-
- # act as if the changes to the DB never happened
- warn $@ if $self->{_TUWF}{db_login} && !eval { $self->dbRollBack; 1 };
-
- # Call the error_500_handler
- # The handler should manually call dbCommit if it makes any changes to the DB
- my $eval500 = eval {
- $self->resInit;
- $self->{_TUWF}{error_500_handler}->($self, $err);
- 1;
- };
- if(!$eval500) {
- chomp( my $m = $@ );
- warn "Error handler died as well, something is seriously wrong with your code. ($m)\n";
- TUWF::_error_500($self, $err);
- }
-
- # write detailed information about this error to the log
- $self->log(
- "FATAL ERROR!\n".
- "HTTP Request Headers:\n".
- join('', map sprintf(" %s: %s\n", $_, $self->reqHeader($_)), $self->reqHeader).
- "POST dump:\n".
- join('', map sprintf(" %s: %s\n", $_, join "\n ", $self->reqPosts($_)), $self->reqPosts).
- "Error:\n $err\n"
- );
- }
+ $self->_handle_error($evalerr || $cleanuperr || $commiterr) if !$eval || !$cleanup || !$commit;
# finalize response (flush output, etc)
warn $@ if !eval { $self->resFinish; 1 };
@@ -459,6 +441,57 @@ sub _handle_request {
}
+sub _handle_error {
+ my($self, $err) = @_;
+ my $terr = ref $err eq 'TUWF::Exception' ? $$err : '';
+
+ # act as if the changes to the DB never happened
+ warn $@ if $self->{_TUWF}{db_login} && !eval { $self->dbRollBack; 1 };
+
+ warn "Client sent non-UTF-8-encoded data. Generating HTTP 400 response.\n" if $terr eq 'utf8';
+ warn "Client sent control characters in strings. Generating HTTP 400 response.\n" if $terr eq 'controlchar';
+ warn "Client sent an invalid JSON object. Generating HTTP 400 response.\n" if $terr eq 'json';
+
+ my $han = {
+ utf8 => 400,
+ json => 400,
+ controlchar => 400,
+ 404 => 404,
+ method => 405,
+ maxpost => 413,
+ }->{$terr} || '500';
+
+ my $ok = eval {
+ $self->resInit;
+ $self->{_TUWF}{"error_${han}_handler"}->($self, $err);
+ 1;
+ };
+ if(!$ok) {
+ $err = $@;
+ $ok = eval {
+ $self->resInit;
+ $self->{_TUWF}{error_500_handler}->($self, $err);
+ 1;
+ };
+ }
+ if(!$ok) {
+ $err = $@;
+ warn "Error handler died as well, something is seriously wrong with your code. ($err)\n";
+ TUWF::_error_500($self, $err);
+ }
+
+ # If this is an unexpected error, write detailed information to the log
+ $self->log(
+ "FATAL ERROR!\n".
+ "HTTP Request Headers:\n".
+ join('', map sprintf(" %s: %s\n", $_, $self->reqHeader($_)), $self->reqHeader).
+ "POST dump:\n".
+ join('', map sprintf(" %s: %s\n", $_, join "\n ", $self->reqPosts($_)), $self->reqPosts).
+ "Error:\n $err\n"
+ ) if ref $err ne 'TUWF::Exception';
+}
+
+
# convenience function
sub debug {
return shift->{_TUWF}{debug};
@@ -497,6 +530,16 @@ sub log {
}
+sub pass {
+ die TUWF::Exception->new('pass');
+}
+
+
+sub done {
+ die TUWF::Exception->new('done');
+}
+
+
# Minimal subclass of HTTP::Server::Simple with CGI environment variables.
package TUWF::http;
@@ -517,5 +560,13 @@ sub handler {
};
-1;
+
+# Objects for die() (just blessed strings)
+package TUWF::Exception;
+
+use overload '""' => sub { "TUWF::Exception: ${$_[0]}" };
+
+sub new { bless \"$_[1]", $_[0] }
+
+1;