package Maypole;
use base qw(Class::Accessor::Fast Class::Data::Inheritable);
-use attributes ();
use UNIVERSAL::require;
use strict;
use warnings;
use Maypole::Config;
-our $VERSION = "1.8";
+use Maypole::Constants;
+use Maypole::Headers;
+
+our $VERSION = '2.10';
+
+# proposed privacy conventions:
+# - no leading underscore - public to custom application code and plugins
+# - single leading underscore - private to the main Maypole stack - *not* including plugins
+# - double leading underscore - private to the current package
+
__PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
__PACKAGE__->mk_accessors(
- qw( ar params query objects model_class
- args action template )
+ qw( params query objects model_class template_args output path
+ args action template error document_encoding content_type table
+ headers_in headers_out )
);
__PACKAGE__->config( Maypole::Config->new() );
__PACKAGE__->init_done(0);
-use Maypole::Constants;
sub debug { 0 }
-sub setup {
+sub setup
+{
my $calling_class = shift;
+
$calling_class = ref $calling_class if ref $calling_class;
- {
- no strict 'refs';
-
- # Naughty.
- *{ $calling_class . "::handler" } =
- sub { Maypole::handler( $calling_class, @_ ) };
- }
+
my $config = $calling_class->config;
- $config->model || $config->model("Maypole::Model::CDBI");
- $config->model->require;
- die "Couldn't load the model class $config->model: $@" if $@;
- $config->model->setup_database( $config, $calling_class, @_ );
- for my $subclass ( @{ $config->classes } ) {
+
+ $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)
}
}
-sub init {
+sub init
+{
my $class = shift;
my $config = $class->config;
$config->view || $config->view("Maypole::View::TT");
$config->view->require;
- die "Couldn't load the view class ".$config->view.": $@" if $@;
- $config->display_tables || $config->display_tables([ $class->config->tables ]);
+ die "Couldn't load the view class " . $config->view . ": $@" if $@;
+ $config->display_tables
+ || $config->display_tables( $class->config->tables );
$class->view_object( $class->config->view->new );
$class->init_done(1);
}
-sub handler {
-
+# handler() has a method attribute so that mod_perl will invoke
+# BeerDB->handler() as a method rather than a plain function
+# 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 ) = @_;
+ my ($class, $req) = @_;
+
$class->init unless $class->init_done;
- my $r = bless { config => $class->config }, $class;
+
+ # Create the request object
+ my $r = bless {
+ template_args => {},
+ config => $class->config
+ }, $class;
+
+ $r->headers_out(Maypole::Headers->new);
+
$r->get_request($req);
- $r->parse_location();
- my $status = $r->handler_guts();
+
+ $r->parse_location;
+
+ my $status = $r->handler_guts;
+
+ # moving this here causes unit test failures - need to check why
+ # before committing the move
+ #$status = $r->__call_process_view unless $r->output;
+
return $status unless $status == OK;
+
$r->send_output;
+
return $status;
}
-sub handler_guts {
- my $r = shift;
- $r->model_class( $r->config->model->class_of( $r, $r->{table} ) );
- my $applicable = $r->is_applicable;
- unless ( $applicable == OK ) {
-
- # It's just a plain template
- delete $r->{model_class};
- $r->{path} =~ s{/$}{}; # De-absolutify
- $r->template( $r->{path} );
- }
-
+# The root of all evil
+sub handler_guts
+{
+ my ($r) = @_;
+
+ $r->__load_model;
+
+ my $applicable = __to_boolean $r->is_applicable;
+
+ $r->__setup_plain_template unless $applicable;
+
# We authenticate every request, needed for proper session management
my $status;
+
eval { $status = $r->call_authenticate };
- if ( my $error = $@ ) {
+
+ if ( my $error = $@ )
+ {
$status = $r->call_exception($error);
- if ( $status != OK ) {
+
+ if ( $status != OK )
+ {
warn "caught authenticate error: $error";
- return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+ return $r->debug ? $r->view_object->error($r, $error) : ERROR;
}
}
- if ( $r->debug and $status != OK and $status != DECLINED ) {
+
+ if ( $r->debug and $status != OK and $status != DECLINED )
+ {
$r->view_object->error( $r,
"Got unexpected status $status from calling authentication" );
}
+
return $status unless $status == OK;
# We run additional_data for every request
$r->additional_data;
- if ( $applicable == OK ) {
+
+ if ($applicable)
+ {
eval { $r->model_class->process($r) };
- if ( my $error = $@ ) {
+
+ if ( my $error = $@ )
+ {
$status = $r->call_exception($error);
- if ( $status != OK ) {
+
+ if ( $status != OK )
+ {
warn "caught model error: $error";
- return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+ return $r->debug ? $r->view_object->error($r, $error) : ERROR;
}
}
}
- if ( !$r->{output} ) { # You might want to do it yourself
- eval { $status = $r->view_object->process($r) };
- if ( my $error = $@ ) {
- $status = $r->call_exception($error);
- if ( $status != OK ) {
- warn "caught view error: $error" if $r->debug;
- return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
- }
+
+ # unusual path - perhaps output has been set to an error message
+ return OK if $r->output;
+
+ # normal path - no output has been generated yet
+ return $r->__call_process_view;
+}
+
+# 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 ($r) = @_;
+
+ # It's just a plain template
+ $r->model_class(undef);
+
+ my $path = $r->path;
+ $path =~ s{/$}{}; # De-absolutify
+ $r->path($path);
+
+ $r->template($r->path);
+}
+
+# The model has been processed or skipped (if is_applicable returned false),
+# any exceptions have been handled, and there's no content in $r->output
+sub __call_process_view
+{
+ my ($r) = @_;
+
+ my $status;
+
+ eval { $status = $r->view_object->process($r) };
+
+ if ( my $error = $@ )
+ {
+ $status = $r->call_exception($error);
+
+ if ( $status != OK )
+ {
+ warn "caught view error: $error" if $r->debug;
+ return $r->debug ? $r->view_object->error($r, $error) : ERROR;
}
- return $status;
}
- else { return OK; }
+
+ return $status;
}
-sub is_applicable {
- my $self = shift;
- my $config = $self->config;
- $config->ok_tables || $config->ok_tables($config->display_tables);
- $config->ok_tables ({ map { $_ => 1 } @{ $config->ok_tables } })
+sub __load_model
+{
+ my ($r) = @_;
+ $r->model_class( $r->config->model->class_of($r, $r->table) );
+}
+
+# is_applicable() should return true or false, not OK or DECLINED, because
+# the return value is never used as the return value from handler(). There's
+# probably a lot of code out there supplying the return codes though, so instead
+# of changing is_applicable() to return 0 or 1, the return value is passed through
+# __to_boolean. I think it helps handler_guts() if we don't have multiple sets of
+# return codes being checked for different things.
+sub is_applicable
+{
+ my ($r) = @_;
+
+ my $config = $r->config;
+
+ $config->ok_tables || $config->ok_tables( $config->display_tables );
+
+ $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } )
if ref $config->ok_tables eq "ARRAY";
- warn "We don't have that table ($self->{table})"
- if $self->debug
- and not $config->ok_tables->{ $self->{table} };
- return DECLINED() unless exists $config->ok_tables->{ $self->{table} };
-
- # Does the action method exist?
- my $cv = $self->model_class->can( $self->{action} );
- warn "We don't have that action ($self->{action})"
- if $self->debug and not $cv;
- return DECLINED() unless $cv;
-
- # Is it exported?
- $self->{method_attribs} = join " ", attributes::get($cv);
- do {
- warn "$self->{action} not exported" if $self->debug;
- return DECLINED();
- } unless $self->{method_attribs} =~ /\bExported\b/i;
- return OK();
+
+ my $table = $r->table;
+
+ warn "We don't have that table ($table).\n"
+ . "Available tables are: "
+ . join( ",", @{ $config->display_tables } )
+ if $r->debug
+ and not $config->ok_tables->{$table}
+ and $r->action; # I think this is always true
+
+ return DECLINED unless exists $config->ok_tables->{$table};
+
+ # Is it public?
+ return DECLINED unless $r->model_class->is_public( $r->action );
+
+ return OK;
}
-sub call_authenticate {
- my $self = shift;
+# *only* intended for translating the return code from is_applicable()
+sub __to_boolean ($) { $_[0] == OK ? 1 : 0 }
+
+
+
+sub call_authenticate
+{
+ my ($r) = @_;
# Check if we have a model class
- if ( $self->{model_class} ) {
- return $self->model_class->authenticate($self)
- if $self->model_class->can("authenticate");
- }
- return $self->authenticate($self); # Interface consistency is a Good Thing
+ return $r->model_class->authenticate($r)
+ if $r->model_class
+ and $r->model_class->can('authenticate');
+
+ # passing $r is unnecessary and redundant, but there's probably
+ # a lot of code out there now using the 2nd instead of the 1st $r,
+ # so we may as well leave it
+ return $r->authenticate($r);
}
-sub call_exception {
- my $self = shift;
- my ($error) = @_;
+sub call_exception
+{
+ my ($r, $error) = @_;
# Check if we have a model class
- if ( $self->{model_class}
- && $self->model_class->can('exception') )
+ if ( $r->model_class && $r->model_class->can('exception') )
{
- my $status = $self->model_class->exception( $self, $error );
+ my $status = $r->model_class->exception( $r, $error );
return $status if $status == OK;
}
- return $self->exception($error);
+
+ return $r->exception($error);
}
sub additional_data { }
sub exception { return ERROR }
-sub parse_path {
- my $self = shift;
- $self->{path} ||= "frontpage";
- my @pi = split /\//, $self->{path};
- shift @pi while @pi and !$pi[0];
- $self->{table} = shift @pi;
- $self->{action} = shift @pi;
- $self->{args} = \@pi;
+sub parse_path
+{
+ my ($r) = @_;
+
+ $r->path || $r->path('frontpage');
+
+ my @pi = grep {length} split '/', $r->path;
+
+ $r->table(shift @pi);
+
+ $r->action( shift @pi or 'index' );
+
+ $r->args(\@pi);
+}
+
+# like CGI::param(), but read only
+sub param
+{
+ my ($r, $key) = @_;
+
+ return keys %{$r->params} unless defined $key;
+
+ return unless exists $r->params->{$key};
+
+ my $val = $r->params->{$key};
+
+ return ref $val ? @$val : ($val) if wantarray;
+
+ return ref $val ? $val->[0] : $val;
+}
+
+sub get_template_root {'.'}
+sub get_request { }
+
+sub parse_location {
+ die "Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+sub send_output {
+ die "Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+# Session and Repeat Submission Handling
+
+sub make_random_id {
+ use Maypole::Session;
+ return Maypole::Session::generate_unique_id();
}
=head1 NAME
=head1 SYNOPSIS
-See L<Maypole>.
+See L<Maypole::Application>.
=head1 DESCRIPTION
-A large number of web programming tasks follow the same sort of pattern:
-we have some data in a datasource, typically a relational database. We
-have a bunch of templates provided by web designers. We have a number of
-things we want to be able to do with the database - create, add, edit,
-delete records, view records, run searches, and so on. We have a web
-server which provides input from the user about what to do. Something in
-the middle takes the input, grabs the relevant rows from the database,
-performs the action, constructs a page, and spits it out.
-
-Maypole aims to be the most generic and extensible "something in the
-middle" - an MVC-based web application framework.
-
-An example would help explain this best. You need to add a product
-catalogue to a company's web site. Users need to list the products in
-various categories, view a page on each product with its photo and
-pricing information and so on, and there needs to be a back-end where
-sales staff can add new lines, change prices, and delete out of date
-records. So, you set up the database, provide some default templates
-for the designers to customize, and then write an Apache handler like
-this:
-
- package ProductDatabase;
- use base 'Maypole::Application';
- __PACKAGE__->set_database("dbi:mysql:products");
- ProductDatabase->config->uri_base = "http://your.site/catalogue/";
- ProductDatabase::Product->has_a("category" => ProductDatabase::Category);
- # ...
-
- sub authenticate {
- my ($self, $request) = @_;
- return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com";
- return OK if $request->{action} =~ /^(view|list)$/;
- return DECLINED;
- }
- 1;
+This documents the Maypole request object. See the L<Maypole::Manual>, for a
+detailed guide to using Maypole.
-You then put the following in your Apache config:
+Maypole is a Perl web application framework similar to Java's struts. It is
+essentially completely abstracted, and so doesn't know anything about
+how to talk to the outside world.
- <Location /catalogue>
- SetHandler perl-script
- PerlHandler ProductDatabase
- </Location>
+To use it, you need to create a package which represents your entire
+application. In our example above, this is the C<BeerDB> package.
-And copy the templates found in F<templates/factory> into the
-F<catalogue/factory> directory off the web root. When the designers get
-back to you with custom templates, they are to go in
-F<catalogue/custom>. If you need to do override templates on a
-database-table-by-table basis, put the new template in
-F<catalogue/I<table>>.
+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>, and then call 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.)
-This will automatically give you C<add>, C<edit>, C<list>, C<view> and
-C<delete> commands; for instance, a product list, go to
+=head2 CLASS METHODS
- http://your.site/catalogue/product/list
+=head3 config
-For a full example, see the included "beer database" application.
+Returns the L<Maypole::Config> object
-=head1 HOW IT WORKS
+=head3 setup
-There's some documentation for the workflow in L<Maypole::Workflow>,
-but the basic idea is that a URL part like C<product/list> gets
-translated into a call to C<ProductDatabase::Product-E<gt>list>. This
-propagates the request with a set of objects from the database, and then
-calls the C<list> template; first, a C<product/list> template if it
-exists, then the C<custom/list> and finally C<factory/list>.
+ My::App->setup($data_source, $user, $password, \%attr);
-If there's another action you want the system to do, you need to either
-subclass the model class, and configure your class slightly differently:
+Initialise the maypole application and model classes. Your application should
+call this after setting configuration via L<"config">
- package ProductDatabase::Model;
- use base 'Maypole::Model::CDBI';
+=head3 init
- sub supersearch :Exported {
- my ($self, $request) = @_;
- # Do stuff, get a bunch of objects back
- $r->objects(\@objects);
- $r->template("template_name");
- }
+You should not call this directly, but you may wish to override this to
+add
+application-specific initialisation.
-Then your top-level application package should change the model class:
-(Before calling C<setup>)
+=head3 view_object
- ProductDatabase->config->model("ProductDatabase::Model");
+Get/set the Maypole::View object
-(The C<:Exported> attribute means that the method can be called via the
-URL C</I<table>/supersearch/...>.)
+=head3 debug
-Alternatively, you can put the method directly into the specific model
-class for the table:
+ sub My::App::debug {1}
- sub ProductDatabase::Product::supersearch :Exported { ... }
+Returns the debugging flag. Override this in your application class to
+enable/disable debugging.
-By default, the view class uses Template Toolkit as the template
-processor, and the model class uses C<Class::DBI>; it may help you to be
-familiar with these modules before going much further with this,
-although I expect there to be other subclasses for other templating
-systems and database abstraction layers as time goes on. The article at
-C<http://www.perl.com/pub/a/2003/07/15/nocode.html> is a great
-introduction to the process we're trying to automate.
+=head2 INSTANCE METHODS
-=head1 USING MAYPOLE
+=head3 parse_location
-You should probably not use Maypole directly. Maypole is an abstract
-class which does not specify how to communicate with the outside world.
-The most popular subclass of Maypole is L<Apache::MVC>, which interfaces
-the Maypole framework to Apache mod_perl; another important one is
-L<CGI::Maypole>. However, if you just don't care, use Maypole::Application,
-and it will choose the right one for you.
+Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a
+Maypole
+request. It does this by setting the C<path>, and invoking C<parse_path>
+and
+C<parse_args>.
-If you are implementing Maypole subclasses, you need to provide at least
-the C<parse_location> and C<send_output> methods. You may also want to
-provide C<get_request> and C<get_template_root>. See the
-L<Maypole::Workflow> documentation for what these are expected to do.
+You should only need to define this method if you are writing a new
+Maypole
+backend.
-=cut
+=head3 path
-sub get_template_root { "." }
-sub get_request { }
+Returns the request path
-sub parse_location {
- die "Do not use Maypole directly; use Apache::MVC or similar";
-}
+=head3 parse_path
-sub send_output {
- die "Do not use Maypole directly; use Apache::MVC or similar";
-}
+Parses the request path and sets the C<args>, C<action> and C<table>
+properties
-=head1 SEE ALSO
+=head3 table
+
+The table part of the Maypole request path
+
+=head3 action
+
+The action part of the Maypole request path
+
+=head3 args
-There's more documentation, examples, and a wiki at the Maypole web site:
+A list of remaining parts of the request path after table and action
+have been
+removed
-http://maypole.simon-cozens.org/
+=head3 headers_in
-L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
+A L<Maypole::Headers> object containing HTTP headers for the request
-=head1 MAINTAINER
+=head3 headers_out
-Sebastian Riedel, c<sri@oook.de>
+A L<HTTP::Headers> object that contains HTTP headers for the output
+
+=head3 parse_args
+
+Turns post data and query string paramaters into a hash of C<params>.
+
+You should only need to define this method if you are writing a new
+Maypole
+backend.
+
+=head3 param
+
+An accessor for request parameters. It behaves similarly to CGI::param() for
+accessing CGI parameters.
+
+=head3 params
+
+Returns a hash of request parameters. The source of the parameters may vary
+depending on the Maypole backend, but they are usually populated from request
+query string and POST data.
+
+B<Note:> Where muliple values of a parameter were supplied, the
+C<params>
+value
+will be an array reference.
+
+=head3 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">
+
+=head3 get_request
+
+You should only need to define this method if you are writing a new
+Maypole backend. It should return something that looks like an Apache
+or CGI request object, it defaults to blank.
+
+
+=head3 is_applicable
+
+Returns a Maypole::Constant to indicate whether the request is valid.
+
+The default implementation checks that C<$r-E<gt>table> is publicly
+accessible
+and that the model class is configured to handle the C<$r-E<gt>action>
+
+=head3 authenticate
+
+Returns a Maypole::Constant to indicate whether the user is
+authenticated for
+the Maypole request.
+
+The default implementation returns C<OK>
+
+=head3 model_class
+
+Returns the perl package name that will serve as the model for the
+request. It corresponds to the request C<table> attribute.
+
+=head3 additional_data
+
+Called before the model processes the request, this method gives you a
+chance
+to do some processing for each request, for example, manipulating
+C<template_args>.
+
+=head3 objects
+
+Get/set a list of model objects. The objects will be accessible in the
+view
+templates.
+
+If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
+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.
+
+=head3 template_args
+
+ $r->template_args->{foo} = 'bar';
+
+Get/set a hash of template variables.
+
+=head3 template
+
+Get/set the template to be used by the view. By default, it returns
+C<$r-E<gt>action>
+
+=head3 exception
+
+This method is called if any exceptions are raised during the
+authentication
+or
+model/view processing. It should accept the exception as a parameter and
+return
+a Maypole::Constant to indicate whether the request should continue to
+be
+processed.
+
+=head3 error
+
+Get/set a request error
+
+=head3 output
+
+Get/set the response output. This is usually populated by the view
+class. You
+can skip view processing by setting the C<output>.
+
+=head3 document_encoding
+
+Get/set the output encoding. Default: utf-8.
+
+=head3 content_type
+
+Get/set the output content type. Default: text/html
+
+=head3 send_output
+
+Sends the output and additional headers to the user.
+
+=head3 call_authenticate
+
+This method first checks if the relevant model class
+can authenticate the user, or falls back to the default
+authenticate method of your Maypole application.
+
+
+=head3 call_exception
+
+This model is called to catch exceptions, first after authenticate, then after
+processing the model class, and finally to check for exceptions from the view
+class.
+
+This method first checks if the relevant model class
+can handle exceptions the user, or falls back to the default
+exception method of your Maypole application.
+
+=head3 make_random_id
+
+returns a unique id for this request can be used to prevent or detect repeat submissions.
+
+=head3 handler
+
+This method sets up the class if it's not done yet, sets some
+defaults and leaves the dirty work to handler_guts.
+
+=head3 handler_guts
+
+This is the core of maypole. You don't want to know.
+
+=head1 SEE ALSO
+
+There's more documentation, examples, and a information on our mailing lists
+at the Maypole web site:
+
+L<http://maypole.perl.org/>
+
+L<Maypole::Application>, L<Apache::MVC>, L<CGI::Maypole>.
=head1 AUTHOR
-Simon Cozens, C<simon@cpan.org>
+Maypole is currently maintained by Simon Flack C<simonflk#cpan.org>
+
+=head1 AUTHOR EMERITUS
+
+Simon Cozens, C<simon#cpan.org>
+
+Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
-=head1 THANK YOU
+=head1 THANKS TO
-Jesse Scheidlower, Jody Belka, Marcus Ramberg, Mickael Joanne, Simon Flack,
+Sebastian Riedel, Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka,
+Marcus Ramberg, Mickael Joanne, Randal Schwartz, Simon Flack, Steve Simms,
Veljko Vidovic and all the others who've helped.
=head1 LICENSE