use Maypole::Constants;
use Maypole::Headers;
-our $VERSION = '2.06';
+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 template_args output path
+ qw( params query objects model_class template_args output path
args action template error document_encoding content_type table
headers_in headers_out )
);
sub debug { 0 }
-sub setup {
+sub setup
+{
my $calling_class = shift;
+
$calling_class = ref $calling_class if ref $calling_class;
- {
- no strict 'refs';
- no warnings 'redefine';
-
- # 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");
}
-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;
# Create the request object
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;
}
# The root of all evil
-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} );
- }
-
+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;
+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}).\n"
+
+ my $table = $r->table;
+
+ warn "We don't have that table ($table).\n"
. "Available tables are: "
- . join( ",", @{ $config->{display_tables} } )
- if $self->debug
- and not $config->ok_tables->{ $self->{table} }
- and $self->{action};
- return DECLINED() unless exists $config->ok_tables->{ $self->{table} };
+ . 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 $self->model_class->is_public( $self->{action} );
- return OK();
+ 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');
+
+ # if the driver ($r) and the request ($r) ever get separated out
+ # properly, then passing the request as an argument will make more sense
+ 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->{action} ||= "index";
- $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);
}
-sub param { # like CGI::param(), but read-only
- my $r = shift;
- my ($key) = @_;
- if (defined $key) {
- unless (exists $r->{params}{$key}) {
- return wantarray() ? () : undef;
- }
- my $val = $r->{params}{$key};
- if (wantarray()) {
- return ref $val ? @$val : $val;
- } else {
- return ref $val ? $val->[0] : $val;
- }
- } else {
- return keys %{$r->{params}};
- }
+# 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_template_root {'.'}
sub get_request { }
sub parse_location {
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
Maypole - MVC web application framework
This documents the Maypole request object. See the L<Maypole::Manual>, for a
detailed guide to using Maypole.
-Maypole is a Perl web application framework to Java's struts. It is
+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.
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
Simon Cozens, C<simon#cpan.org>
-Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.8 to 2.04
+Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
=head1 THANKS TO