X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=85d471f33f43369b3d94370cc672aad065d47d10;hb=3e978894e009cbd57ad9376c29a0de845ad5e6de;hp=cd9ec49951099656ed7325290a5f9dcf1f020a22;hpb=4043f9681bc177aa9ba86effd589c7cccf4b6783;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index cd9ec49..85d471f 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -22,7 +22,45 @@ Maypole - MVC web application framework =head1 SYNOPSIS -See L. +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 @@ -38,8 +76,8 @@ 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 +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.) @@ -161,17 +199,57 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path args action template error document_encoding content_type table - headers_in headers_out stash session) + headers_in headers_out stash status) ); __PACKAGE__->config( Maypole::Config->new() ); __PACKAGE__->init_done(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 } + =item config Returns the L object @@ -205,38 +283,75 @@ 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 $calling_class = shift; + my $class = shift; - $calling_class = ref $calling_class if ref $calling_class; + $class = ref $class if ref $class; - my $config = $calling_class->config; + 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, $@; - $config->model->setup_database($config, $calling_class, @_); + # among other things, this populates $config->classes + $config->model->setup_database($config, $class, @_); foreach my $subclass ( @{ $config->classes } ) { no strict 'refs'; unshift @{ $subclass . "::ISA" }, $config->model; - $config->model->adopt($subclass) - if $config->model->can("adopt"); - - # TODO: I think we should also load these classes, in case there is any - # custom code. It would save the developer from needing to put - # lots of use MyApp::SomeTable statements in the driver, and should - # help eliminate some of those annoying silent errors if there's a - # syntax error. + + # 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 + $class->load_model_subclass($subclass); + + $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, perhaps during development, 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. @@ -281,30 +396,6 @@ sub new Get/set the Maypole::View object -=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. - -=cut - -sub debug { 0 } - -=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 - -sub get_template_root {'.'} - =back =head1 INSTANCE METHODS @@ -339,13 +430,19 @@ sub handler : method $self->get_request($req); $self->parse_location; - # hook useful for declining static requests e.g. images - my $status = $self->start_request_hook; - return $status unless $status == Maypole::Constants::OK(); + # 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->get_session; + $self->get_user; - $status = $self->handler_guts; + my $status = $self->handler_guts; # moving this here causes unit test failures - need to check why # before committing the move @@ -359,6 +456,39 @@ sub handler : method return $status; } +# 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 @@ -373,7 +503,7 @@ sub handler_guts { my ($self) = @_; - $self->__load_model; + $self->__load_request_model; my $applicable = $self->is_model_applicable; @@ -385,7 +515,7 @@ sub handler_guts if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "authentication"); if ( $status != OK ) { @@ -412,7 +542,7 @@ sub handler_guts if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "model"); if ( $status != OK ) { @@ -430,7 +560,7 @@ sub handler_guts return $self->__call_process_view; } -sub __load_model +sub __load_request_model { my ($self) = @_; $self->model_class( $self->config->model->class_of($self, $self->table) ); @@ -465,7 +595,7 @@ sub __call_process_view if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "view"); if ( $status != OK ) { @@ -508,23 +638,45 @@ sub parse_location =item start_request_hook This is called immediately after setting up the basic request. The default -method simply returns C. +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. -Any other return value causes Maypole to abort further processing of the -request. 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: +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) = @_; - return Maypole::Constants::DECLINED if $r->path =~ /\.jpg$/; - return Maypole::Constants::OK; + $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 { Maypole::Constants::OK } +sub start_request_hook { } =item is_applicable @@ -590,7 +742,7 @@ sub is_model_applicable my $action = $self->action; return 1 if $self->model_class->is_public($action); - warn "The action '$action' is not applicable to the table $table" + warn "The action '$action' is not applicable to the table '$table'" if $self->debug; return 0; @@ -598,12 +750,30 @@ sub is_model_applicable =item get_session +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 @@ -653,18 +823,19 @@ exception method of your Maypole application. sub call_exception { - my ($self, $error) = @_; + 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 @@ -674,7 +845,14 @@ processed. =cut -sub exception { return ERROR } +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 @@ -726,11 +904,11 @@ sub parse_path $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); @@ -849,6 +1027,25 @@ 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 + +sub get_template_root {'.'} + =back =head2 Request properties @@ -1005,6 +1202,8 @@ Alias for C. =head3 Utility methods +=over 4 + =item redirect_request Sets output headers to redirect based on the arguments provided @@ -1055,9 +1254,113 @@ sub make_random_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 @@ -1066,12 +1369,15 @@ L, L, L. =head1 AUTHOR -Maypole is currently maintained by Aaron Trevena +Maypole is currently maintained by Aaron Trevena, David Baird, Dave Howorth and +Peter Speltz. =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 @@ -1087,3 +1393,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: $@"; + } + } + } +} +