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
__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
=cut
-sub debug { 0 }
+sub debug { 0 }
=item config
=item setup
- My::App->setup($data_source, $user, $password, \%attr);
-
-Initialise the Maypole application and plugins and model classes - see
-L<Maypole::Manual::Plugins>.
-
-If your model is based on L<Maypole::Model::CDBI>, the C<\%attr> hashref can
-contain options that are passed directly to L<Class::DBI::Loader>, to control
-how the model hierarchy is constructed.
+ My::App->setup($data_source, $user, $password, \%attr);
+Initialise the Maypole application and plugins and model classes.
Your application should call this B<after> setting up configuration data via
L<"config">.
+It calls the hook C<setup_model> to setup the model. The %attr hash contains
+options and arguments used to set up the model. See the particular model's
+documentation. However here is the most usage of setup where
+Maypole::Model::CDBI is the base class.
+
+ My::App->setup($data_source, $user, $password,
+ { opitons => { # These are DB connection options
+ AutoCommit => 0,
+ RaiseError => 1,
+ ...
+ },
+ # These are Class::DBI::Loader arguments.
+ relationships => 1,
+ ...
+ }
+ );
+
+Also, see L<Maypole::Manual::Plugins>.
+
=cut
+
sub setup
{
my $class = shift;
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");
+ 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");
}
}
# 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;
-
- # 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
- $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->get_session;
- $self->get_user;
+ my $self = $class->new;
- my $status = $self->handler_guts;
+ # initialise the request
+ $self->headers_out(Maypole::Headers->new);
+ $self->get_request($req);
+ $self->parse_location;
- # moving this here causes unit test failures - need to check why
- # before committing the move
- #$status = $self->__call_process_view unless $self->output;
+ # 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();
- return $status unless $status == OK;
+ die "status undefined after start_request_hook()" unless defined
+ $self->status;
- # TODO: require send_output to return a status code
- $self->send_output;
+ $self->get_session;
+ $self->get_user;
- return $status;
+ 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 ($r,$path) = @_;
+ my $component = Maypole::Components->new(@_);
+ return $component->handler($path);
+}
+
+
# 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
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 )
{
return 1 if $self->model_class->is_public($action);
warn "The action '$action' is not applicable to the table '$table'"
- if $self->debug;
+ 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