use warnings;
use Maypole::Config;
use Maypole::Constants;
+use Maypole::Headers;
-our $VERSION = '2.04';
+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
- args action template error document_encoding content_type table)
+ qw( params query objects model_class template_args output path
+ args action template error document_encoding content_type table
+ 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';
-
- # 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;
- my $r = bless { template_args => {}, config => $class->config }, $class;
- $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 = $self->is_model_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_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;
+
$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} };
-
- # Is it public?
- return DECLINED unless $self->model_class->is_public( $self->{action} );
- return OK();
+ if ref $config->ok_tables eq "ARRAY";
+
+ my $ok_tables = $config->ok_tables;
+
+ # Does this request concern a table to be processed by the model?
+ my $table = $self->table;
+
+ my $ok = 0;
+
+ if (exists $ok_tables->{$table})
+ {
+ $ok = 1;
+ }
+# implements tj's default_table_view(), but there's no _default_table_view()
+# or _have_default_table_view() yet
+# else
+# {
+# $ok = $self->default_table_view($self->path, $self->args)
+# if $self->_have_default_table_view;
+# }
+
+ if (not $ok)
+ {
+ warn "We don't have that table ($table).\n"
+ . "Available tables are: "
+ . join( ",", keys %$ok_tables )
+ if $self->debug and not $ok_tables->{$table};
+
+ return 0;
+ }
+
+ # Is the action public?
+ my $action = $self->action;
+ return 1 if $self->model_class->is_public($action);
+
+ warn "The action '$action' is not applicable to the table $table"
+ if $self->debug;
+
+ return 0;
}
-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 = 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 ($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 get_template_root { "." }
+# 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_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
+
+sub make_random_id {
+ use Maypole::Session;
+ return Maypole::Session::generate_unique_id();
}
=head1 NAME
=head1 DESCRIPTION
-This documents the Maypole request object. For user documentation, see
-L<Maypole::Manual>.
+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 similar to Java's struts. It is
+essentially completely abstracted, and so doesn't know anything about
+how to talk to the outside world.
+
+To use it, you need to create a package which represents your entire
+application. In our example above, this is the C<BeerDB> package.
+
+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.)
=head2 CLASS METHODS
add
application-specific initialisation.
+=head3 new
+
+Constructs a very minimal new Maypole request object.
+
=head3 view_object
Get/set the Maypole::View object
have been
removed
+=head3 headers_in
+
+A L<Maypole::Headers> object containing HTTP headers for the request
+
+=head3 headers_out
+
+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>.
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
+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
=head3 get_template_root
-Implimentation-specific path to template root.
+Implementation-specific path to template root.
You should only need to define this method if you are writing a new
Maypole
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 implimentation 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>
+B<This method is deprecated> as of version 2.11. If you have overridden it,
+please override C<is_model_applicable> instead, and change the return type
+from Maypole:Constants to true/false.
+
+=head3 is_model_applicable
+
+Returns true or false to indicate whether the request is valid.
+
+The default implementation checks that C<< $r->table >> is publicly
+accessible and that the model class is configured to handle the
+C<< $r->action >>.
=head3 authenticate
authenticated for
the Maypole request.
-The default implimentation returns C<OK>
+The default implementation returns C<OK>
=head3 model_class
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 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 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 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
-There's more documentation, examples, and a wiki at the Maypole web
-site:
+There's more documentation, examples, and a information on our mailing lists
+at the Maypole web site:
-http://maypole.perl.org/
+L<http://maypole.perl.org/>
-L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
+L<Maypole::Application>,
L<Apache::MVC>, L<CGI::Maypole>.
=head1 AUTHOR
-Sebastian Riedel, c<sri@oook.de>
+Maypole is currently maintained by Simon Flack C<simonflk#cpan.org>
=head1 AUTHOR EMERITUS
-Simon Cozens, C<simon@cpan.org>
+Simon Cozens, C<simon#cpan.org>
+
+Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
=head1 THANKS TO
-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.
+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
projects / maypole.git / blobdiff