Removed last direct accesses to hash keys. Broke

[maypole.git] / lib / Maypole.pm

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index 802769378b508f554b06caf549658eca76e6cdcb..bc4a5aac96d06376fbb7a01b4bd704adab4f2939 100644 (file)
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -5,35 +5,43 @@ use strict;
 use warnings;
 use Maypole::Config;
 use Maypole::Constants;
 use warnings;
 use Maypole::Config;
 use Maypole::Constants;

+use Maypole::Headers;

 
 

-our $VERSION = '2.02';
+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(
 
 __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 }
 
 );
 __PACKAGE__->config( Maypole::Config->new() );
 __PACKAGE__->init_done(0);
 
 sub debug { 0 }
 

-sub setup {
+sub setup 
+{

     my $calling_class = shift;
     my $calling_class = shift;

+    

     $calling_class = ref $calling_class if ref $calling_class;
     $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;
     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)
         no strict 'refs';
         unshift @{ $subclass . "::ISA" }, $config->model;
         $config->model->adopt($subclass)


@@ -41,130 +49,231 @@ sub setup {
     }
 }
 
     }
 }
 

-sub init {
+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
     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);
 
 }
 
     $class->view_object( $class->config->view->new );
     $class->init_done(1);
 
 }
 

-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.
     # See Maypole::Workflow before trying to understand this.

-    my ( $class, $req ) = @_;
+    my ($class, $req) = @_;
+    

     $class->init unless $class->init_done;
     $class->init unless $class->init_done;

-    my $r = bless { 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->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;
     return $status unless $status == OK;

+    

     $r->send_output;
     $r->send_output;

+    

     return $status;
 }
 
 # The root of all evil
     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;
     # We authenticate every request, needed for proper session management
     my $status;

+    

     eval { $status = $r->call_authenticate };
     eval { $status = $r->call_authenticate };

-    if ( my $error = $@ ) {
+    
+    if ( my $error = $@ ) 
+    {

         $status = $r->call_exception($error);
         $status = $r->call_exception($error);

-        if ( $status != OK ) {
+        
+        if ( $status != OK ) 
+        {

             warn "caught authenticate error: $error";
             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" );
     }
         $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;
     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) };
         eval { $r->model_class->process($r) };

-        if ( my $error = $@ ) {
+        
+        if ( my $error = $@ ) 
+        {

             $status = $r->call_exception($error);
             $status = $r->call_exception($error);

-            if ( $status != OK ) {
+            
+            if ( $status != OK ) 
+            {

                 warn "caught model error: $error";
                 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 || $config->ok_tables( $config->display_tables );

+    

     $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } )
       if ref $config->ok_tables eq "ARRAY";
     $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: "
       . "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?
 
     # 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
 
     # 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
 
     # 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 $status if $status == OK;
     }

-    return $self->exception($error);
+    
+    return $r->exception($error);

 }
 
 sub additional_data { }
 }
 
 sub additional_data { }


@@ -173,17 +282,38 @@ sub authenticate { return OK }
 
 sub exception { return ERROR }
 
 
 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 {
 sub get_request       { }
 
 sub parse_location {


@@ -194,6 +324,13 @@ sub send_output {
     die "Do not use Maypole directly; use Apache::MVC or similar";
 }
 
     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
 =head1 NAME
 
 Maypole - MVC web application framework


@@ -204,8 +341,22 @@ See L<Maypole::Application>.
 
 =head1 DESCRIPTION
 
 
 =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
 
 
 =head2 CLASS METHODS
 


@@ -274,6 +425,14 @@ A list of remaining parts of the request path after table and action
 have been
 removed
 
 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>.
 =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.
 
 Maypole
 backend.
 

+=head3 param
+
+An accessor for request parameters. It behaves similarly to CGI::param() for
+accessing CGI parameters.
+

 =head3 params
 
 =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
 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
 
 
 =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
 
 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.
 
 
 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>
 
 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.
 
 authenticated for
 the Maypole request.
 

-The default implimentation returns C<OK>
+The default implementation returns C<OK>

 
 =head3 model_class
 
 
 =head3 model_class
 


@@ -403,14 +565,17 @@ authenticate method of your Maypole application.
 
 =head3 call_exception
 
 
 =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.
 
 
 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
 
 
 =head3 handler
 


@@ -423,26 +588,28 @@ This is the core of maypole. You don't want to know.
 
 =head1 SEE ALSO
 
 
 =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
 
 
 =head1 AUTHOR
 

-Sebastian Riedel, c<sri@oook.de>
+Maypole is currently maintained by Simon Flack C<simonflk#cpan.org>

 
 =head1 AUTHOR EMERITUS
 
 
 =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
 
 
 =head1 THANKS TO
 

-Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka, Marcus Ramberg,
-Mickael Joanne, Simon Flack, 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
 
 
 =head1 LICENSE