X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=2f609d8b0496b1838e5069b403e1f5273afcdc1b;hb=f19715f56244cc6d862169c2dd656b8a2f3845b5;hp=b5de0c51ad4fb11ee52960f9e158dfbc9cc632fd;hpb=fcd546d12f9569c1acbab120b8e7c141bec8a0c2;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index b5de0c5..2f609d8 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -6,9 +6,12 @@ use warnings; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; +use Maypole::Components; use URI(); +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 @@ -38,7 +41,7 @@ The canonical example used in the Maypole documentation is the beer database: $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]]); + $config->display_tables([qw/beer brewery pub style/]); # table relationships $config->relationships([ @@ -76,8 +79,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.) @@ -194,23 +197,25 @@ synopsis of L for an example driver =cut -__PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); +__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); __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); +__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. Likely hooks include: +behaviour, others do nothing by default. Hooks include: Class methods ------------- @@ -243,6 +248,9 @@ 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 } @@ -303,19 +311,16 @@ sub setup_model foreach my $subclass ( @{ $config->classes } ) { - 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 - $class->load_model_subclass($subclass); - - $config->model->adopt($subclass) if $config->model->can("adopt"); - -# eval "use $subclass"; -# die "Error loading $subclass: $@" -# if $@ and $@ !~ /Can\'t locate \S+ in \@INC/; + 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 + $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); + + $config->model->adopt($subclass) if $config->model->can("adopt"); } } @@ -348,7 +353,7 @@ sub load_model_subclass (my $filename = $subclass) =~ s!::!/!g; die "Loading '$subclass' failed: $@\n" unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; - warn "Did not find external module for '$subclass'\n" + warn "No external module for '$subclass'" if $class->debug > 1; } } @@ -417,38 +422,77 @@ leaves the dirty work to C. # 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) = @_; +sub handler : method { + # See Maypole::Workflow before trying to understand this. + my ($class, $req) = @_; - $class->init unless $class->init_done; + $class->init unless $class->init_done; - my $self = $class->new; + my $self = $class->new; - # initialise the request - $self->headers_out(Maypole::Headers->new); - $self->get_request($req); - $self->parse_location; + # 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 - 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(); - $self->session($self->get_session); + die "status undefined after start_request_hook()" unless defined + $self->status; - $status = $self->handler_guts; + $self->get_session; + $self->get_user; - # moving this here causes unit test failures - need to check why - # before committing the move - #$status = $self->__call_process_view unless $self->output; + my $status = $self->handler_guts; + return $status unless $status == OK; + + # TODO: require send_output to return a status code + $self->send_output; + + return $status; +} + +sub component { + my $component = Maypole::Components->new(@_); + return $component->handler; +} + + +# 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) = @_; - return $status unless $status == OK; + my @plugins; + { + my $class = ref($self); + no strict 'refs'; + @plugins = @{"$class\::ISA"}; + } - # TODO: require send_output to return a status code - $self->send_output; + # 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; - return $status; + 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 @@ -477,7 +521,7 @@ sub handler_guts if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "authentication"); if ( $status != OK ) { @@ -504,7 +548,7 @@ sub handler_guts if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "model"); if ( $status != OK ) { @@ -517,9 +561,32 @@ sub handler_guts # less frequent path - perhaps output has been set to an error message return OK if $self->output; - + # normal path - no output has been generated yet - return $self->__call_process_view; + 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; + if ($self->path =~ m/.*\.(\w{3,4})$/) { + $type = $filetypes{$1}; + } else { + $type = $mmagic->checktype_contents($self->output); + } + return $type; } sub __load_request_model @@ -557,7 +624,7 @@ sub __call_process_view if ( my $error = $@ ) { - $status = $self->call_exception($error); + $status = $self->call_exception($error, "view"); if ( $status != OK ) { @@ -600,23 +667,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 @@ -682,20 +771,38 @@ 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" - if $self->debug; + warn "The action '$action' is not applicable to the table '$table'" + if $self->debug; return 0; } =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 @@ -745,18 +852,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 @@ -766,7 +874,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 @@ -818,11 +933,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); @@ -1198,7 +1313,7 @@ calls during processing of a request. This is a brief summary: | | | |-----+ init | | ||<---+ | | - || | new | view_object: e.g + || | new | view_object: e.g. ||---------------------------------------------> Maypole::View::TT | | | | | | | | @@ -1228,6 +1343,9 @@ calls during processing of a request. This is a brief summary: | ||-----+ get_session | | | | |||<---+ | | | | || | | | + | ||-----+ get_user | | | + | |||<---+ | | | + | || | | | | ||-----+ handler_guts | | | | |||<---+ | | | | ||| class_of($table) | | | @@ -1243,14 +1361,14 @@ calls during processing of a request. This is a brief summary: | ||| | | | | |||-----+ additional_data | | | | ||||<---+ | | | - | ||| process | | fetch_objects - | |||--------------------------------->||-----+ | + | ||| process | | | + | |||--------------------------------->|| fetch_objects + | ||| | ||-----+ | | ||| | |||<---+ | | ||| | || | | ||| | || $action | ||| | ||-----+ | - | ||| | |||<---+ | - | ||| | | | + | ||| | |||<---+ | | ||| process | | | | |||------------------------------------------->|| template | ||| | | ||-----+ @@ -1304,3 +1422,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: $@"; + } + } + } +} +