X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=bc4a5aac96d06376fbb7a01b4bd704adab4f2939;hb=db969aff8709f53ce4c7494166feb308008264e0;hp=bcd0b3ab0d6ff7f6bd12f858b3ab40bab1276e2f;hpb=7913f720113bfd85b59a9fed57a60ec7a665fb39;p=maypole.git

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index bcd0b3a..bc4a5aa 100644
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -5,35 +5,43 @@ use strict;
 use warnings;
 use Maypole::Config;
 use Maypole::Constants;
+use Maypole::Headers;
 
-our $VERSION = '2.05';
+our $VERSION = '2.10';
+
+# 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
 
 __PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
 __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 )
 );
 __PACKAGE__->config( Maypole::Config->new() );
 __PACKAGE__->init_done(0);
 
 sub debug { 0 }
 
-sub setup {
+sub setup 
+{
     my $calling_class = shift;
+    
     $calling_class = ref $calling_class if ref $calling_class;
-    {
-        no strict 'refs';
-
-        # 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 } ) {
+    
+    $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, @_);
+    
+    foreach my $subclass ( @{ $config->classes } ) 
+    {
         no strict 'refs';
         unshift @{ $subclass . "::ISA" }, $config->model;
         $config->model->adopt($subclass)
@@ -41,7 +49,8 @@ sub setup {
     }
 }
 
-sub init {
+sub init 
+{
     my $class  = shift;
     my $config = $class->config;
     $config->view || $config->view("Maypole::View::TT");
@@ -54,117 +63,217 @@ sub init {
 
 }
 
-sub handler {
-
+# 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 <http://modperlbook.org/html/ch25_01.html>
+sub handler : method 
+{
     # See Maypole::Workflow before trying to understand this.
-    my ( $class, $req ) = @_;
+    my ($class, $req) = @_;
+    
     $class->init unless $class->init_done;
-    my $r = bless { template_args => {}, config => $class->config }, $class;
+
+    # Create the request object
+    my $r = bless {
+        template_args => {},
+        config        => $class->config
+    }, $class;
+    
+    $r->headers_out(Maypole::Headers->new);
+    
     $r->get_request($req);
-    $r->parse_location();
-    my $status = $r->handler_guts();
+    
+    $r->parse_location;
+    
+    my $status = $r->handler_guts;
+    
+    # moving this here causes unit test failures - need to check why
+    # before committing the move
+    #$status = $r->__call_process_view unless $r->output;
+    
     return $status unless $status == OK;
+    
     $r->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} );
-    }
-
+sub handler_guts 
+{
+    my ($r) = @_;
+    
+    $r->__load_model;
+
+    my $applicable = __to_boolean $r->is_applicable;
+    
+    $r->__setup_plain_template unless $applicable;
+    
     # We authenticate every request, needed for proper session management
     my $status;
+    
     eval { $status = $r->call_authenticate };
-    if ( my $error = $@ ) {
+    
+    if ( my $error = $@ ) 
+    {
         $status = $r->call_exception($error);
-        if ( $status != OK ) {
+        
+        if ( $status != OK ) 
+        {
             warn "caught authenticate error: $error";
-            return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+            return $r->debug ? $r->view_object->error($r, $error) : ERROR;
         }
     }
-    if ( $r->debug and $status != OK and $status != DECLINED ) {
+    
+    if ( $r->debug and $status != OK and $status != DECLINED ) 
+    {
         $r->view_object->error( $r,
             "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 ) {
+    
+    if ($applicable) 
+    {
         eval { $r->model_class->process($r) };
-        if ( my $error = $@ ) {
+        
+        if ( my $error = $@ ) 
+        {
             $status = $r->call_exception($error);
-            if ( $status != OK ) {
+            
+            if ( $status != OK ) 
+            {
                 warn "caught model error: $error";
-                return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+                return $r->debug ? $r->view_object->error($r, $error) : ERROR;
             }
         }
     }
-    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;
-            }
+    
+    # unusual path - perhaps output has been set to an error message
+    return OK if $r->output;
+    
+    # normal path - no output has been generated yet
+    return $r->__call_process_view;
+}
+
+# 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 ($r) = @_;
+    
+    # It's just a plain template
+    $r->model_class(undef);
+    
+    my $path = $r->path;
+    $path =~ s{/$}{};    # De-absolutify
+    $r->path($path);
+    
+    $r->template($r->path);
+}
+
+# The model has been processed or skipped (if is_applicable returned false), 
+# any exceptions have been handled, and there's no content in $r->output
+sub __call_process_view
+{
+    my ($r) = @_;
+    
+    my $status;
+    
+    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;
     }
-    else { return OK; }
+    
+    return $status;
 }
 
-sub is_applicable {
-    my $self   = shift;
-    my $config = $self->config;
+sub __load_model
+{
+    my ($r) = @_;
+    $r->model_class( $r->config->model->class_of($r, $r->table) );
+}
+
+# is_applicable() should return true or false, not OK or DECLINED, because 
+# the return value is never used as the return value from handler(). There's 
+# probably a lot of code out there supplying the return codes though, so instead 
+# of changing is_applicable() to return 0 or 1, the return value is passed through 
+# __to_boolean. I think it helps handler_guts() if we don't have multiple sets of 
+# return codes being checked for different things.
+sub is_applicable 
+{
+    my ($r) = @_;
+    
+    my $config = $r->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"
+      
+    my $table = $r->table;
+    
+    warn "We don't have that table ($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} };
+      . join( ",", @{ $config->display_tables } )
+            if $r->debug
+                and not $config->ok_tables->{$table}
+                        and $r->action; # I think this is always true
+                        
+    return DECLINED unless exists $config->ok_tables->{$table};
 
     # Is it public?
-    return DECLINED unless $self->model_class->is_public( $self->{action} );
-    return OK();
+    return DECLINED unless $r->model_class->is_public( $r->action );
+    
+    return OK;
 }
 
-sub call_authenticate {
-    my $self = shift;
+# *only* intended for translating the return code from is_applicable()
+sub __to_boolean ($) { $_[0] == OK ? 1 : 0 }
+
+
+
+sub call_authenticate 
+{
+    my ($r) = @_;
 
     # 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
+    return $r->model_class->authenticate($r) 
+        if  $r->model_class 
+        and $r->model_class->can('authenticate');
+    
+    # passing $r is unnecessary and redundant, but there's probably 
+    # a lot of code out there now using the 2nd instead of the 1st $r,
+    # so we may as well leave it
+    return $r->authenticate($r);   
 }
 
-sub call_exception {
-    my $self = shift;
-    my ($error) = @_;
+sub call_exception 
+{
+    my ($r, $error) = @_;
 
     # Check if we have a model class
-    if (   $self->{model_class}
-        && $self->model_class->can('exception') )
+    if ( $r->model_class && $r->model_class->can('exception') )
     {
-        my $status = $self->model_class->exception( $self, $error );
+        my $status = $r->model_class->exception( $r, $error );
         return $status if $status == OK;
     }
-    return $self->exception($error);
+    
+    return $r->exception($error);
 }
 
 sub additional_data { }
@@ -173,17 +282,38 @@ sub authenticate { return OK }
 
 sub exception { return ERROR }
 
-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;
+sub parse_path 
+{
+    my ($r) = @_;
+    
+    $r->path || $r->path('frontpage');
+    
+    my @pi = grep {length} split '/', $r->path;
+    
+    $r->table(shift @pi);
+    
+    $r->action( shift @pi or 'index' );
+    
+    $r->args(\@pi);
 }
 
-sub get_template_root { "." }
+# like CGI::param(), but read only 
+sub param 
+{ 
+    my ($r, $key) = @_;
+    
+    return keys %{$r->params} unless defined $key;
+    
+    return unless exists $r->params->{$key};
+    
+    my $val = $r->params->{$key};
+    
+    return ref $val ? @$val : ($val) if wantarray;
+        
+    return ref $val ? $val->[0] : $val;
+}
+
+sub get_template_root {'.'}
 sub get_request       { }
 
 sub parse_location {
@@ -194,6 +324,13 @@ sub send_output {
     die "Do not use Maypole directly; use Apache::MVC or similar";
 }
 
+# Session and Repeat Submission Handling
+
+sub make_random_id {
+    use Maypole::Session;
+    return Maypole::Session::generate_unique_id();
+}
+
 =head1 NAME
 
 Maypole - MVC web application framework
@@ -204,8 +341,22 @@ See L<Maypole::Application>.
 
 =head1 DESCRIPTION
 
-This documents the Maypole request object. For user documentation, see
-L<Maypole::Manual>.
+This documents the Maypole request object. See the L<Maypole::Manual>, 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 package which represents your entire
+application. In our example above, this is the C<BeerDB> package.
+
+This needs to first use L<Maypole::Application> which will make your package
+inherit from the appropriate platform driver such as C<Apache::MVC> or
+C<CGI::Maypole>, and then call setup.  This sets up the model classes and
+configures your application. The default model class for Maypole uses
+L<Class::DBI> to map a database to classes, but this can be changed by altering
+configuration. (B<Before> calling setup.)
 
 =head2 CLASS METHODS
 
@@ -274,6 +425,14 @@ A list of remaining parts of the request path after table and action
 have been
 removed
 
+=head3 headers_in
+
+A L<Maypole::Headers> object containing HTTP headers for the request
+
+=head3 headers_out
+
+A L<HTTP::Headers> object that contains HTTP headers for the output
+
 =head3 parse_args
 
 Turns post data and query string paramaters into a hash of C<params>.
@@ -282,12 +441,15 @@ You should only need to define this method if you are writing a new
 Maypole
 backend.
 
+=head3 param
+
+An accessor for request parameters. It behaves similarly to CGI::param() for
+accessing CGI parameters.
+
 =head3 params
 
-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
+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.
 
 B<Note:> Where muliple values of a parameter were supplied, the
@@ -297,7 +459,7 @@ will be an array reference.
 
 =head3 get_template_root
 
-Implimentation-specific path to template root.
+Implementation-specific path to template root.
 
 You should only need to define this method if you are writing a new
 Maypole
@@ -314,7 +476,7 @@ or CGI request object, it defaults to blank.
 
 Returns a Maypole::Constant to indicate whether the request is valid.
 
-The default implimentation checks that C<$r-E<gt>table> is publicly
+The default implementation checks that C<$r-E<gt>table> is publicly
 accessible
 and that the model class is configured to handle the C<$r-E<gt>action>
 
@@ -324,7 +486,7 @@ Returns a Maypole::Constant to indicate whether the user is
 authenticated for
 the Maypole request.
 
-The default implimentation returns C<OK>
+The default implementation returns C<OK>
 
 =head3 model_class
 
@@ -403,14 +565,17 @@ authenticate method of your Maypole application.
 
 =head3 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 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.
 
+=head3 make_random_id
+
+returns a unique id for this request can be used to prevent or detect repeat submissions.
 
 =head3 handler
 
@@ -423,26 +588,28 @@ This is the core of maypole. You don't want to know.
 
 =head1 SEE ALSO
 
-There's more documentation, examples, and a wiki at the Maypole web
-site:
+There's more documentation, examples, and a information on our mailing lists
+at the Maypole web site:
 
-http://maypole.perl.org/
+L<http://maypole.perl.org/>
 
-L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
+L<Maypole::Application>, L<Apache::MVC>, L<CGI::Maypole>.
 
 =head1 AUTHOR
 
-Sebastian Riedel, c<sri@oook.de>
+Maypole is currently maintained by Simon Flack C<simonflk#cpan.org>
 
 =head1 AUTHOR EMERITUS
 
-Simon Cozens, C<simon@cpan.org>
+Simon Cozens, C<simon#cpan.org>
+
+Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
 
 =head1 THANKS TO
 
-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.
+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