use Maypole::Constants;
use Maypole::Headers;
-our $VERSION = '2.09';
+our $VERSION = '2.11';
+
+# 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 )
+ headers_in headers_out stash)
);
__PACKAGE__->config( Maypole::Config->new() );
__PACKAGE__->init_done(0);
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 {
+sub new
+{
+ my ($class) = @_;
+
+ my $self = bless {
+ template_args => {},
+ config => $class->config,
+ }, $class;
+
+ return $self;
+}
+# 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
- 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();
+ my $self = $class->new;
+
+ # initialise the request
+ $self->headers_out(Maypole::Headers->new);
+ $self->get_request($req);
+ $self->parse_location;
+
+ my $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;
- $r->send_output;
+
+ $self->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 ($self) = @_;
+
+ $self->__load_model;
+
+ my $applicable = __to_boolean( $self->is_applicable );
+
+ $self->__setup_plain_template unless $applicable;
+
# We authenticate every request, needed for proper session management
my $status;
- eval { $status = $r->call_authenticate };
- if ( my $error = $@ ) {
- $status = $r->call_exception($error);
- if ( $status != OK ) {
+
+ eval { $status = $self->call_authenticate };
+
+ if ( my $error = $@ )
+ {
+ $status = $self->call_exception($error);
+
+ if ( $status != OK )
+ {
warn "caught authenticate error: $error";
- return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+ return $self->debug ?
+ $self->view_object->error($self, $error) : ERROR;
}
}
- if ( $r->debug and $status != OK and $status != DECLINED ) {
- $r->view_object->error( $r,
+
+ 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
- $r->additional_data;
- if ( $applicable == OK ) {
- eval { $r->model_class->process($r) };
- if ( my $error = $@ ) {
- $status = $r->call_exception($error);
- if ( $status != OK ) {
+ $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 $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+ return $self->debug ?
+ $self->view_object->error($self, $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;
- }
+
+ # 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;
+}
+
+# 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);
+
+ 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;
}
- return $status;
}
- else { return OK; }
+
+ return $status;
+}
+
+sub __load_model
+{
+ my ($self) = @_;
+ $self->model_class( $self->config->model->class_of($self, $self->table) );
}
-sub is_applicable {
- my $self = shift;
+# 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 -drb.
+sub is_applicable
+{
+ my ($self) = @_;
+
my $config = $self->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"
- . "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} };
+ if ref $config->ok_tables eq "ARRAY";
+
+ my $table = $self->table;
+
+ warn "We don't have that table ($table).\n"
+ . "Available tables are: "
+ . join( ",", @{ $config->ok_tables } )
+ if $self->debug
+ and not $config->ok_tables->{$table}
+ and $self->action; # this is probably always true
+
+ return DECLINED unless exists $config->ok_tables->{$table};
+
+ my $path_is_ok = 0;
+ if (exists $config->ok_tables->{ $self->{table} }) {
+ $path_is_ok = 1;
+ } else {
+ if ( $self->_have_default_table_view ) {
+ my $path_is_ok = $self->default_table_view($self->{path},$self->{args});
+ }
+ unless ($path_is_ok) {
+ warn "We don't have that table ($self->{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 $path_is_ok;
# Is it public?
- return DECLINED unless $self->model_class->is_public( $self->{action} );
- return OK();
+ return DECLINED unless $self->model_class->is_public($self->action);
+
+ return OK;
}
-sub call_authenticate {
- my $self = shift;
-
- # 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
+# *only* intended for translating the return code from is_applicable()
+sub __to_boolean { $_[0] == OK ? 1 : 0 }
+
+sub call_authenticate
+{
+ my ($self) = @_;
+
+ # Check if we have a model class with an authenticate() to delegate to
+ return $self->model_class->authenticate($self)
+ if $self->model_class and $self->model_class->can('authenticate');
+
+ # Interface consistency is a Good Thing -
+ # the invocant and the argument may one day be different things
+ # (i.e. controller and request), like they are when authenticate()
+ # is called on a model class (i.e. model and request)
+ return $self->authenticate($self);
}
-sub call_exception {
- my $self = shift;
- my ($error) = @_;
+sub call_exception
+{
+ my ($self, $error) = @_;
- # Check if we have a model class
- if ( $self->{model_class}
- && $self->model_class->can('exception') )
+ # 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 );
return $status if $status == OK;
}
+
return $self->exception($error);
}
+sub default_table_view {
+ my ($self,$path,$args) = @_;
+ my $path_is_ok = 0;
+ my $default_table_view = __PACKAGE__->_default_table_view;
+ # (path class action field)
+ my @path = $self->{path} =~ m{([^/]+)/?}g;
+ my $search_value = shift(@path);
+ if ($default_table_view->{path}) {
+ if ($default_table_view->{path} eq $search_value) {
+ $search_value = shift(@path);
+ } else {
+ return 0;
+ }
+ }
+
+ $self->{table} = $default_table_view->{class};
+ $self->{action} = $default_table_view->{action};
+ $self->{args} = [ $search_value,@path ];
+ return $path_is_ok;
+}
+
sub additional_data { }
sub authenticate { return OK }
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 ($self) = @_;
+
+ $self->path || $self->path('frontpage');
+
+ my @pi = grep {length} split '/', $self->path;
+
+ $self->table(shift @pi);
+
+ $self->action( shift @pi or 'index' );
+
+ $self->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 ($self, $key) = @_;
+
+ return keys %{$self->params} unless defined $key;
+
+ return unless exists $self->params->{$key};
+
+ my $val = $self->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 get_protocol {
+ die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
sub parse_location {
- die "Do not use Maypole directly; use Apache::MVC or similar";
+ die "parse_location is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+sub redirect_request {
+ die "parse_location is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+sub redirect_internal_request {
+
}
sub send_output {
- die "Do not use Maypole directly; use Apache::MVC or similar";
+ die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
}
# Session and Repeat Submission Handling
add
application-specific initialisation.
+=head3 new
+
+Constructs a very minimal new Maypole request object.
+
=head3 view_object
Get/set the Maypole::View object
Maypole backend. It should return something that looks like an Apache
or CGI request object, it defaults to blank.
+=head3 default_table_view
=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
+The default implementation checks that C<$self-E<gt>table> is publicly
accessible
-and that the model class is configured to handle the C<$r-E<gt>action>
+and that the model class is configured to handle the C<$self-E<gt>action>
=head3 authenticate
view
templates.
-If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
+If the first item in C<$self-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
=head3 template_args
- $r->template_args->{foo} = 'bar';
+ $self->template_args->{foo} = 'bar';
Get/set a hash of template variables.
+=head3 stash
+
+A place to put custom application data. Not used by Maypole itself.
+
=head3 template
Get/set the template to be used by the view. By default, it returns
-C<$r-E<gt>action>
+C<$self-E<gt>action>
=head3 exception
=head3 make_random_id
-returns a unique id for this request can be used to prevent or detect repeat submissions.
+returns a unique id for this request can be used to prevent or detect repeat
+submissions.
+
+=head3 get_protocol
+
+Returns the protocol the request was made with, i.e. https
+
+=head3 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.
=head3 handler
=head3 handler_guts
-This is the core of maypole. You don't want to know.
+This is the main request handling method and calls various methods to handle the request/response
+and defines the workflow within Maypole.
+
+Currently undocumented and liable to be refactored without warning.
=head1 SEE ALSO
projects / maypole.git / blobdiff