]> git.decadent.org.uk Git - maypole.git/blobdiff - lib/Maypole.pm
simon cozens debug page and improved exceptions
[maypole.git] / lib / Maypole.pm
index b84360cc0262e9e4e77dc6ebf41b05f8d876fccc..85d471f33f43369b3d94370cc672aad065d47d10 100644 (file)
@@ -38,7 +38,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([
@@ -199,7 +199,7 @@ __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() );
@@ -210,7 +210,7 @@ __PACKAGE__->init_done(0);
 
 As a framework, Maypole provides a number of B<hooks> - 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 +243,9 @@ enable/disable debugging.
 
 You can also set the C<debug> flag via L<Maypole::Application>.
 
+Some packages respond to higher debug levels, try increasing it to 2 or 3.
+
+
 =cut
 
 sub debug { 0 }      
@@ -312,10 +315,6 @@ sub setup_model
         $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/;
     }
 }
 
@@ -348,7 +347,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;
    }
 }
@@ -431,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();
     
-    $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;
+    
+    my $status = $self->handler_guts;
     
     # moving this here causes unit test failures - need to check why
     # before committing the move
@@ -451,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
@@ -477,7 +515,7 @@ sub handler_guts
     
     if ( my $error = $@ ) 
     {
-        $status = $self->call_exception($error);
+        $status = $self->call_exception($error, "authentication");
         
         if ( $status != OK ) 
         {
@@ -504,7 +542,7 @@ sub handler_guts
         
         if ( my $error = $@ ) 
         {
-            $status = $self->call_exception($error);
+            $status = $self->call_exception($error, "model");
             
             if ( $status != OK ) 
             {
@@ -557,7 +595,7 @@ sub __call_process_view
     
     if ( my $error = $@ ) 
     {
-        $status = $self->call_exception($error);
+        $status = $self->call_exception($error, "view");
         
         if ( $status != OK ) 
         {
@@ -600,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<Maypole::Constants::OK>.
+method does nothing. 
+
+The value of C<< $r->status >> is set to C<OK> before this hook is run. Your 
+implementation can change the status code, or leave it alone. 
 
-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:
+After this hook has run, Maypole will check the value of C<status>. For any
+value other than C<OK>, Maypole returns the C<status> 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) = @_;
        
-       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<status>
+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,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;
@@ -690,12 +750,30 @@ sub is_model_applicable
 
 =item get_session
 
+Called immediately after C<start_request_hook()>.
+
+This method should return a session, which will be stored in the request's
+C<session> attribute.
+
 The default method is empty. 
 
 =cut
 
 sub get_session { }
 
+=item get_user
+
+Called immediately after C<get_session>.
+
+This method should return a user, which will be stored in the request's C<user>
+attribute.
+
+The default method is empty.
+
+=cut
+
+sub get_user {}
+
 =item call_authenticate
 
 This method first checks if the relevant model class
@@ -745,16 +823,16 @@ 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);
 }
 
 
@@ -767,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
 
@@ -1199,7 +1284,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
            |                        |                  |          |
            |                        |                  |          |
@@ -1229,6 +1314,9 @@ calls during processing of a request. This is a brief summary:
             |         ||-----+ get_session         |       |         |
             |         |||<---+                     |       |         |
             |         ||                           |       |         |
+            |         ||-----+ get_user            |       |         |
+            |         |||<---+                     |       |         |
+            |         ||                           |       |         |
             |         ||-----+ handler_guts        |       |         |
             |         |||<---+                     |       |         |
             |         |||     class_of($table)     |       |         |
@@ -1244,14 +1332,14 @@ calls during processing of a request. This is a brief summary:
             |         |||                          |       |         |
             |         |||-----+ additional_data    |       |         |
             |         ||||<---+                    |       |         |
-            |         |||             process      |       |   fetch_objects
-            |         |||--------------------------------->||-----+  |
+            |         |||             process      |       |         |
+            |         |||--------------------------------->||  fetch_objects
+            |         |||                          |       ||-----+  |
             |         |||                          |       |||<---+  |
             |         |||                          |       ||        |
             |         |||                          |       ||   $action
             |         |||                          |       ||-----+  |
-            |         |||                          |       |||<---+  |
-            |         |||                          |       |         |
+            |         |||                          |       |||<---+  |            
             |         |||         process          |       |         |
             |         |||------------------------------------------->|| template
             |         |||                          |       |         ||-----+
@@ -1305,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<Apache>'s C<register_cleanup>. 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
+C<DESTROY>ed.
+
+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: $@";
+            }
+        }        
+    }    
+}
+