X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=83607c8db34137662cf0694cf8a494179d319d18;hb=f94c2679992bf0db0b360a0a475b3e646466aee0;hp=dd9ff770a1827ca393dd4361509222461135f1b7;hpb=193575767582376e4a70c5d4af176dab84b2b0ee;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index dd9ff77..83607c8 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,351 +1,1462 @@ package Maypole; use base qw(Class::Accessor::Fast Class::Data::Inheritable); -use attributes (); use UNIVERSAL::require; use strict; use warnings; +use Data::Dumper; use Maypole::Config; -our $VERSION = '2.0'; -__PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); +use Maypole::Constants; +use Maypole::Headers; +use URI(); +use URI::QueryParam; +use NEXT; +use File::MMagic::XS qw(:compat); + +our $VERSION = '2.11'; +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/; + + # 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/], + ); + + # set everything up + __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); + + 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.droogs.org/perl/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.droogs.org/perl/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 + +=head1 DEMOS + +A couple of demos are available, sometimes with source code and configs. + +=over 4 + +=item http://maypole.perl.org/beerdb/ + +The standard BeerDB example, using the TT factory templates supplied in the +distribution. + +=item beerdb.riverside-cms.co.uk + +The standard BeerDB example, running on Mason, using the factory templates +supplied in the L distribution. + +=item beerfb.riverside-cms.co.uk + +A demo of L. This site is running on the set of Mason +templates included in the L distribution. See the +synopsis of L for an example driver + +=back + +=cut + +__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); + __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 status parent) ); + __PACKAGE__->config( Maypole::Config->new() ); + __PACKAGE__->init_done(0); -use Maypole::Constants; -sub debug { 0 } +__PACKAGE__->model_classes_loaded(0); -sub setup { - my $calling_class = shift; - $calling_class = ref $calling_class if ref $calling_class; - { - no strict 'refs'; +=head1 HOOKABLE METHODS - # 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"); - } +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 { 1 } + +=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, @_); + + foreach my $subclass ( @{ $config->classes } ) { + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + unshift @{ $subclass . "::ISA" }, $config->model; + } + + # Load custom model code, if it exists - nb this must happen after the + # unshift, 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"); + } + +} + +=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; + } } -sub init { +=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"); $config->view->require; die "Couldn't load the view class " . $config->view . ": $@" if $@; $config->display_tables - || $config->display_tables( [ $class->config->tables ] ); + || $config->display_tables( $class->config->tables ); $class->view_object( $class->config->view->new ); $class->init_done(1); +} + +=item new + +Constructs a very minimal new Maypole request object. + +=cut +sub new +{ + my ($class) = @_; + + my $self = bless { + template_args => {}, + config => $class->config, + }, $class; + + return $self; } -sub handler { +=item view_object - # See Maypole::Workflow before trying to understand this. - my ( $class, $req ) = @_; - $class->init unless $class->init_done; - my $r = bless { config => $class->config }, $class; - $r->get_request($req); - $r->parse_location(); - my $status = $r->handler_guts(); - return $status unless $status == OK; - $r->send_output; - return $status; +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->get_session; + $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; } -# 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} ); +=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 argyument +to the method + +=cut + +sub component { + my ( $r, $path ) = @_; + my $self = bless { parent => $r, config => $r->{config}, template_args => {}, }, ref $r; + $self->get_user; + my $url = URI->new($path); + warn "path : $path\n"; + $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. + +B. + +=cut + +# The root of all evil +sub handler_guts +{ + my ($self) = @_; + + $self->__load_request_model; + + my $applicable = $self->is_model_applicable == OK; - # 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 ) { + + # handle authentication + eval { $status = $self->call_authenticate }; + if ( my $error = $@ ) + { + $status = $self->call_exception($error, "authentication"); + 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 ) { - warn "caught model error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + $self->additional_data; + + if ($applicable) { + eval { $self->model_class->process($self) }; + if ( my $error = $@ ) + { + $status = $self->call_exception($error, "model"); + if ( $status != OK ) + { + warn "caught model error: $error"; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } + } else { + $self->__setup_plain_template; } - 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; + + # 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 + 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); } - else { return OK; } + } + return $type; +} + +sub __load_request_model +{ + my ($self) = @_; + $self->model_class( $self->config->model->class_of($self, $self->table) ); } -sub is_applicable { - 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) = @_; + + # 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 { $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 $status; +} + +=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"; +} + +=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 start_request_hook { } + +=item is_applicable + +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"; - warn "We don't have that table ($self->{table})" - if $self->debug - and not $config->ok_tables->{ $self->{table} }; - return DECLINED() unless exists $config->ok_tables->{ $self->{table} }; - - # Does the action method exist? - my $cv = $self->model_class->can( $self->{action} ); - warn "We don't have that action ($self->{action})" - if $self->debug and not $cv; - return DECLINED() unless $cv; - - # Is it exported? - $self->{method_attribs} = join " ", attributes::get($cv); - do { - warn "$self->{action} not exported" if $self->debug; - return DECLINED(); - } unless $self->{method_attribs} =~ /\bExported\b/i; - 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; + } + + 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 DECLINED; + } + + # Is the action public? + my $action = $self->action; + return OK if $self->model_class->is_public($action); + + warn "The action '$action' is not applicable to the table '$table'" + if $self->debug; + + return DECLINED; } -sub call_authenticate { - my $self = shift; +=item get_session - # 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 +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); } -sub call_exception { - my $self = shift; - my ($error) = @_; +=item authenticate + +Returns a Maypole::Constant to indicate whether the user is authenticated for +the Maypole request. + +The default implementation returns C + +=cut + +sub authenticate { return OK } + + +=item 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 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. + +=cut - # Check if we have a model class - if ( $self->{model_class} - && $self->model_class->can('exception') ) +sub call_exception +{ + my ($self, $error, $when) = @_; + + # 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 ); + my $status = $self->model_class->exception( $self, $error, $when ); return $status if $status == OK; } - return $self->exception($error); + + return $self->exception($error, $when); +} + + +=item exception + +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. + +=cut + +sub exception { + my ($self, $error, $when) = @_; + if ($self->view_object->can("report_error") and $self->debug) { + $self->view_object->report_error($self, $error, $when); + return OK; + } + return ERROR; } +=item 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. + +=cut + sub additional_data { } -sub authenticate { return OK } +=item send_output -sub exception { return ERROR } +Sends the output and additional headers to the user. -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; +=cut + +sub send_output { + die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; } -=head1 NAME -Maypole - MVC web application framework -=head1 SYNOPSIS -See L. +=back -=head1 DESCRIPTION +=head2 Path processing and manipulation -A large number of web programming tasks follow the same sort of pattern: -we have some data in a datasource, typically a relational database. We -have a bunch of templates provided by web designers. We have a number of -things we want to be able to do with the database - create, add, edit, -delete records, view records, run searches, and so on. We have a web -server which provides input from the user about what to do. Something in -the middle takes the input, grabs the relevant rows from the database, -performs the action, constructs a page, and spits it out. - -Maypole aims to be the most generic and extensible "something in the -middle" - an MVC-based web application framework. - -An example would help explain this best. You need to add a product -catalogue to a company's web site. Users need to list the products in -various categories, view a page on each product with its photo and -pricing information and so on, and there needs to be a back-end where -sales staff can add new lines, change prices, and delete out of date -records. So, you set up the database, provide some default templates -for the designers to customize, and then write an Apache handler like -this: - - package ProductDatabase; - use base 'Maypole::Application'; - __PACKAGE__->set_database("dbi:mysql:products"); - ProductDatabase->config->uri_base = "http://your.site/catalogue/"; - ProductDatabase::Product->has_a("category" => ProductDatabase::Category); - # ... - - sub authenticate { - my ($self, $request) = @_; - return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com"; - return OK if $request->{action} =~ /^(view|list)$/; - return DECLINED; +=over 4 + +=item path + +Returns the request path + +=item parse_path + +Parses the request path and sets the C, C and C +properties. Calls C before parsing path and setting properties. + +=cut + +sub parse_path +{ + my ($self) = @_; + + # 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; + $self->path || $self->path('frontpage'); + + my @pi = grep {length} split '/', $self->path; + + + $self->table || $self->table(shift @pi); + $self->action || $self->action( shift @pi or 'index' ); + $self->args || $self->args(\@pi); +} + +=item preprocess_path + +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. + +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. + +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 + +=cut + +sub preprocess_path { }; + +=item make_path( %args or \%args or @args ) + +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. + + %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 + +C can be used as an alternative key to C. + +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. + +=cut + +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; } - 1; + 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; +} + + + +=item make_uri( @segments ) + +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. + +=cut + +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; +} + +=item parse_args + +Turns post data and query string paramaters into a hash of C. + +You should only need to define this method if you are writing a new Maypole +backend. + +=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 + +=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. + + +=item objects + +Get/set a list of model objects. The objects will be accessible in the view +templates. + +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 template_args + + $self->template_args->{foo} = 'bar'; + +Get/set a hash of template variables. + +=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> + + +=item error + +Get/set a request error + +=item output + +Get/set the response output. This is usually populated by the view class. You +can skip view processing by setting the C. + +=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 -You then put the following in your Apache config: +Get/set the output encoding. Default: utf-8. - - SetHandler perl-script - PerlHandler ProductDatabase - +=item content_type -And copy the templates found in F into the -F directory off the web root. When the designers get -back to you with custom templates, they are to go in -F. If you need to do override templates on a -database-table-by-table basis, put the new template in -F>. +Get/set the output content type. Default: text/html -This will automatically give you C, C, C, C and -C commands; for instance, a product list, go to +=item get_protocol - http://your.site/catalogue/product/list +Returns the protocol the request was made with, i.e. https -For a full example, see the included "beer database" application. +=cut + +sub get_protocol { + die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} + +=back + +=head2 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. + +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: -=head1 HOW IT WORKS + $r->{params}->{foo} # bad + $r->params->{foo} # better -There's some documentation for the workflow in L, -but the basic idea is that a URL part like C gets -translated into a call to Clist>. This -propagates the request with a set of objects from the database, and then -calls the C template; first, a C template if it -exists, then the C and finally C. + $r->{query}->{foo} # bad + $r->query->{foo} # better -If there's another action you want the system to do, you need to either -subclass the model class, and configure your class slightly differently: + $r->param('foo') # best - package ProductDatabase::Model; - use base 'Maypole::Model::CDBI'; +=over 4 - sub supersearch :Exported { - my ($self, $request) = @_; - # Do stuff, get a bunch of objects back - $r->objects(\@objects); - $r->template("template_name"); +=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; +} -Then your top-level application package should change the model class: -(Before calling C) - ProductDatabase->config->model("ProductDatabase::Model"); +=item params -(The C<:Exported> attribute means that the method can be called via the -URL C/supersearch/...>.) +Returns a hashref of request parameters. -Alternatively, you can put the method directly into the specific model -class for the table: +B Where muliple values of a parameter were supplied, the C value +will be an array reference. - sub ProductDatabase::Product::supersearch :Exported { ... } +=item query -By default, the view class uses Template Toolkit as the template -processor, and the model class uses C; it may help you to be -familiar with these modules before going much further with this, -although I expect there to be other subclasses for other templating -systems and database abstraction layers as time goes on. The article at -C is a great -introduction to the process we're trying to automate. +Alias for C. -=head1 USING MAYPOLE +=back -You should probably not use Maypole directly. Maypole is an abstract -class which does not specify how to communicate with the outside world. -The most popular subclass of Maypole is L, which interfaces -the Maypole framework to Apache mod_perl; another important one is -L. However, if you just don't care, use Maypole::Application, -and it will choose the right one for you. +=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 + +$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. + +=cut + +sub redirect_request { + die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} -If you are implementing Maypole subclasses, you need to provide at least -the C and C methods. You may also want to -provide C and C. See the -L documentation for what these are expected to do. +=item redirect_internal_request =cut -sub get_template_root { "." } -sub get_request { } +sub redirect_internal_request { -sub parse_location { - die "Do not use Maypole directly; use Apache::MVC or similar"; } -sub send_output { - die "Do not use Maypole directly; use Apache::MVC or similar"; + +=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 wiki at the Maypole web site: +There's more documentation, examples, and information on our mailing lists +at the Maypole web site: -http://maypole.simon-cozens.org/ +L -L,L, L. +L, L, L. -=head1 MAINTAINER +=head1 AUTHOR -Sebastian Riedel, c +Maypole is currently maintained by Aaron Trevena. -=head1 AUTHOR +=head1 AUTHOR EMERITUS + +Simon Cozens, C -Simon Cozens, C +Simon Flack maintained Maypole from 2.05 to 2.09 -=head1 THANK YOU +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 -Danijel Milicevic, Jesse Scheidlower, Jody Belka, Marcus Ramberg, -Mickael Joanne, Simon Flack, Veljko Vidovic and all the others who've helped. +=head1 THANKS TO + +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 @@ -354,3 +1465,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: $@"; + } + } + } +} +