use UNIVERSAL::require;
use strict;
use warnings;
+use Data::Dumper;
use Maypole::Config;
use Maypole::Constants;
use Maypole::Headers;
use URI();
+use URI::QueryParam;
+use NEXT;
+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
__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 status)
+ headers_in headers_out stash status parent)
);
__PACKAGE__->config( Maypole::Config->new() );
=cut
-sub debug { 0 }
+sub debug { 1 }
=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,
+ { options => { # 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;
=cut
-sub setup_model
-{
- my $class = shift;
-
- $class = ref $class if ref $class;
-
- my $config = $class->config;
-
- $config->model || $config->model('Maypole::Model::CDBI');
-
- $config->model->require or die sprintf
- "Couldn't load the model class %s: %s", $config->model, $@;
-
- # among other things, this populates $config->classes
- $config->model->setup_database($config, $class, @_);
-
- foreach my $subclass ( @{ $config->classes } )
- {
- 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");
- }
+sub setup_model {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ my $config = $class->config;
+ $config->model || $config->model('Maypole::Model::CDBI');
+ $config->model->require or die sprintf
+ "Couldn't load the model class %s: %s", $config->model, $@;
+
+ # among other things, this populates $config->classes
+ $config->model->setup_database($config, $class, @_);
+
+ foreach my $subclass ( @{ $config->classes } ) {
+ 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
+ foreach my $subclass ( @{ $config->classes } ) {
+ $class->load_model_subclass($subclass) unless ($class->model_classes_loaded());
+ $config->model->adopt($subclass) if $config->model->can("adopt");
+ }
+
}
=item load_model_subclass($subclass)
C<$subclass> package, if one exists. So if you make a customized C<BeerDB::Beer>
package, you don't need to explicitly load it.
-If, perhaps during development, you don't want to load up custom classes, you
+If automatic loading causes problems, Override load_model_subclass in your driver.
+
+sub load_model_subclass {};
+
+Or perhaps during development, if you don't want to load up custom classes, you
can override this method and load them manually.
=cut
-sub load_model_subclass
-{
- my ($class, $subclass) = @_;
-
- my $config = $class->config;
-
- # Load any external files for the model base class or subclasses
- # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from
- # Maypole::Plugin::Loader and Class::DBI.
- if ( $subclass->require )
- {
- warn "Loaded external module for '$subclass'\n" if $class->debug > 1;
- }
- else
- {
- (my $filename = $subclass) =~ s!::!/!g;
- die "Loading '$subclass' failed: $@\n"
- unless $@ =~ /Can\'t locate \Q$filename\E\.pm/;
- warn "No external module for '$subclass'"
- if $class->debug > 1;
- }
+sub load_model_subclass {
+ my ($class, $subclass) = @_;
+
+ my $config = $class->config;
+
+ # Load any external files for the model base class or subclasses
+ # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from
+ # Maypole::Plugin::Loader and Class::DBI.
+ if ( $subclass->require ) {
+ warn "Loaded external module for '$subclass'\n" if $class->debug > 1;
+ } else {
+ (my $filename = $subclass) =~ s!::!/!g;
+ die "Loading '$subclass' failed: $@\n"
+ unless $@ =~ /Can\'t locate \Q$filename\E\.pm/;
+ warn "No external module for '$subclass'"
+ if $class->debug > 1;
+ }
}
=item init
sub new
{
my ($class) = @_;
-
my $self = bless {
- template_args => {},
config => $class->config,
}, $class;
+
+ $self->stash({});
+ $self->params({});
+ $self->query({});
+ $self->template_args({});
+ $self->args([]);
+ $self->objects([]);
return $self;
}
# 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) = @_;
-
- $class->init unless $class->init_done;
+sub handler : method {
+ # See Maypole::Workflow before trying to understand this.
+ my ($class, $req) = @_;
+
+ $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 $status = $self->handler_guts;
+ return $status unless $status == OK;
+ # TODO: require send_output to return a status code
+ $self->send_output;
+ return $status;
+}
+
+=item component
+
+ Run Maypole sub-requests as a component of the request
+
+ [% request.component("/beer/view_as_component/20") %]
+
+ Allows you to integrate the results of a Maypole request into an existing
+request. You'll need to set up actions and templates
+which return fragments of HTML rather than entire pages, but once you've
+done that, you can use the C<component> method of the Maypole request object
+to call those actions. You may pass a query string in the usual URL style.
+
+You should not fully qualify the Maypole URLs.
+
+Note: any HTTP POST or URL parameters passed to the parent are not passed to the
+component sub-request, only what is included in the url passed as an argyument
+to the method
+
+=cut
+
+sub component {
+ my ( $r, $path ) = @_;
+ my $self = bless { parent => $r, config => $r->{config}, } , ref $r;
+ $self->stash({});
+ $self->params({});
+ $self->query({});
+ $self->template_args({});
+ $self->args([]);
+ $self->objects([]);
- 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 $status = $self->handler_guts;
- return $status unless $status == OK;
-
- # TODO: require send_output to return a status code
- $self->send_output;
+ my $url = URI->new($path);
+ warn "path : $path\n";
+ $self->{path} = $url->path;
+ $self->parse_path;
+ $self->params( $url->query_form_hash );
+ $self->handler_guts;
+ return $self->output;
+}
- return $status;
+sub get_template_root {
+ my $self = shift;
+ my $r = shift;
+ return $r->parent->get_template_root if $r->{parent};
+ return $self->NEXT::DISTINCT::get_template_root( $r, @_ );
+}
+
+sub view_object {
+ my $self = shift;
+ my $r = shift;
+ return $r->parent->view_object if $r->{parent};
+ return $self->NEXT::DISTINCT::view_object( $r, @_ );
}
# Instead of making plugin authors use the NEXT::DISTINCT hoopla to ensure other
$self->__load_request_model;
- my $applicable = $self->is_model_applicable;
-
- $self->__setup_plain_template unless $applicable;
+ my $applicable = $self->is_model_applicable == OK;
my $status;
+ # handle authentication
eval { $status = $self->call_authenticate };
-
if ( my $error = $@ )
{
$status = $self->call_exception($error, "authentication");
-
if ( $status != OK )
{
warn "caught authenticate error: $error";
$self->view_object->error($self, $error) : ERROR;
}
}
-
if ( $self->debug and $status != OK and $status != DECLINED )
{
$self->view_object->error( $self,
"Got unexpected status $status from calling authentication" );
}
-
+
return $status unless $status == OK;
# We run additional_data for every request
$self->additional_data;
-
- if ($applicable)
- {
- eval { $self->model_class->process($self) };
-
- if ( my $error = $@ )
+
+ if ($applicable) {
+ eval { $self->model_class->process($self) };
+ if ( my $error = $@ )
{
- $status = $self->call_exception($error, "model");
-
- if ( $status != OK )
+ $status = $self->call_exception($error, "model");
+ if ( $status != OK )
{
- warn "caught model error: $error";
- return $self->debug ?
- $self->view_object->error($self, $error) : ERROR;
+ warn "caught model error: $error";
+ return $self->debug ?
+ $self->view_object->error($self, $error) : ERROR;
}
}
+ } else {
+ $self->__setup_plain_template;
}
-
+
# 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 = 'text/html';
+ if ($self->path =~ m/.*\.(\w{3,4})$/) {
+ $type = $filetypes{$1};
+ } else {
+ my $output = $self->output;
+ if (defined $output) {
+ $type = $mmagic->checktype_contents($output);
+ }
+ }
+ return $type;
}
sub __load_request_model
{
my ($self) = @_;
- $self->model_class( $self->config->model->class_of($self, $self->table) );
+ # We may get a made up class from class_of
+ my $mclass = $self->config->model->class_of($self, $self->table);
+ if ( eval {$mclass->isa('Maypole::Model::Base')} ) {
+ $self->model_class( $mclass );
+ }
+ elsif ($self->debug) {
+ warn "***Warning: No $mclass class appropriate for model. @_";
+ }
}
+
# is_applicable() returned false, so set up a plain template. Model processing
# will be skipped, but need to remove the model anyway so the template can't
# access it.
sub __setup_plain_template
{
my ($self) = @_;
-
+
# It's just a plain template
$self->model_class(undef);
# The model has been processed or skipped (if is_applicable returned false),
# any exceptions have been handled, and there's no content in $self->output
-sub __call_process_view
-{
- my ($self) = @_;
-
- my $status;
-
- eval { $status = $self->view_object->process($self) };
-
- if ( my $error = $@ )
- {
- $status = $self->call_exception($error, "view");
-
- if ( $status != OK )
- {
- warn "caught view error: $error" if $self->debug;
- return $self->debug ?
- $self->view_object->error($self, $error) : ERROR;
- }
+sub __call_process_view {
+ my ($self) = @_;
+
+ my $status = eval { $self->view_object->process($self) };
+
+ my $error = $@ || $self->{error};
+
+ if ( $error ) {
+ $status = $self->call_exception($error, "view");
+
+ if ( $status != OK ) {
+ warn "caught view error: $error" if $self->debug;
+ return $self->debug ?
+ $self->view_object->error($self, $error) : ERROR;
}
-
- return $status;
+ }
+
+ return $status;
}
=item get_request
Returns a Maypole::Constant to indicate whether the request is valid.
+=cut
+
+sub is_applicable { return shift->is_model_applicable(@_); }
+
=item is_model_applicable
Returns true or false to indicate whether the request is valid.
=cut
-sub is_model_applicable
-{
+sub is_model_applicable {
my ($self) = @_;
-
- # cater for applications that are using obsolete version
- if ($self->can('is_applicable'))
- {
- warn "DEPRECATION WARNING: rewrite is_applicable to the interface ".
- "of Maypole::is_model_applicable\n";
- return $self->is_applicable == OK;
- }
# Establish which tables should be processed by the model
my $config = $self->config;
. join( ",", keys %$ok_tables )
if $self->debug and not $ok_tables->{$table};
- return 0;
+ return DECLINED;
}
# Is the action public?
my $action = $self->action;
- return 1 if $self->model_class->is_public($action);
+ return OK 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;
+ return DECLINED;
}
=item get_session
sub exception {
my ($self, $error, $when) = @_;
- if ($self->view_object->can("report_error") and $self->debug) {
+ if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) {
$self->view_object->report_error($self, $error, $when);
return OK;
}
}
-
-
=back
=head2 Path processing and manipulation
sub parse_path
{
my ($self) = @_;
-
+
# Previous versions unconditionally set table, action and args to whatever
# was in @pi (or else to defaults, if @pi is empty).
# Adding preprocess_path(), and then setting table, action and args
# conditionally, broke lots of tests, hence this:
$self->$_(undef) for qw/action table args/;
-
$self->preprocess_path;
$self->path || $self->path('frontpage');
=cut
-sub get_template_root {'.'}
-
=back
=head2 Request properties
class, it will be removed from C<args> and the retrieved object will be added to
the C<objects> list. See L<Maypole::Model> for more information.
+
+=item object
+
+Alias to get/set the first/only model object. The object will be accessible
+in the view templates.
+
+When used to set the object, will overwrite the request objects
+with a single object.
+
+=cut
+
+sub object {
+ my ($r,$object) = @_;
+ $r->objects([$object]) if ($object);
+ return undef unless $r->objects();
+ return $r->objects->[0];
+}
+
=item template_args
$self->template_args->{foo} = 'bar';
=item stash
-A place to put custom application data. Not used by Maypole itself.
+A place to put custom application data. Not used by Maypole itself.
=item template
=head1 AUTHOR
-Maypole is currently maintained by Aaron Trevena, David Baird, Dave Howorth and
-Peter Speltz.
+Maypole is currently maintained by Aaron Trevena.
=head1 AUTHOR EMERITUS