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 $VERSION = '2.13';
+our $mmagic = File::MMagic::XS->new();
# proposed privacy conventions:
# - no leading underscore - public to custom application code and plugins
=head1 SYNOPSIS
-See L<Maypole::Application>.
+The canonical example used in the Maypole documentation is the beer database:
+
+ package BeerDB;
+ use strict;
+ use warnings;
+
+ # choose a frontend, initialise the config object, and load a plugin
+ use Maypole::Application qw/Relationship/;
+
+ # set everything up
+ __PACKAGE__->setup("dbi:SQLite:t/beerdb.db");
+
+ # get the empty config object created by Maypole::Application
+ my $config = __PACKAGE__->config;
+
+ # basic settings
+ $config->uri_base("http://localhost/beerdb");
+ $config->template_root("/path/to/templates");
+ $config->rows_per_page(10);
+ $config->display_tables([qw/beer brewery pub style/]);
+
+ # table relationships
+ $config->relationships([
+ "a brewery produces beers",
+ "a style defines beers",
+ "a pub has beers on handpumps",
+ ]);
+
+ # validation
+ BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] );
+ BeerDB::Pub->untaint_columns( printable => [qw/name notes url/] );
+ BeerDB::Style->untaint_columns( printable => [qw/name notes/] );
+ BeerDB::Beer->untaint_columns(
+ printable => [qw/abv name price notes/],
+ integer => [qw/style brewery score/],
+ date => [ qw/date/],
+ );
+
+ # note : set up model before calling this method
+ BeerDB::Beer->required_columns([qw/name/]);
+
+ 1;
=head1 DESCRIPTION
This needs to first use L<Maypole::Application> which will make your package
inherit from the appropriate platform driver such as C<Apache::MVC> or
-C<CGI::Maypole>. Then, the driver calls C<setup>. This sets up the model classes and
-configures your application. The default model class for Maypole uses
+C<CGI::Maypole>. Then, the driver calls C<setup>. This sets up the model classes
+and configures your application. The default model class for Maypole uses
L<Class::DBI> to map a database to classes, but this can be changed by altering
configuration (B<before> calling setup.)
Note that some details in some of these resources may be out of date.
-=over 4
+=over 4
=item The Maypole Manual
=item Web applications with Maypole
A tutorial written by Simon Cozens for YAPC::EU 2005 -
-http://www.droogs.org/perl/maypole/maypole-tutorial.pdf [228KB].
+http://www.aarontrevena.co.uk/opensource/maypole/maypole-tutorial.pdf [228KB].
=item A Database-Driven Web Application in 18 Lines of Code
=item Authentication
Some notes written by Simon Cozens. A little bit out of date, but still
-very useful: http://www.droogs.org/perl/maypole/authentication.html
+very useful: http://www.aarontrevena.co.uk/opensource/maypole/authentication.html
=item CheatSheet
=back
-=head1 DEMOS
+=cut
-A couple of demos are available, sometimes with source code and configs.
+__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded);
-=over 4
+__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 parent build_form_elements
+ user session)
+);
-=item http://maypole.perl.org/beerdb/
+__PACKAGE__->config( Maypole::Config->new({additional => { }, request_options => { }, view_options => { },}) );
-The standard BeerDB example, using the TT factory templates supplied in the
-distribution.
+__PACKAGE__->init_done(0);
-=item beerdb.riverside-cms.co.uk
+__PACKAGE__->model_classes_loaded(0);
-The standard BeerDB example, running on Mason, using the factory templates
-supplied in the L<MasonX::Maypole> distribution.
+=head1 HOOKABLE METHODS
-=item beerfb.riverside-cms.co.uk
+As a framework, Maypole provides a number of B<hooks> - methods that are
+intended to be overridden. Some of these methods come with useful default
+behaviour, others do nothing by default. Hooks include:
-A demo of L<Maypole::FormBuilder>. This site is running on the set of Mason
-templates included in the L<Maypole::FormBuilder> distribution. See the
-synopsis of L<Maypole::Plugin::FormBuilder> for an example driver
+ Class methods
+ -------------
+ debug
+ setup
+ setup_model
+ load_model_subclass
+ init
+
+ Instance methods
+ ----------------
+ start_request_hook
+ is_model_applicable
+ get_session
+ authenticate
+ exception
+ additional_data
+ preprocess_path
-=back
+=head1 CLASS METHODS
-=cut
+=over 4
-__PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
+=item debug
-__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)
-);
+ sub My::App::debug {1}
-__PACKAGE__->config( Maypole::Config->new() );
+Returns the debugging flag. Override this in your application class to
+enable/disable debugging.
-__PACKAGE__->init_done(0);
+You can also set the C<debug> flag via L<Maypole::Application>.
-=head1 CLASS METHODS
+Some packages respond to higher debug levels, try increasing it to 2 or 3.
-=over 4
+
+=cut
+
+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,
+ { 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;
A likely target for over-riding, if you need to build a customised model.
+This method also ensures any code in custom model classes is loaded, so you
+don't need to load them in the driver.
+
=cut
-sub setup_model
-{
- my $calling_class = shift;
-
- $calling_class = ref $calling_class if ref $calling_class;
-
- my $config = $calling_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, $@;
-
- $config->model->setup_database($config, $calling_class, @_);
-
- foreach my $subclass ( @{ $config->classes } )
- {
- no strict 'refs';
- unshift @{ $subclass . "::ISA" }, $config->model;
- $config->model->adopt($subclass)
- if $config->model->can("adopt");
-
- # TODO: I think we should also load these classes, in case there is any
- # custom code. It would save the developer from needing to put
- # lots of use MyApp::SomeTable statements in the driver, and should
- # help eliminate some of those annoying silent errors if there's a
- # syntax error.
- }
+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, @_);
+
+ $config->model->add_model_superclass($config);
+
+ # Load custom model code, if it exists - nb this must happen after the
+ # adding the model superclass, 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)
+
+This method is called from C<setup_model()>. It attempts to load the
+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 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;
+ }
}
=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;
}
Get/set the Maypole::View object
-=item debug
-
- sub My::App::debug {1}
-
-Returns the debugging flag. Override this in your application class to
-enable/disable debugging.
-
-You can also set the C<debug> flag via L<Maypole::Application>.
-
-=cut
-
-sub debug { 0 }
-
-=item get_template_root
-
-Implementation-specific path to template root.
-
-You should only need to define this method if you are writing a new Maypole
-backend. Otherwise, see L<Maypole::Config/"template_root">
-
-=cut
-
-sub get_template_root {'.'}
-
=back
=head1 INSTANCE METHODS
# 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
- my $status = $self->start_request_hook;
- return $status unless $status == Maypole::Constants::OK();
+ 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;
+
+ my $session = $self->get_session;
+ $self->session($self->{session} || $session);
+ my $user = $self->get_user;
+ $self->user($self->{user} || $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 argument
+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([]);
+
$self->session($self->get_session);
+ $self->user($self->get_user);
+
+ my $url = URI->new($path);
+ $self->{path} = $url->path;
+ $self->parse_path;
+ $self->params( $url->query_form_hash );
+ $self->handler_guts;
+ return $self->output;
+}
+
+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
+# 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) = @_;
- $status = $self->handler_guts;
-
- # moving this here causes unit test failures - need to check why
- # before committing the move
- #$status = $self->__call_process_view unless $self->output;
-
- 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
This is the main request handling method and calls various methods to handle the
request/response and defines the workflow within Maypole.
-B<Currently undocumented and liable to be refactored without warning>.
-
=cut
# The root of all evil
-sub handler_guts
-{
- my ($self) = @_;
-
- $self->__load_model;
+sub handler_guts {
+ my ($self) = @_;
+ $self->build_form_elements(1) unless (defined ($self->config->build_form_elements) && $self->config->build_form_elements == 0);
+ $self->__load_request_model;
+
+ 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 ) {
+ $self->warn("caught authenticate error: $error");
+ return $self->debug ?
+ $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;
+
+ # process request with model if applicable and template not set.
+ if ($applicable) {
+ unless ($self->{template}) {
+ eval { $self->model_class->process($self) };
+ if ( my $error = $@ ) {
+ $status = $self->call_exception($error, "model");
+ if ( $status != OK ) {
+ $self->warn("caught model error: $error");
+ return $self->debug ?
+ $self->view_object->error($self, $error) : ERROR;
+ }
+ }
+ }
+ } else {
+ $self->__setup_plain_template;
+ }
- my $applicable = $self->is_model_applicable;
-
- $self->__setup_plain_template unless $applicable;
+ # less frequent path - perhaps output has been set to an error message
+ if ($self->output) {
+ $self->{content_type} ||= $self->__get_mime_type();
+ $self->{document_encoding} ||= "utf-8";
+ return OK;
+ }
- my $status;
+ # normal path - no output has been generated yet
+ my $processed_view_ok = $self->__call_process_view;
- eval { $status = $self->call_authenticate };
-
- if ( my $error = $@ )
- {
- $status = $self->call_exception($error);
-
- if ( $status != OK )
- {
- warn "caught authenticate error: $error";
- return $self->debug ?
- $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;
+ $self->{content_type} ||= $self->__get_mime_type();
+ $self->{document_encoding} ||= "utf-8";
- # We run additional_data for every request
- $self->additional_data;
-
- if ($applicable)
- {
- eval { $self->model_class->process($self) };
-
- if ( my $error = $@ )
- {
- $status = $self->call_exception($error);
-
- if ( $status != OK )
- {
- warn "caught model error: $error";
- return $self->debug ?
- $self->view_object->error($self, $error) : ERROR;
- }
- }
+ 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{2,4})$/) {
+ $type = $filetypes{$1};
+ } else {
+ my $output = $self->output;
+ if (defined $output) {
+ $type = $mmagic->checktype_contents($output);
}
-
- # 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;
+ }
+ return $type;
}
-sub __load_model
+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 > 1) {
+ $self->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->build_form_elements(0);
$self->model_class(undef);
-
- my $path = $self->path;
- $path =~ s{/$}{}; # De-absolutify
- $self->path($path);
-
- $self->template($self->path);
+
+ unless ($self->template) {
+ # FIXME: this is likely to be redundant and is definately causing problems.
+ my $path = $self->path;
+ $path =~ s{/$}{}; # De-absolutify
+ $self->path($path);
+ $self->template($self->path);
+ }
}
# 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);
-
- 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 warn
+
+$r->warn('its all gone pete tong');
+
+Warn must be implemented by the backend, i.e. Apache::MVC
+and warn to stderr or appropriate logfile.
+
+You can also over-ride this in your Maypole driver, should you
+want to use something like Log::Log4perl instead.
+
+=cut
+
+sub warn { }
+
+=item build_form_elements
+
+$r->build_form_elements(0);
+
+Specify (in an action) whether to build HTML form elements and populate
+the cgi element of classmetadata in the view.
+
+You can set this globally using the accessor of the same name in Maypole::Config,
+this method allows you to over-ride that setting per action.
+
+=cut
+
=item get_request
You should only need to define this method if you are writing a new
=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
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;
if (not $ok)
{
- warn "We don't have that table ($table).\n"
+ $self->warn ("We don't have that table ($table).\n"
. "Available tables are: "
- . join( ",", keys %$ok_tables )
+ . 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;
+ $self->warn("The action '$action' is not applicable to the table '$table'")
+ if $self->debug;
- return 0;
+ return DECLINED;
}
=item get_session
+Called immediately after C<start_request_hook()>.
+
+This method should return a session, which will be stored in the request's
+C<session> attribute.
+
The default method is empty.
=cut
sub get_session { }
+=item get_user
+
+Called immediately after C<get_session>.
+
+This method should return a user, which will be stored in the request's C<user>
+attribute.
+
+The default method is empty.
+
+=cut
+
+sub get_user {}
+
=item call_authenticate
This method first checks if the relevant model class
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);
}
+
=item exception
This method is called if any exceptions are raised during the authentication or
=cut
-sub exception { return ERROR }
+sub exception {
+ my ($self, $error, $when) = @_;
+ if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) {
+ $self->view_object->report_error($self, $error, $when);
+ return OK;
+ }
+ return ERROR;
+}
=item additional_data
}
-
-=item redirect_request
-
-Sets output headers to redirect based on the arguments provided
-
-Accepts either a single argument of the full url to redirect to, or a hash of
-named parameters :
-
-$r->redirect_request('http://www.example.com/path');
-
-or
-
-$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
-
-The named parameters are protocol, domain, path, status and url
-
-Only 1 named parameter is required but other than url, they can be combined as
-required and current values (from the request) will be used in place of any
-missing arguments. The url argument must be a full url including protocol and
-can only be combined with status.
-
-=cut
-
-sub redirect_request {
- die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
-}
-
-=item redirect_internal_request
-
-=cut
-
-sub redirect_internal_request {
-
-}
-
=back
=head2 Path processing and manipulation
=cut
-sub parse_path
-{
+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');
-
+ # use frontpage template for frontpage
+ unless ($self->path && $self->path ne '/') {
+ $self->path('frontpage');
+ }
+
my @pi = grep {length} split '/', $self->path;
-
+
$self->table || $self->table(shift @pi);
$self->action || $self->action( shift @pi or 'index' );
$self->args || $self->args(\@pi);
=item preprocess_path
Sometimes when you don't want to rewrite or over-ride parse_path but
-want to rewrite urls or extract data from them before it is parsed.
+want to rewrite urls or extract data from them before it is parsed,
+the preprocess_path/location methods allow you to munge paths and urls
+before maypole maps them to actions, classes, etc.
This method is called after parse_location has populated the request
information and before parse_path has populated the model and action
information, and is passed the request object.
You can set action, args or table in this method and parse_path will
-then leave those values in place or populate them if not present
+then leave those values in place or populate them based on the current
+value of the path attribute if they are not present.
=cut
sub preprocess_path { };
+=item preprocess_location
+
+This method is called at the start of parse_location, after the headers in, and allows you
+to rewrite the url used by maypole, or dynamically set configuration
+like the base_uri based on the hostname or path.
+
+=cut
+
+sub preprocess_location { };
+
=item make_path( %args or \%args or @args )
This is the counterpart to C<parse_path>. It generates a path to use
=cut
+
sub make_path
{
my $r = shift;
You should only need to define this method if you are writing a new Maypole
backend.
+=cut
+
+sub parse_args
+{
+ die "parse_args() is a virtual method. Do not use Maypole directly; ".
+ "use Apache::MVC or similar";
+}
+
+=item get_template_root
+
+Implementation-specific path to template root.
+
+You should only need to define this method if you are writing a new Maypole
+backend. Otherwise, see L<Maypole::Config/"template_root">
+
+=cut
+
=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';
Get/set a hash of template variables.
+Maypole reserved words for template variables will over-ride values in template_variables.
+
+Reserved words are : r, request, object, objects, base, config and errors, as well as the
+current class or object name.
+
=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
$self->params->{$key} = $new_val;
}
- return ref $val ? @$val : ($val) if wantarray;
+ return (ref $val eq 'ARRAY') ? @$val : ($val) if wantarray;
- return ref $val ? $val->[0] : $val;
+ return (ref $val eq 'ARRAY') ? $val->[0] : $val;
}
Alias for C<params>.
+=back
+
+=head3 Utility methods
+
+=over 4
+
+=item redirect_request
+
+Sets output headers to redirect based on the arguments provided
+
+Accepts either a single argument of the full url to redirect to, or a hash of
+named parameters :
+
+$r->redirect_request('http://www.example.com/path');
+
+or
+
+$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
+
+The named parameters are protocol, domain, path, status and url
+
+Only 1 named parameter is required but other than url, they can be combined as
+required and current values (from the request) will be used in place of any
+missing arguments. The url argument must be a full url including protocol and
+can only be combined with status.
+
+=cut
+
+sub redirect_request {
+ die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+# =item redirect_internal_request
+#
+# =cut
+#
+# sub redirect_internal_request {
+#
+# }
+
+
=item make_random_id
returns a unique id for this request can be used to prevent or detect repeat
=back
+=head1 SEQUENCE DIAGRAMS
+
+See L<Maypole::Manual::Workflow> for a detailed discussion of the sequence of
+calls during processing of a request. This is a brief summary:
+
+ INITIALIZATION
+ Model e.g.
+ BeerDB Maypole::Model::CDBI
+ | |
+ setup | |
+ o-------->|| |
+ || setup_model | setup_database() creates
+ ||------+ | a subclass of the Model
+ |||<----+ | for each table
+ ||| | |
+ ||| setup_database | |
+ |||--------------------->|| 'create' *
+ ||| ||----------> $subclass
+ ||| | |
+ ||| load_model_subclass | |
+ foreach |||------+ ($subclass) | |
+ $subclass ||||<----+ | require |
+ ||||--------------------------------------->|
+ ||| | |
+ ||| adopt($subclass) | |
+ |||--------------------->|| |
+ | | |
+ | | |
+ |-----+ init | |
+ ||<---+ | |
+ || | new | view_object: e.g.
+ ||---------------------------------------------> Maypole::View::TT
+ | | | |
+ | | | |
+ | | | |
+ | | | |
+ | | | |
+
+
+
+ HANDLING A REQUEST
+
+
+ BeerDB Model $subclass view_object
+ | | | |
+ handler | | | |
+ o-------->| new | | |
+ |-----> r:BeerDB | | |
+ | | | | |
+ | | | | |
+ | || | | |
+ | ||-----+ parse_location | | |
+ | |||<---+ | | |
+ | || | | |
+ | ||-----+ start_request_hook | | |
+ | |||<---+ | | |
+ | || | | |
+ | ||-----+ get_session | | |
+ | |||<---+ | | |
+ | || | | |
+ | ||-----+ get_user | | |
+ | |||<---+ | | |
+ | || | | |
+ | ||-----+ handler_guts | | |
+ | |||<---+ | | |
+ | ||| class_of($table) | | |
+ | |||------------------------->|| | |
+ | ||| $subclass || | |
+ | |||<-------------------------|| | |
+ | ||| | | |
+ | |||-----+ is_model_applicable| | |
+ | ||||<---+ | | |
+ | ||| | | |
+ | |||-----+ call_authenticate | | |
+ | ||||<---+ | | |
+ | ||| | | |
+ | |||-----+ additional_data | | |
+ | ||||<---+ | | |
+ | ||| process | | |
+ | |||--------------------------------->|| fetch_objects
+ | ||| | ||-----+ |
+ | ||| | |||<---+ |
+ | ||| | || |
+ | ||| | || $action
+ | ||| | ||-----+ |
+ | ||| | |||<---+ |
+ | ||| process | | |
+ | |||------------------------------------------->|| template
+ | ||| | | ||-----+
+ | ||| | | |||<---+
+ | ||| | | |
+ | || send_output | | |
+ | ||-----+ | | |
+ | |||<---+ | | |
+ $status | || | | |
+ <------------------|| | | |
+ | | | | |
+ | X | | |
+ | | | |
+ | | | |
+ | | | |
+
+
+
=head1 SEE ALSO
-There's more documentation, examples, and a information on our mailing lists
+There's more documentation, examples, and information on our mailing lists
at the Maypole web site:
L<http://maypole.perl.org/>
=head1 AUTHOR
-Maypole is currently maintained by Aaron Trevena
+Maypole is currently maintained by Aaron Trevena.
=head1 AUTHOR EMERITUS
Simon Cozens, C<simon#cpan.org>
+Simon Flack maintained Maypole from 2.05 to 2.09
+
Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
=head1 THANKS TO
=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