X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=blobdiff_plain;f=lib%2FMaypole.pm;h=dbae33be3580d65f667d6e79044ef9b30ca94634;hp=087f2b9daae744671f8cf3af72cd4886531edab8;hb=12d8a77a713d5ed4f08414e5f34e96d45f60e2d3;hpb=f4a654d5fee1b79ced98bb6d71a4f3b4bf402ecd diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 087f2b9..dbae33b 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -199,7 +199,7 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path args action template error document_encoding content_type table - headers_in headers_out stash session user) + headers_in headers_out stash status) ); __PACKAGE__->config( Maypole::Config->new() ); @@ -243,6 +243,9 @@ enable/disable debugging. You can also set the C flag via L. +Some packages respond to higher debug levels, try increasing it to 2 or 3. + + =cut sub debug { 0 } @@ -312,10 +315,6 @@ sub setup_model $class->load_model_subclass($subclass); $config->model->adopt($subclass) if $config->model->can("adopt"); - -# eval "use $subclass"; -# die "Error loading $subclass: $@" -# if $@ and $@ !~ /Can\'t locate \S+ in \@INC/; } } @@ -348,7 +347,7 @@ sub load_model_subclass (my $filename = $subclass) =~ s!::!/!g; die "Loading '$subclass' failed: $@\n" unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; - warn "Did not find external module for '$subclass'\n" + warn "No external module for '$subclass'" if $class->debug > 1; } } @@ -433,13 +432,17 @@ sub handler : method # hook useful for declining static requests e.g. images, or perhaps for # sanitizing request parameters - my $status = $self->start_request_hook; - return $status unless $status == Maypole::Constants::OK(); + $self->status(Maypole::Constants::OK()); # set the default + $self->__call_hook('start_request_hook'); + return $self->status unless $self->status == Maypole::Constants::OK(); + + die "status undefined after start_request_hook()" unless defined + $self->status; - $self->session($self->get_session); - $self->user($self->get_user); + $self->get_session; + $self->get_user; - $status = $self->handler_guts; + my $status = $self->handler_guts; # moving this here causes unit test failures - need to check why # before committing the move @@ -453,6 +456,39 @@ sub handler : method return $status; } +# Instead of making plugin authors use the NEXT::DISTINCT hoopla to ensure other +# plugins also get to call the hook, we can cycle through the application's +# @ISA and call them all here. Doesn't work for setup() though, because it's +# too ingrained in the stack. We could add a run_setup() method, but we'd break +# lots of existing code. +sub __call_hook +{ + my ($self, $hook) = @_; + + my @plugins; + { + my $class = ref($self); + no strict 'refs'; + @plugins = @{"$class\::ISA"}; + } + + # this is either a custom method in the driver, or the method in the 1st + # plugin, or the 'null' method in the frontend (i.e. inherited from + # Maypole.pm) - we need to be careful to only call it once + my $first_hook = $self->can($hook); + $self->$first_hook; + + my %seen = ( $first_hook => 1 ); + + # @plugins includes the frontend + foreach my $plugin (@plugins) + { + next unless my $plugin_hook = $plugin->can($hook); + next if $seen{$plugin_hook}++; + $self->$plugin_hook; + } +} + =item handler_guts This is the main request handling method and calls various methods to handle the @@ -602,23 +638,45 @@ sub parse_location =item start_request_hook This is called immediately after setting up the basic request. The default -method simply returns C. +method does nothing. -Any other return value causes Maypole to abort further processing of the -request. This is useful for filtering out requests for static files, e.g. -images, which should not be processed by Maypole or by the templating engine: +The value of C<< $r->status >> is set to C before this hook is run. Your +implementation can change the status code, or leave it alone. + +After this hook has run, Maypole will check the value of C. For any +value other than C, Maypole returns the C immediately. + +This is useful for filtering out requests for static files, e.g. images, which +should not be processed by Maypole or by the templating engine: sub start_request_hook { my ($r) = @_; - return Maypole::Constants::DECLINED if $r->path =~ /\.jpg$/; - return Maypole::Constants::OK; + $r->status(DECLINED) if $r->path =~ /\.jpg$/; } + +Multiple plugins, and the driver, can define this hook - Maypole will call all +of them. You should check for and probably not change any non-OK C +value: + package Maypole::Plugin::MyApp::SkipFavicon; + + sub start_request_hook + { + my ($r) = @_; + + # check if a previous plugin has already DECLINED this request + # - probably unnecessary in this example, but you get the idea + return unless $r->status == OK; + + # then do our stuff + $r->status(DECLINED) if $r->path =~ /favicon\.ico/; + } + =cut -sub start_request_hook { Maypole::Constants::OK } +sub start_request_hook { } =item is_applicable @@ -684,7 +742,7 @@ sub is_model_applicable my $action = $self->action; return 1 if $self->model_class->is_public($action); - warn "The action '$action' is not applicable to the table $table" + warn "The action '$action' is not applicable to the table '$table'" if $self->debug; return 0; @@ -1328,3 +1386,55 @@ You may distribute this code under the same terms as Perl itself. =cut 1; + +__END__ + + =item register_cleanup($coderef) + +Analogous to L's C. If an Apache request object is +available, this call simply redispatches there. If not, the cleanup is +registered in the Maypole request, and executed when the request is +Ced. + +This method is only useful in persistent environments, where you need to ensure +that some code runs when the request finishes, no matter how it finishes (e.g. +after an unexpected error). + + =cut + +{ + my @_cleanups; + + sub register_cleanup + { + my ($self, $cleanup) = @_; + + die "register_cleanup() is an instance method, not a class method" + unless ref $self; + die "Cleanup must be a coderef" unless ref($cleanup) eq 'CODE'; + + if ($self->can('ar') && $self->ar) + { + $self->ar->register_cleanup($cleanup); + } + else + { + push @_cleanups, $cleanup; + } + } + + sub DESTROY + { + my ($self) = @_; + + while (my $cleanup = shift @_cleanups) + { + eval { $cleanup->() }; + if ($@) + { + warn "Error during request cleanup: $@"; + } + } + } +} +