Removed last direct accesses to hash keys. Broke

[maypole.git] / lib / Maypole.pm

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index cb5e50ea04f38211eabfdf5787f4053b24a6767f..bc4a5aac96d06376fbb7a01b4bd704adab4f2939 100644 (file)
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -7,11 +7,16 @@ use Maypole::Config;
 use Maypole::Constants;
 use Maypole::Headers;
 
 use Maypole::Constants;
 use Maypole::Headers;
 

-our $VERSION = '2.09';
+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
+    qw( params query objects model_class template_args output path

         args action template error document_encoding content_type table
         headers_in headers_out )
 );
         args action template error document_encoding content_type table
         headers_in headers_out )
 );


@@ -20,23 +25,23 @@ __PACKAGE__->init_done(0);
 
 sub debug { 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';
-        no warnings 'redefine';
-
-        # 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)


@@ -44,7 +49,8 @@ sub setup {
     }
 }
 
     }
 }
 

-sub init {
+sub init 
+{

     my $class  = shift;
     my $config = $class->config;
     $config->view || $config->view("Maypole::View::TT");
     my $class  = shift;
     my $config = $class->config;
     $config->view || $config->view("Maypole::View::TT");


@@ -57,10 +63,16 @@ 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.
     # See Maypole::Workflow before trying to understand this.

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

     $class->init unless $class->init_done;
 
     # Create the request object
     $class->init unless $class->init_done;
 
     # Create the request object


@@ -68,113 +80,200 @@ sub handler {
         template_args => {},
         config        => $class->config
     }, $class;
         template_args => {},
         config        => $class->config
     }, $class;

+    

     $r->headers_out(Maypole::Headers->new);
     $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 { }


@@ -183,35 +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 = $self->{path} =~ m{([^/]+)/?}g;
-    $self->{table}  = shift @pi;
-    $self->{action} = shift @pi;
-    $self->{action} ||= "index";
-    $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 param { # like CGI::param(), but read-only
-    my $r = shift;
-    my ($key) = @_;
-    if (defined $key) {
-        unless (exists $r->{params}{$key}) {
-            return wantarray() ? () : undef;
-        }
-        my $val = $r->{params}{$key};
-        if (wantarray()) {
-            return ref $val ? @$val : $val;
-        } else {
-            return ref $val ? $val->[0] : $val;
-        }
-    } else {
-        return keys %{$r->{params}};
-    }
+# 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_template_root {'.'}

 sub get_request       { }
 
 sub parse_location {
 sub get_request       { }
 
 sub parse_location {


@@ -222,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


@@ -464,6 +573,9 @@ 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.
 
 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