use Maypole::Constants;
use Maypole::Headers;
-our $VERSION = '2.10_pre2';
+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 __load_model
+{
+ my ($r) = @_;
+ $r->model_class( $r->config->model->class_of($r, $r->table) );
}
-sub is_applicable {
- my $self = shift;
- my $config = $self->config;
+# 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');
+
+ # 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 = $self->{path} =~ m{([^/]+)/?}g;
- $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 {