From: Sebastian Riedel Date: Thu, 16 Sep 2004 09:49:33 +0000 (+0000) Subject: Added exception handling X-Git-Tag: 2.10~179 X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=commitdiff_plain;h=4b37444fc8ad176ede57c571eff0e6aefd712d0e Added exception handling git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@183 48953598-375a-da11-a14b-00016c27c3ee --- diff --git a/Changes b/Changes index ac6493a..30353b9 100644 --- a/Changes +++ b/Changes @@ -1,13 +1,14 @@ Revision history for Perl extension Maypole -1.8 XXX XXX XX XX:XX:XX XXX XXXX +2.0 XXX XXX XX XX:XX:XX XXX XXXX - Added parse_args() (Simon Flack) - call additional_data() and authenticate() for plain templates - merged Apache2::MVC (mod_perl2 support) into Apache::MVC - - added Maypole::Application universal loader + - added Maypole::Application universal front-end - config parameter handling for Maypole::Model::CDBI - $r->{query} is now deprecated, use $r->{params} for GET and POST - fixed multiple value handling (Simon Flack) + - added exception handling (Simon Flack) 1.7 Sat Jul 17 20:15:26 BST 2004 - Emergency release - we lost the "use Maypole::Constants" from diff --git a/lib/Maypole.pm b/lib/Maypole.pm index b18aac3..4a5a8e7 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -6,9 +6,11 @@ use strict; use warnings; our $VERSION = "1.8"; __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( ar params query objects model_class -args action template )); -__PACKAGE__->config({}); +__PACKAGE__->mk_accessors( + qw( ar params query objects model_class + args action template ) +); +__PACKAGE__->config( {} ); __PACKAGE__->init_done(0); use Maypole::Constants; @@ -18,36 +20,39 @@ sub setup { my $calling_class = shift; $calling_class = ref $calling_class if ref $calling_class; { - no strict 'refs'; - # Naughty. - *{$calling_class."::handler"} = sub { Maypole::handler($calling_class, @_) }; + no strict 'refs'; + + # Naughty. + *{ $calling_class . "::handler" } = + sub { Maypole::handler( $calling_class, @_ ) }; } my $config = $calling_class->config; $config->{model} ||= "Maypole::Model::CDBI"; $config->{model}->require; die "Couldn't load the model class $config->{model}: $@" if $@; - $config->{model}->setup_database($config, $calling_class, @_); - for my $subclass (@{$config->{classes}}) { + $config->{model}->setup_database( $config, $calling_class, @_ ); + for my $subclass ( @{ $config->{classes} } ) { no strict 'refs'; - unshift @{$subclass."::ISA"}, $config->{model}; + unshift @{ $subclass . "::ISA" }, $config->{model}; $config->{model}->adopt($subclass) - if $config->{model}->can("adopt"); + if $config->{model}->can("adopt"); } } sub init { - my $class = shift; + my $class = shift; my $config = $class->config; - $config->{view} ||= "Maypole::View::TT"; + $config->{view} ||= "Maypole::View::TT"; $config->{view}->require; die "Couldn't load the view class $config->{view}: $@" if $@; - $config->{display_tables} ||= [ @{$class->config->{tables}} ]; - $class->view_object($class->config->{view}->new); + $config->{display_tables} ||= [ @{ $class->config->{tables} } ]; + $class->view_object( $class->config->{view}->new ); $class->init_done(1); } sub handler { + # See Maypole::Workflow before trying to understand this. my ( $class, $req ) = @_; $class->init unless $class->init_done; @@ -62,77 +67,107 @@ sub handler { sub handler_guts { my $r = shift; - $r->model_class($r->config->{model}->class_of($r, $r->{table})); + $r->model_class( $r->config->{model}->class_of( $r, $r->{table} ) ); my $applicable = $r->is_applicable; - unless ($applicable == OK) { + unless ( $applicable == OK ) { + # It's just a plain template delete $r->{model_class}; - $r->{path} =~ s{/$}{}; # De-absolutify - $r->template($r->{path}); + $r->{path} =~ s{/$}{}; # De-absolutify + $r->template( $r->{path} ); } + # We authenticate every request, needed for proper session management my $status = $r->call_authenticate; - if ($r->debug and $status != OK and $status != DECLINED) { - $r->view_object->error($r, - "Got unexpected status $status from calling authentication"); + if ( $r->debug and $status != OK and $status != DECLINED ) { + $r->view_object->error( $r, + "Got unexpected status $status from calling authentication" ); } return $status unless $status == OK; + # We run additional_data for every request $r->additional_data; - if ($applicable == OK) { - $r->model_class->process($r); + if ( $applicable == OK ) { + eval { $r->model_class->process($r) }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught model error: $error"; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } } - if (!$r->{output}) { # You might want to do it yourself + if ( !$r->{output} ) { # You might want to do it yourself return $r->view_object->process($r); - } else { return OK; } + } + else { return OK; } } sub is_applicable { - my $self = shift; + my $self = shift; my $config = $self->config; $config->{ok_tables} ||= $config->{display_tables}; - $config->{ok_tables} = {map {$_=>1} @{$config->{ok_tables}}} - if ref $config->{ok_tables} eq "ARRAY"; + $config->{ok_tables} = { map { $_ => 1 } @{ $config->{ok_tables} } } + if ref $config->{ok_tables} eq "ARRAY"; warn "We don't have that table ($self->{table})" - if $self->debug and not $config->{ok_tables}{$self->{table}}; - return DECLINED() unless exists $config->{ok_tables}{$self->{table}}; + if $self->debug + and not $config->{ok_tables}{ $self->{table} }; + return DECLINED() unless exists $config->{ok_tables}{ $self->{table} }; # Does the action method exist? - my $cv = $self->model_class->can($self->{action}); - warn "We don't have that action ($self->{action})" - if $self->debug and not $cv; + my $cv = $self->model_class->can( $self->{action} ); + warn "We don't have that action ($self->{action})" + if $self->debug and not $cv; return DECLINED() unless $cv; # Is it exported? $self->{method_attribs} = join " ", attributes::get($cv); - do { warn "$self->{action} not exported" if $self->debug; - return DECLINED() - } unless $self->{method_attribs} =~ /\bExported\b/i; + do { + warn "$self->{action} not exported" if $self->debug; + return DECLINED(); + } unless $self->{method_attribs} =~ /\bExported\b/i; return OK(); } sub call_authenticate { my $self = shift; + # Check if we have a model class - if ($self->{model_class}) { - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); + if ( $self->{model_class} ) { + return $self->model_class->authenticate($self) + if $self->model_class->can("authenticate"); } - return $self->authenticate($self); # Interface consistency is a Good Thing + return $self->authenticate($self); # Interface consistency is a Good Thing } -sub additional_data {} +sub call_exception { + my $self = shift; + my ($error) = @_; + + # Check if we have a model class + if ( $self->{model_class} + && $self->model_class->can('exception') ) + { + my $status = $self->model_class->exception( $self, $error ); + return $status if $status == OK; + } + return $self->exception($error); +} + +sub additional_data { } sub authenticate { return OK } +sub exception { return ERROR } + sub parse_path { my $self = shift; $self->{path} ||= "frontpage"; my @pi = split /\//, $self->{path}; shift @pi while @pi and !$pi[0]; - $self->{table} = shift @pi; + $self->{table} = shift @pi; $self->{action} = shift @pi; - $self->{args} = \@pi; + $self->{args} = \@pi; } =head1 NAME @@ -261,9 +296,15 @@ L documentation for what these are expected to do. =cut sub get_template_root { "." } -sub get_request { } -sub parse_location { die "Do not use Maypole directly; use Apache::MVC or similar" } -sub send_output{ die "Do not use Maypole directly; use Apache::MVC or similar" } +sub get_request { } + +sub parse_location { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} + +sub send_output { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} =head1 SEE ALSO