use Maypole::Config;
use Maypole::Constants;
use Maypole::Headers;
+use Maypole::Components;
use URI();
+use File::MMagic::XS qw(:compat);
our $VERSION = '2.11';
+our $mmagic = File::MMagic::XS->new();
# proposed privacy conventions:
# - no leading underscore - public to custom application code and plugins
=cut
-__PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
+__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded);
__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() );
__PACKAGE__->init_done(0);
+__PACKAGE__->model_classes_loaded(0);
+
=head1 HOOKABLE METHODS
As a framework, Maypole provides a number of B<hooks> - methods that are
You can also set the C<debug> flag via L<Maypole::Application>.
+Some packages respond to higher debug levels, try increasing it to 2 or 3.
+
+
=cut
sub debug { 0 }
foreach my $subclass ( @{ $config->classes } )
{
- no strict 'refs';
- unshift @{ $subclass . "::ISA" }, $config->model;
-
- # Load custom model code, if it exists - nb this must happen after the
- # unshift, to allow code attributes to work, but before adopt(),
- # in case adopt() calls overridden methods on $subclass
- $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/;
+ next if $subclass->isa("Maypole::Model::Base");
+ no strict 'refs';
+ unshift @{ $subclass . "::ISA" }, $config->model;
+
+ # Load custom model code, if it exists - nb this must happen after the
+ # unshift, to allow code attributes to work, but before adopt(),
+ # in case adopt() calls overridden methods on $subclass
+ $class->load_model_subclass($subclass) unless ($class->model_classes_loaded());
+
+ $config->model->adopt($subclass) if $config->model->can("adopt");
}
}
(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;
}
}
# BeerDB::handler() and so this inherited implementation will be
# found. See e.g. "Practical mod_perl" by Bekman & Cholet for
# more information <http://modperlbook.org/html/ch25_01.html>
-sub handler : method
-{
- # See Maypole::Workflow before trying to understand this.
- my ($class, $req) = @_;
+sub handler : method {
+ # See Maypole::Workflow before trying to understand this.
+ my ($class, $req) = @_;
- $class->init unless $class->init_done;
+ $class->init unless $class->init_done;
- my $self = $class->new;
+ my $self = $class->new;
- # initialise the request
- $self->headers_out(Maypole::Headers->new);
- $self->get_request($req);
- $self->parse_location;
+ # initialise the request
+ $self->headers_out(Maypole::Headers->new);
+ $self->get_request($req);
+ $self->parse_location;
- # 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();
+ # hook useful for declining static requests e.g. images, or perhaps for
+ # sanitizing request parameters
+ $self->status(Maypole::Constants::OK()); # set the default
+ $self->__call_hook('start_request_hook');
+ return $self->status unless $self->status == Maypole::Constants::OK();
- $self->session($self->get_session);
- $self->user($self->get_user);
+ die "status undefined after start_request_hook()" unless defined
+ $self->status;
- $status = $self->handler_guts;
+ $self->get_session;
+ $self->get_user;
- # moving this here causes unit test failures - need to check why
- # before committing the move
- #$status = $self->__call_process_view unless $self->output;
+ my $status = $self->handler_guts;
+ return $status unless $status == OK;
+
+ # TODO: require send_output to return a status code
+ $self->send_output;
+
+ return $status;
+}
+
+sub component {
+ my $component = Maypole::Components->new(@_);
+ return $component->handler;
+}
+
+
+# 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) = @_;
- return $status unless $status == OK;
+ my @plugins;
+ {
+ my $class = ref($self);
+ no strict 'refs';
+ @plugins = @{"$class\::ISA"};
+ }
- # TODO: require send_output to return a status code
- $self->send_output;
+ # 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;
- return $status;
+ 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
if ( my $error = $@ )
{
- $status = $self->call_exception($error);
+ $status = $self->call_exception($error, "authentication");
if ( $status != OK )
{
if ( my $error = $@ )
{
- $status = $self->call_exception($error);
+ $status = $self->call_exception($error, "model");
if ( $status != OK )
{
# less frequent path - perhaps output has been set to an error message
return OK if $self->output;
-
+
# normal path - no output has been generated yet
- return $self->__call_process_view;
+ my $processed_view_ok = $self->__call_process_view;
+
+ $self->{content_type} ||= $self->__get_mime_type();
+ $self->{document_encoding} ||= "utf-8";
+
+ return $processed_view_ok;
+}
+
+my %filetypes = (
+ 'js' => 'text/javascript',
+ 'css' => 'text/css',
+ 'htm' => 'text/html',
+ 'html' => 'text/html',
+ );
+
+sub __get_mime_type {
+ my $self = shift;
+ my $type;
+ if ($self->path =~ m/.*\.(\w{3,4})$/) {
+ $type = $filetypes{$1};
+ } else {
+ $type = $mmagic->checktype_contents($self->output);
+ }
+ return $type;
}
sub __load_request_model
if ( my $error = $@ )
{
- $status = $self->call_exception($error);
+ $status = $self->call_exception($error, "view");
if ( $status != OK )
{
=item start_request_hook
This is called immediately after setting up the basic request. The default
-method simply returns C<Maypole::Constants::OK>.
+method does nothing.
+
+The value of C<< $r->status >> is set to C<OK> 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<status>. For any
+value other than C<OK>, Maypole returns the C<status> immediately.
-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:
+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<status>
+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
my $action = $self->action;
return 1 if $self->model_class->is_public($action);
- warn "The action '$action' is not applicable to the table $table"
- if $self->debug;
+ warn "The action '$action' is not applicable to the table '$table'"
+ if $self->debug;
return 0;
}
sub call_exception
{
- my ($self, $error) = @_;
+ my ($self, $error, $when) = @_;
# Check if we have a model class with an exception() to delegate to
if ( $self->model_class && $self->model_class->can('exception') )
{
- my $status = $self->model_class->exception( $self, $error );
+ my $status = $self->model_class->exception( $self, $error, $when );
return $status if $status == OK;
}
- return $self->exception($error);
+ return $self->exception($error, $when);
}
=cut
-sub exception { return ERROR }
+sub exception {
+ my ($self, $error, $when) = @_;
+ if ($self->view_object->can("report_error") and $self->debug) {
+ $self->view_object->report_error($self, $error, $when);
+ return OK;
+ }
+ return ERROR;
+}
=item additional_data
=cut
1;
+
+__END__
+
+ =item register_cleanup($coderef)
+
+Analogous to L<Apache>'s C<register_cleanup>. 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
+C<DESTROY>ed.
+
+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: $@";
+ }
+ }
+ }
+}
+
projects / maypole.git / blobdiff