X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=blobdiff_plain;f=lib%2FMaypole.pm;h=596479e21ec8f2b57cbe4dd20dc1957c2385ad18;hp=d978bf023916c57bfd2baf6aac07447dc89021ba;hb=5f90e1e118700c4cba7575299aa42dc4ffc0eb67;hpb=392422a4f5754d70aab8dd05bbe14793695a3ce3 diff --git a/lib/Maypole.pm b/lib/Maypole.pm index d978bf0..596479e 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,50 +1,363 @@ package Maypole; +use Class::C3; use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; use strict; use warnings; +use Data::Dumper; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; +use URI(); +use URI::QueryParam; +use NEXT; +use File::MMagic::XS qw(:compat); -our $VERSION = '2.10_pre2a'; +our $VERSION = '2.12'; +our $mmagic = File::MMagic::XS->new(); + +# 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 + +=head1 NAME + +Maypole - MVC web application framework + +=head1 SYNOPSIS + +The canonical example used in the Maypole documentation is the beer database: + + package BeerDB; + use strict; + use warnings; + + # choose a frontend, initialise the config object, and load a plugin + use Maypole::Application qw/Relationship/; + + # set everything up + __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); + + # get the empty config object created by Maypole::Application + my $config = __PACKAGE__->config; + + # basic settings + $config->uri_base("http://localhost/beerdb"); + $config->template_root("/path/to/templates"); + $config->rows_per_page(10); + $config->display_tables([qw/beer brewery pub style/]); + + # table relationships + $config->relationships([ + "a brewery produces beers", + "a style defines beers", + "a pub has beers on handpumps", + ]); + + # validation + BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] ); + BeerDB::Pub->untaint_columns( printable => [qw/name notes url/] ); + BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); + BeerDB::Beer->untaint_columns( + printable => [qw/abv name price notes/], + integer => [qw/style brewery score/], + date => [ qw/date/], + ); + + # note : set up model before calling this method + BeerDB::Beer->required_columns([qw/name/]); + + 1; + +=head1 DESCRIPTION + +This documents the Maypole request object. See the L, 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 driver package which represents your entire +application. This is the C package used as an example in the manual. + +This needs to first use L which will make your package +inherit from the appropriate platform driver such as C or +C. Then, the driver calls C. This sets up the model classes +and configures your application. The default model class for Maypole uses +L to map a database to classes, but this can be changed by altering +configuration (B calling setup.) + + +=head1 DOCUMENTATION AND SUPPORT + +Note that some details in some of these resources may be out of date. + +=over 4 + +=item The Maypole Manual + +The primary documentation is the Maypole manual. This lives in the +C pod documents included with the distribution. + +=item Embedded POD + +Individual packages within the distribution contain (more or less) detailed +reference documentation for their API. + +=item Mailing lists + +There are two mailing lists - maypole-devel and maypole-users - see +http://maypole.perl.org/?MailingList + +=item The Maypole Wiki + +The Maypole wiki provides a useful store of extra documentation - +http://maypole.perl.org + +In particular, there's a FAQ (http://maypole.perl.org/?FAQ) and a cookbook +(http://maypole.perl.org/?Cookbook). Again, certain information on these pages +may be out of date. + +=item Web applications with Maypole + +A tutorial written by Simon Cozens for YAPC::EU 2005 - +http://www.aarontrevena.co.uk/opensource/maypole/maypole-tutorial.pdf [228KB]. + +=item A Database-Driven Web Application in 18 Lines of Code + +By Paul Barry, published in Linux Journal, March 2005. + +http://www.linuxjournal.com/article/7937 + +"From zero to Web-based database application in eight easy steps". + +Maypole won a 2005 Linux Journal Editor's Choice Award +(http://www.linuxjournal.com/article/8293) after featuring in this article. + +=item Build Web apps with Maypole + +By Simon Cozens, on IBM's DeveloperWorks website, May 2004. + +http://www-128.ibm.com/developerworks/linux/library/l-maypole/ + +=item Rapid Web Application Deployment with Maypole + +By Simon Cozens, on O'Reilly's Perl website, April 2004. + +http://www.perl.com/pub/a/2004/04/15/maypole.html + +=item Authentication + +Some notes written by Simon Cozens. A little bit out of date, but still +very useful: http://www.aarontrevena.co.uk/opensource/maypole/authentication.html + +=item CheatSheet + +There's a refcard for the Maypole (and Class::DBI) APIs on the wiki - +http://maypole.perl.org/?CheatSheet. Probably a little out of date now - it's a +wiki, so feel free to fix any errors! + +=item Plugins and add-ons + +There are a large and growing number of plugins and other add-on modules +available on CPAN - http://search.cpan.org/search?query=maypole&mode=module + +=item del.icio.us + +You can find a range of useful Maypole links, particularly to several thoughtful +blog entries, starting here: http://del.icio.us/search/?all=maypole + +=item CPAN ratings + +There are a couple of short reviews here: +http://cpanratings.perl.org/dist/Maypole + +=back + +=cut + +__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); -__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 status parent build_form_elements + user session) ); + __PACKAGE__->config( Maypole::Config->new() ); + __PACKAGE__->init_done(0); +__PACKAGE__->model_classes_loaded(0); + +=head1 HOOKABLE METHODS + +As a framework, Maypole provides a number of B - methods that are +intended to be overridden. Some of these methods come with useful default +behaviour, others do nothing by default. Hooks include: + + Class methods + ------------- + debug + setup + setup_model + load_model_subclass + init + + Instance methods + ---------------- + start_request_hook + is_model_applicable + get_session + authenticate + exception + additional_data + preprocess_path + +=head1 CLASS METHODS + +=over 4 + +=item debug + + sub My::App::debug {1} + +Returns the debugging flag. Override this in your application class to +enable/disable debugging. + +You can also set the C flag via L. + +Some packages respond to higher debug levels, try increasing it to 2 or 3. + + +=cut + sub debug { 0 } -sub setup { - my $calling_class = shift; - $calling_class = ref $calling_class if ref $calling_class; - { - no strict 'refs'; - no warnings 'redefine'; +=item config + +Returns the L object + +=item setup + + My::App->setup($data_source, $user, $password, \%attr); + +Initialise the Maypole application and plugins and model classes. +Your application should call this B setting up configuration data via +L<"config">. + +It calls the hook C to setup the model. The %attr hash contains +options and arguments used to set up the model. See the particular model's +documentation. However here is the most usage of setup where +Maypole::Model::CDBI is the base class. + + My::App->setup($data_source, $user, $password, + { options => { # These are DB connection options + AutoCommit => 0, + RaiseError => 1, + ... + }, + # These are Class::DBI::Loader arguments. + relationships => 1, + ... + } + ); + +Also, see L. + +=cut + + +sub setup +{ + my $class = shift; + + $class->setup_model(@_); +} + +=item setup_model + +Called by C. This method builds the Maypole model hierarchy. + +A likely target for over-riding, if you need to build a customised model. + +This method also ensures any code in custom model classes is loaded, so you +don't need to load them in the driver. + +=cut + +sub setup_model { + my $class = shift; + $class = ref $class if ref $class; + my $config = $class->config; + $config->model || $config->model('Maypole::Model::CDBI'); + $config->model->require or die sprintf + "Couldn't load the model class %s: %s", $config->model, $@; + + # among other things, this populates $config->classes + $config->model->setup_database($config, $class, @_); + + $config->model->add_model_superclass($config); + + # Load custom model code, if it exists - nb this must happen after the + # adding the model superclass, to allow code attributes to work, but before adopt(), + # in case adopt() calls overridden methods on $subclass + foreach my $subclass ( @{ $config->classes } ) { + $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); + $config->model->adopt($subclass) if $config->model->can("adopt"); + } - # 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 } ) { - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - $config->model->adopt($subclass) - if $config->model->can("adopt"); - } } -sub init { +=item load_model_subclass($subclass) + +This method is called from C. It attempts to load the +C<$subclass> package, if one exists. So if you make a customized C +package, you don't need to explicitly load it. + +If automatic loading causes problems, Override load_model_subclass in your driver. + +sub load_model_subclass {}; + +Or perhaps during development, if you don't want to load up custom classes, you +can override this method and load them manually. + +=cut + +sub load_model_subclass { + my ($class, $subclass) = @_; + + my $config = $class->config; + + # Load any external files for the model base class or subclasses + # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from + # Maypole::Plugin::Loader and Class::DBI. + if ( $subclass->require ) { + warn "Loaded external module for '$subclass'\n" if $class->debug > 1; + } else { + (my $filename = $subclass) =~ s!::!/!g; + die "Loading '$subclass' failed: $@\n" + unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; + warn "No external module for '$subclass'" + if $class->debug > 1; + } +} + +=item init + +Loads the view class and instantiates the view object. + +You should not call this directly, but you may wish to override this to add +application-specific initialisation - see L. + +=cut + +sub init +{ my $class = shift; my $config = $class->config; $config->view || $config->view("Maypole::View::TT"); @@ -54,439 +367,1113 @@ sub init { || $config->display_tables( $class->config->tables ); $class->view_object( $class->config->view->new ); $class->init_done(1); - } -sub handler { +=item new + +Constructs a very minimal new Maypole request object. - # See Maypole::Workflow before trying to understand this. - my ( $class, $req ) = @_; - $class->init unless $class->init_done; +=cut - # Create the request object - my $r = bless { - template_args => {}, - config => $class->config +sub new +{ + my ($class) = @_; + my $self = bless { + config => $class->config, }, $class; - $r->headers_out(Maypole::Headers->new); - $r->get_request($req); - $r->parse_location(); - my $status = $r->handler_guts(); - return $status unless $status == OK; - $r->send_output; - return $status; + + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + return $self; } +=item view_object + +Get/set the Maypole::View object + +=back + +=head1 INSTANCE METHODS + +=head2 Workflow + +=over 4 + +=item handler + +This method sets up the class if it's not done yet, sets some defaults and +leaves the dirty work to C. + +=cut + +# 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 +sub handler : method { + # See Maypole::Workflow before trying to understand this. + my ($class, $req) = @_; + + $class->init unless $class->init_done; + + my $self = $class->new; + + # initialise the request + $self->headers_out(Maypole::Headers->new); + $self->get_request($req); + + $self->parse_location; + + # hook useful for declining static requests e.g. images, or perhaps for + # sanitizing request parameters + $self->status(Maypole::Constants::OK()); # set the default + $self->__call_hook('start_request_hook'); + return $self->status unless $self->status == Maypole::Constants::OK(); + die "status undefined after start_request_hook()" unless defined + $self->status; + + $self->session($self->get_session); + $self->user($self->get_user); + + my $status = $self->handler_guts; + return $status unless $status == OK; + # TODO: require send_output to return a status code + $self->send_output; + return $status; +} + +=item component + + Run Maypole sub-requests as a component of the request + + [% request.component("/beer/view_as_component/20") %] + + Allows you to integrate the results of a Maypole request into an existing +request. You'll need to set up actions and templates +which return fragments of HTML rather than entire pages, but once you've +done that, you can use the C method of the Maypole request object +to call those actions. You may pass a query string in the usual URL style. + +You should not fully qualify the Maypole URLs. + +Note: any HTTP POST or URL parameters passed to the parent are not passed to the +component sub-request, only what is included in the url passed as an argument +to the method + +=cut + +sub component { + my ( $r, $path ) = @_; + my $self = bless { parent => $r, config => $r->{config}, } , ref $r; + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + + $self->session($self->get_session); + $self->user($self->get_user); + + my $url = URI->new($path); + $self->{path} = $url->path; + $self->parse_path; + $self->params( $url->query_form_hash ); + $self->handler_guts; + return $self->output; +} + +sub get_template_root { + my $self = shift; + my $r = shift; + return $r->parent->get_template_root if $r->{parent}; + return $self->NEXT::DISTINCT::get_template_root( $r, @_ ); +} + +sub view_object { + my $self = shift; + my $r = shift; + return $r->parent->view_object if $r->{parent}; + return $self->NEXT::DISTINCT::view_object( $r, @_ ); +} + +# Instead of making plugin authors use the NEXT::DISTINCT hoopla to ensure other +# plugins also get to call the hook, we can cycle through the application's +# @ISA and call them all here. Doesn't work for setup() though, because it's +# too ingrained in the stack. We could add a run_setup() method, but we'd break +# lots of existing code. +sub __call_hook +{ + my ($self, $hook) = @_; + + my @plugins; + { + my $class = ref($self); + no strict 'refs'; + @plugins = @{"$class\::ISA"}; + } + + # this is either a custom method in the driver, or the method in the 1st + # plugin, or the 'null' method in the frontend (i.e. inherited from + # Maypole.pm) - we need to be careful to only call it once + my $first_hook = $self->can($hook); + $self->$first_hook; + + my %seen = ( $first_hook => 1 ); + + # @plugins includes the frontend + foreach my $plugin (@plugins) + { + next unless my $plugin_hook = $plugin->can($hook); + next if $seen{$plugin_hook}++; + $self->$plugin_hook; + } +} + +=item handler_guts + +This is the main request handling method and calls various methods to handle the +request/response and defines the workflow within Maypole. + +=cut + # The root of all evil sub handler_guts { - my $r = shift; - $r->model_class( $r->config->model->class_of( $r, $r->{table} ) ); + my ($self) = @_; + $self->build_form_elements(1) unless (defined ($self->config->build_form_elements) && $self->config->build_form_elements == 0); + $self->__load_request_model; + + my $applicable = $self->is_model_applicable == OK; + + my $status; + + # handle authentication + eval { $status = $self->call_authenticate }; + if ( my $error = $@ ) { + $status = $self->call_exception($error, "authentication"); + if ( $status != OK ) { + $self->warn("caught authenticate error: $error"); + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; + } + } + if ( $self->debug and $status != OK and $status != DECLINED ) { + $self->view_object->error( $self, + "Got unexpected status $status from calling authentication" ); + } - my $applicable = $r->is_applicable; - unless ( $applicable == OK ) { + return $status unless $status == OK; - # It's just a plain template - delete $r->{model_class}; - $r->{path} =~ s{/$}{}; # De-absolutify - $r->template( $r->{path} ); - } + # We run additional_data for every request + $self->additional_data; - # We authenticate every request, needed for proper session management - my $status; - eval { $status = $r->call_authenticate }; + if ($applicable) { + eval { $self->model_class->process($self) }; if ( my $error = $@ ) { - $status = $r->call_exception($error); - if ( $status != OK ) { - warn "caught authenticate error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; - } + $status = $self->call_exception($error, "model"); + if ( $status != OK ) { + $self->warn("caught model 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, - "Got unexpected status $status from calling authentication" ); + } else { + $self->__setup_plain_template; + } + + # less frequent path - perhaps output has been set to an error message + if ($self->output) { + $self->{content_type} ||= $self->__get_mime_type(); + $self->{document_encoding} ||= "utf-8"; + return OK; + } + + # normal path - no output has been generated yet + my $processed_view_ok = $self->__call_process_view; + + $self->{content_type} ||= $self->__get_mime_type(); + $self->{document_encoding} ||= "utf-8"; + + return $processed_view_ok; +} + +my %filetypes = ( + 'js' => 'text/javascript', + 'css' => 'text/css', + 'htm' => 'text/html', + 'html' => 'text/html', + ); + +sub __get_mime_type { + my $self = shift; + my $type = 'text/html'; + if ($self->path =~ m/.*\.(\w{3,4})$/) { + $type = $filetypes{$1}; + } else { + my $output = $self->output; + if (defined $output) { + $type = $mmagic->checktype_contents($output); } - 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 ) { - warn "caught model error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; - } - } + } + return $type; +} + +sub __load_request_model +{ + my ($self) = @_; + # We may get a made up class from class_of + my $mclass = $self->config->model->class_of($self, $self->table); + if ( eval {$mclass->isa('Maypole::Model::Base')} ) { + $self->model_class( $mclass ); } - 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; - } - } - return $status; + elsif ($self->debug > 1) { + $self->warn("***Warning: No $mclass class appropriate for model. @_"); } - else { return OK; } } -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 } } ) - 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(); -} -sub call_authenticate { - my $self = shift; +# 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) = @_; - # Check if we have a model class - if ( $self->{model_class} ) { - return $self->model_class->authenticate($self) - if $self->model_class->can("authenticate"); + # It's just a plain template + $self->build_form_elements(0); + $self->model_class(undef); + + unless ($self->template) { + # FIXME: this is likely to be redundant and is definately causing problems. + my $path = $self->path; + $path =~ s{/$}{}; # De-absolutify + $self->path($path); + $self->template($self->path); } - return $self->authenticate($self); # Interface consistency is a Good Thing } -sub call_exception { - my $self = shift; - my ($error) = @_; +# 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) = @_; - # Check if we have a model class - if ( $self->{model_class} - && $self->model_class->can('exception') ) - { - my $status = $self->model_class->exception( $self, $error ); - return $status if $status == OK; + my $status = eval { $self->view_object->process($self) }; + + my $error = $@ || $self->{error}; + + if ( $error ) { + $status = $self->call_exception($error, "view"); + + if ( $status != OK ) { + warn "caught view error: $error" if $self->debug; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } - return $self->exception($error); + } + + return $status; } -sub additional_data { } +=item warn -sub authenticate { return OK } +$r->warn('its all gone pete tong'); -sub exception { return ERROR } +Warn must be implemented by the backend, i.e. Apache::MVC +and warn to stderr or appropriate logfile. -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; +You can also over-ride this in your Maypole driver, should you +want to use something like Log::Log4perl instead. + +=cut + +sub warn { } + +=item build_form_elements + +$r->build_form_elements(0); + +Specify (in an action) whether to build HTML form elements and populate +the cgi element of classmetadata in the view. + +You can set this globally using the accessor of the same name in Maypole::Config, +this method allows you to over-ride that setting per action. + +=cut + +=item 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. + +=cut + +sub get_request { } + +=item parse_location + +Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a Maypole +request. It does this by setting the C, and invoking C and +C. + +You should only need to define this method if you are writing a new Maypole +backend. + +=cut + +sub parse_location +{ + die "parse_location is a virtual method. Do not use Maypole directly; " . + "use Apache::MVC or similar"; } -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}}; +=item start_request_hook + +This is called immediately after setting up the basic request. The default +method does nothing. + +The value of C<< $r->status >> is set to C before this hook is run. Your +implementation can change the status code, or leave it alone. + +After this hook has run, Maypole will check the value of C. For any +value other than C, Maypole returns the C immediately. + +This is useful for filtering out requests for static files, e.g. images, which +should not be processed by Maypole or by the templating engine: + + sub start_request_hook + { + my ($r) = @_; + + $r->status(DECLINED) if $r->path =~ /\.jpg$/; } -} + +Multiple plugins, and the driver, can define this hook - Maypole will call all +of them. You should check for and probably not change any non-OK C +value: + + package Maypole::Plugin::MyApp::SkipFavicon; + + sub start_request_hook + { + my ($r) = @_; + + # check if a previous plugin has already DECLINED this request + # - probably unnecessary in this example, but you get the idea + return unless $r->status == OK; + + # then do our stuff + $r->status(DECLINED) if $r->path =~ /favicon\.ico/; + } + +=cut -sub get_template_root { "." } -sub get_request { } +sub start_request_hook { } -sub parse_location { - die "Do not use Maypole directly; use Apache::MVC or similar"; -} +=item is_applicable -sub send_output { - die "Do not use Maypole directly; use Apache::MVC or similar"; +B as of version 2.11. If you have overridden it, +please override C instead, and change the return type +from a Maypole:Constant to a true/false value. + +Returns a Maypole::Constant to indicate whether the request is valid. + +=cut + +sub is_applicable { return shift->is_model_applicable(@_); } + +=item 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 >>. + +=cut + +sub is_model_applicable { + my ($self) = @_; + + # 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"; + + 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; + } + + if (not $ok) + { + $self->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 DECLINED; + } + + # Is the action public? + my $action = $self->action; + return OK if $self->model_class->is_public($action); + + $self->warn("The action '$action' is not applicable to the table '$table'") + if $self->debug; + + return DECLINED; } -# Session and Repeat Submission Handling +=item get_session -sub make_random_id { - use Maypole::Session; - return Maypole::Session::generate_unique_id(); +Called immediately after C. + +This method should return a session, which will be stored in the request's +C attribute. + +The default method is empty. + +=cut + +sub get_session { } + +=item get_user + +Called immediately after C. + +This method should return a user, which will be stored in the request's C +attribute. + +The default method is empty. + +=cut + +sub get_user {} + +=item 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. + +=cut + +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); } -=head1 NAME +=item authenticate -Maypole - MVC web application framework +Returns a Maypole::Constant to indicate whether the user is authenticated for +the Maypole request. -=head1 SYNOPSIS +The default implementation returns C -See L. +=cut -=head1 DESCRIPTION +sub authenticate { return OK } -This documents the Maypole request object. See the L, 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. +=item call_exception -To use it, you need to create a package which represents your entire -application. In our example above, this is the C package. +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 needs to first use L which will make your package -inherit from the appropriate platform driver such as C or -C, and then call setup. This sets up the model classes and -configures your application. The default model class for Maypole uses -L to map a database to classes, but this can be changed by altering -configuration. (B calling setup.) +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. -=head2 CLASS METHODS +=cut -=head3 config +sub call_exception +{ + my ($self, $error, $when) = @_; -Returns the L object + # 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, $when ); + return $status if $status == OK; + } + + return $self->exception($error, $when); +} -=head3 setup - My::App->setup($data_source, $user, $password, \%attr); +=item exception -Initialise the maypole application and model classes. Your application should -call this after setting configuration via L<"config"> +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 init +=cut -You should not call this directly, but you may wish to override this to -add -application-specific initialisation. +sub exception { + my ($self, $error, $when) = @_; + if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) { + $self->view_object->report_error($self, $error, $when); + return OK; + } + return ERROR; +} -=head3 view_object +=item additional_data -Get/set the Maypole::View object +Called before the model processes the request, this method gives you a chance to +do some processing for each request, for example, manipulating C. -=head3 debug +=cut - sub My::App::debug {1} +sub additional_data { } -Returns the debugging flag. Override this in your application class to -enable/disable debugging. +=item send_output -=head2 INSTANCE METHODS +Sends the output and additional headers to the user. -=head3 parse_location +=cut -Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a -Maypole -request. It does this by setting the C, and invoking C -and -C. +sub send_output { + die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} -You should only need to define this method if you are writing a new -Maypole -backend. -=head3 path +=back + +=head2 Path processing and manipulation + +=over 4 + +=item path Returns the request path -=head3 parse_path +=item parse_path -Parses the request path and sets the C, C and C -properties +Parses the request path and sets the C, C and C
+properties. Calls C before parsing path and setting properties. -=head3 table +=cut -The table part of the Maypole request path +sub parse_path +{ + my ($self) = @_; -=head3 action + # Previous versions unconditionally set table, action and args to whatever + # was in @pi (or else to defaults, if @pi is empty). + # Adding preprocess_path(), and then setting table, action and args + # conditionally, broke lots of tests, hence this: + $self->$_(undef) for qw/action table args/; + $self->preprocess_path; -The action part of the Maypole request path + # use frontpage template for frontpage + unless ($self->path && $self->path ne '/') { + $self->path('frontpage'); + } -=head3 args + my @pi = grep {length} split '/', $self->path; -A list of remaining parts of the request path after table and action -have been -removed + $self->table || $self->table(shift @pi); + $self->action || $self->action( shift @pi or 'index' ); + $self->args || $self->args(\@pi); +} -=head3 headers_in +=item preprocess_path -A L object containing HTTP headers for the request +Sometimes when you don't want to rewrite or over-ride parse_path but +want to rewrite urls or extract data from them before it is parsed. -=head3 headers_out +This method is called after parse_location has populated the request +information and before parse_path has populated the model and action +information, and is passed the request object. -A L object that contains HTTP headers for the output +You can set action, args or table in this method and parse_path will +then leave those values in place or populate them if not present -=head3 parse_args +=cut -Turns post data and query string paramaters into a hash of C. +sub preprocess_path { }; -You should only need to define this method if you are writing a new -Maypole -backend. +=item make_path( %args or \%args or @args ) -=head3 param +This is the counterpart to C. It generates a path to use +in links, form actions etc. To implement your own path scheme, just override +this method and C. -An accessor for request parameters. It behaves similarly to CGI::param() for -accessing CGI parameters. + %args = ( table => $table, + action => $action, + additional => $additional, # optional - generally an object ID + ); + + \%args = as above, but a ref + + @args = ( $table, $action, $additional ); # $additional is optional -=head3 params +C can be used as an alternative key to C. -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. +C<$additional> can be a string, an arrayref, or a hashref. An arrayref is +expanded into extra path elements, whereas a hashref is translated into a query +string. -B Where muliple values of a parameter were supplied, the -C -value -will be an array reference. +=cut -=head3 get_template_root +sub make_path +{ + my $r = shift; + + my %args; + + if (@_ == 1 and ref $_[0] and ref $_[0] eq 'HASH') + { + %args = %{$_[0]}; + } + elsif ( @_ > 1 and @_ < 4 ) + { + $args{table} = shift; + $args{action} = shift; + $args{additional} = shift; + } + else + { + %args = @_; + } + + do { die "no $_" unless $args{$_} } for qw( table action ); + + my $additional = $args{additional} || $args{id}; + + my @add = (); + + if ($additional) + { + # if $additional is a href, make_uri() will transform it into a query + @add = (ref $additional eq 'ARRAY') ? @$additional : ($additional); + } + + my $uri = $r->make_uri($args{table}, $args{action}, @add); + + return $uri->as_string; +} -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 -=head3 get_request +=item make_uri( @segments ) -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. +Make a L object given table, action etc. Automatically adds +the C. +If the final element in C<@segments> is a hash ref, C will render it +as a query string. -=head3 is_applicable +=cut -Returns a Maypole::Constant to indicate whether the request is valid. +sub make_uri +{ + my ($r, @segments) = @_; + + my $query = (ref $segments[-1] eq 'HASH') ? pop(@segments) : undef; + + my $base = $r->config->uri_base; + $base =~ s|/$||; + + my $uri = URI->new($base); + $uri->path_segments($uri->path_segments, grep {length} @segments); + + my $abs_uri = $uri->abs('/'); + $abs_uri->query_form($query) if $query; + return $abs_uri; +} -The default implementation checks that C<$r-Etable> is publicly -accessible -and that the model class is configured to handle the C<$r-Eaction> +=item parse_args -=head3 authenticate +Turns post data and query string paramaters into a hash of C. -Returns a Maypole::Constant to indicate whether the user is -authenticated for -the Maypole request. +You should only need to define this method if you are writing a new Maypole +backend. -The default implementation returns C +=cut + +sub parse_args +{ + die "parse_args() is a virtual method. Do not use Maypole directly; ". + "use Apache::MVC or similar"; +} + +=item 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 + +=cut + +=back + +=head2 Request properties -=head3 model_class +=over 4 + +=item model_class Returns the perl package name that will serve as the model for the request. It corresponds to the request C
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. -=head3 objects +=item objects -Get/set a list of model objects. The objects will be accessible in the -view +Get/set a list of model objects. The objects will be accessible in the view templates. -If the first item in C<$r-Eargs> can be Cd by the model -class, -it will be removed from C and the retrieved object will be added -to the -C list. See L for more information. +If the first item in C<$self-Eargs> can be Cd by the model +class, it will be removed from C and the retrieved object will be added to +the C list. See L for more information. + + +=item object -=head3 template_args +Alias to get/set the first/only model object. The object will be accessible +in the view templates. - $r->template_args->{foo} = 'bar'; +When used to set the object, will overwrite the request objects +with a single object. + +=cut + +sub object { + my ($r,$object) = @_; + $r->objects([$object]) if ($object); + return undef unless $r->objects(); + return $r->objects->[0]; +} + +=item template_args + + $self->template_args->{foo} = 'bar'; Get/set a hash of template variables. -=head3 template +Maypole reserved words for template variables will over-ride values in template_variables. -Get/set the template to be used by the view. By default, it returns -C<$r-Eaction> +Reserved words are : r, request, object, objects, base, config and errors, as well as the +current class or object name. -=head3 exception +=item stash + +A place to put custom application data. Not used by Maypole itself. + +=item template + +Get/set the template to be used by the view. By default, it returns +C<$self-Eaction> -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 +=item error Get/set a request error -=head3 output +=item output -Get/set the response output. This is usually populated by the view -class. You +Get/set the response output. This is usually populated by the view class. You can skip view processing by setting the C. -=head3 document_encoding +=item table + +The table part of the Maypole request path + +=item action + +The action part of the Maypole request path + +=item args + +A list of remaining parts of the request path after table and action +have been +removed + +=item headers_in + +A L object containing HTTP headers for the request + +=item headers_out + +A L object that contains HTTP headers for the output + +=item document_encoding Get/set the output encoding. Default: utf-8. -=head3 content_type +=item content_type Get/set the output content type. Default: text/html -=head3 send_output +=item get_protocol -Sends the output and additional headers to the user. +Returns the protocol the request was made with, i.e. https -=head3 call_authenticate +=cut -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. +sub get_protocol { + die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} +=back -=head3 call_exception +=head2 Request parameters -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. +The source of the parameters may vary depending on the Maypole backend, but they +are usually populated from request query string and POST data. -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. +Maypole supplies several approaches for accessing the request parameters. Note +that the current implementation (via a hashref) of C and C is +likely to change in a future version of Maypole. So avoid direct access to these +hashrefs: + + $r->{params}->{foo} # bad + $r->params->{foo} # better + + $r->{query}->{foo} # bad + $r->query->{foo} # better + + $r->param('foo') # best + +=over 4 + +=item param + +An accessor (get or set) for request parameters. It behaves similarly to +CGI::param() for accessing CGI parameters, i.e. + + $r->param # returns list of keys + $r->param($key) # returns value for $key + $r->param($key => $value) # returns old value, sets to new value + +=cut + +sub param +{ + my ($self, $key) = (shift, shift); + + return keys %{$self->params} unless defined $key; + + return unless exists $self->params->{$key}; + + my $val = $self->params->{$key}; + + if (@_) + { + my $new_val = shift; + $self->params->{$key} = $new_val; + } + + return ref $val ? @$val : ($val) if wantarray; + + return ref $val ? $val->[0] : $val; +} + + +=item params + +Returns a hashref of request parameters. + +B Where muliple values of a parameter were supplied, the C value +will be an array reference. + +=item query + +Alias for C. + +=back + +=head3 Utility methods + +=over 4 + +=item 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 -=head3 make_random_id +$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..'); -returns a unique id for this request can be used to prevent or detect repeat submissions. +The named parameters are protocol, domain, path, status and url -=head3 handler +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. -This method sets up the class if it's not done yet, sets some -defaults and leaves the dirty work to handler_guts. +=cut + +sub redirect_request { + die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} + +# =item redirect_internal_request +# +# =cut +# +# sub redirect_internal_request { +# +# } -=head3 handler_guts -This is the core of maypole. You don't want to know. +=item make_random_id + +returns a unique id for this request can be used to prevent or detect repeat +submissions. + +=cut + +# Session and Repeat Submission Handling +sub make_random_id { + use Maypole::Session; + return Maypole::Session::generate_unique_id(); +} + +=back + +=head1 SEQUENCE DIAGRAMS + +See L for a detailed discussion of the sequence of +calls during processing of a request. This is a brief summary: + + INITIALIZATION + Model e.g. + BeerDB Maypole::Model::CDBI + | | + setup | | + o-------->|| | + || setup_model | setup_database() creates + ||------+ | a subclass of the Model + |||<----+ | for each table + ||| | | + ||| setup_database | | + |||--------------------->|| 'create' * + ||| ||----------> $subclass + ||| | | + ||| load_model_subclass | | + foreach |||------+ ($subclass) | | + $subclass ||||<----+ | require | + ||||--------------------------------------->| + ||| | | + ||| adopt($subclass) | | + |||--------------------->|| | + | | | + | | | + |-----+ init | | + ||<---+ | | + || | new | view_object: e.g. + ||---------------------------------------------> Maypole::View::TT + | | | | + | | | | + | | | | + | | | | + | | | | + + + + HANDLING A REQUEST + + + BeerDB Model $subclass view_object + | | | | + handler | | | | + o-------->| new | | | + |-----> r:BeerDB | | | + | | | | | + | | | | | + | || | | | + | ||-----+ parse_location | | | + | |||<---+ | | | + | || | | | + | ||-----+ start_request_hook | | | + | |||<---+ | | | + | || | | | + | ||-----+ get_session | | | + | |||<---+ | | | + | || | | | + | ||-----+ get_user | | | + | |||<---+ | | | + | || | | | + | ||-----+ handler_guts | | | + | |||<---+ | | | + | ||| class_of($table) | | | + | |||------------------------->|| | | + | ||| $subclass || | | + | |||<-------------------------|| | | + | ||| | | | + | |||-----+ is_model_applicable| | | + | ||||<---+ | | | + | ||| | | | + | |||-----+ call_authenticate | | | + | ||||<---+ | | | + | ||| | | | + | |||-----+ additional_data | | | + | ||||<---+ | | | + | ||| process | | | + | |||--------------------------------->|| fetch_objects + | ||| | ||-----+ | + | ||| | |||<---+ | + | ||| | || | + | ||| | || $action + | ||| | ||-----+ | + | ||| | |||<---+ | + | ||| process | | | + | |||------------------------------------------->|| template + | ||| | | ||-----+ + | ||| | | |||<---+ + | ||| | | | + | || send_output | | | + | ||-----+ | | | + | |||<---+ | | | + $status | || | | | + <------------------|| | | | + | | | | | + | X | | | + | | | | + | | | | + | | | | + + =head1 SEE ALSO -There's more documentation, examples, and a information on our mailing lists +There's more documentation, examples, and information on our mailing lists at the Maypole web site: L @@ -495,12 +1482,14 @@ L, L, L. =head1 AUTHOR -Maypole is currently maintained by Simon Flack C +Maypole is currently maintained by Aaron Trevena. =head1 AUTHOR EMERITUS Simon Cozens, C +Simon Flack maintained Maypole from 2.05 to 2.09 + Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 =head1 THANKS TO @@ -516,3 +1505,55 @@ You may distribute this code under the same terms as Perl itself. =cut 1; + +__END__ + + =item register_cleanup($coderef) + +Analogous to L's C. If an Apache request object is +available, this call simply redispatches there. If not, the cleanup is +registered in the Maypole request, and executed when the request is +Ced. + +This method is only useful in persistent environments, where you need to ensure +that some code runs when the request finishes, no matter how it finishes (e.g. +after an unexpected error). + + =cut + +{ + my @_cleanups; + + sub register_cleanup + { + my ($self, $cleanup) = @_; + + die "register_cleanup() is an instance method, not a class method" + unless ref $self; + die "Cleanup must be a coderef" unless ref($cleanup) eq 'CODE'; + + if ($self->can('ar') && $self->ar) + { + $self->ar->register_cleanup($cleanup); + } + else + { + push @_cleanups, $cleanup; + } + } + + sub DESTROY + { + my ($self) = @_; + + while (my $cleanup = shift @_cleanups) + { + eval { $cleanup->() }; + if ($@) + { + warn "Error during request cleanup: $@"; + } + } + } +} +