From 12d8a77a713d5ed4f08414e5f34e96d45f60e2d3 Mon Sep 17 00:00:00 2001 From: David Baird Date: Fri, 18 Nov 2005 16:41:04 +0000 Subject: [PATCH] Maypole::Application supports Maypole::HTTPD (which needs a patch). CGI::Maypole - split collect_output() out of send_output(), for Maypole::HTTPD. Added status attribute to request object, but only used by start_request_hook() so far. Refactored Mp::Model::CDBI::do_edit(), for better output in Mp-Plugin-Trace. git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@427 48953598-375a-da11-a14b-00016c27c3ee --- Changes | 14 ++- lib/Apache/MVC.pm | 2 +- lib/CGI/Maypole.pm | 22 ++++- lib/Maypole.pm | 148 ++++++++++++++++++++++++---- lib/Maypole/Application.pm | 44 +++++---- lib/Maypole/Manual/Terminology.pod | 6 +- lib/Maypole/Model/Base.pm | 4 +- lib/Maypole/Model/CDBI.pm | 86 ++++++++++------ t/03podcoverage.t | 2 +- t/maypole.t | 3 +- templates/{ => factory}/maypole.css | 0 wishlist.txt | 6 +- 12 files changed, 250 insertions(+), 87 deletions(-) rename templates/{ => factory}/maypole.css (100%) diff --git a/Changes b/Changes index 8067f8a..e0b8a50 100644 --- a/Changes +++ b/Changes @@ -17,23 +17,29 @@ Incompatible API changes: API additions and enhancements: Maypole::Application: - -Init flag (wishlist 14123) + - -Init flag (wishlist 14123) + - recognises Maypole::HTTPD and installs Maypole::HTTPD::Frontend + as its frontend Maypole::Headers: add() alias to push() (wishlist 14142) Maypole: - - session() attribute, and get_session() method (no-op) - - user() attribute, and get_user() method (no-op) - - get_session() now called during handler_guts() before authenticate() + - get_session() method (no-op) + - get_user() method (no-op) + - get_session() is called during handler_guts() before authenticate() - new preprocess_path() method added and called by parse_path(), parse_path() will leave any properties set by preprocess_path() in place - start_request_hook() added + - status() attribute added (though only used by start_request_hook() + so far) - setup() split into setup(), setup_model(), and load_model_subclass() - added new path processing methods for ssl and default table/action - added make_path() - added make_uri() Templates: - Improved pager macro/include + - added the status() attribute, although it's not used in many places + yet Bug fixes: Fix to cgi_maypole.t (bug 11346) diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 3bb33e6..4623b9f 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -82,7 +82,7 @@ functionality. See L for these: sub get_request { my ($self, $r) = @_; - my $ar = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->new($r); + my $ar = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->instance($r); $self->ar($ar); } diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm index 9b2ee79..b8a0a48 100644 --- a/lib/CGI/Maypole.pm +++ b/lib/CGI/Maypole.pm @@ -7,9 +7,9 @@ use CGI::Simple; use Maypole::Headers; use Maypole::Constants; -our $VERSION = '2.10'; +our $VERSION = '2.11'; -__PACKAGE__->mk_accessors( qw( cgi ) ); +__PACKAGE__->mk_accessors( qw/cgi/ ); =head1 NAME @@ -164,12 +164,28 @@ sub get_protocol =item send_output +Generates output (using C) and prints it. + =cut sub send_output { my $r = shift; + print $r->collect_output; +} + +=item collect_output + +Gathers headers and output together into a string and returns it. + +Splitting this code out of C supports L. +=cut + +sub collect_output +{ + my $r = shift; + # Collect HTTP headers my %headers = ( -type => $r->content_type, @@ -181,7 +197,7 @@ sub send_output $headers{"-$_"} = $r->headers_out->get($_); } - print $r->cgi->header(%headers), $r->output; + return $r->cgi->header(%headers) . $r->output; } =item get_template_root diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 087f2b9..dbae33b 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -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 user) + headers_in headers_out stash status) ); __PACKAGE__->config( Maypole::Config->new() ); @@ -243,6 +243,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 } @@ -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; } } @@ -433,13 +432,17 @@ sub handler : method # hook useful for declining static requests e.g. images, or perhaps for # sanitizing request parameters - my $status = $self->start_request_hook; - return $status unless $status == Maypole::Constants::OK(); + $self->status(Maypole::Constants::OK()); # set the default + $self->__call_hook('start_request_hook'); + return $self->status unless $self->status == Maypole::Constants::OK(); + + die "status undefined after start_request_hook()" unless defined + $self->status; - $self->session($self->get_session); - $self->user($self->get_user); + $self->get_session; + $self->get_user; - $status = $self->handler_guts; + my $status = $self->handler_guts; # moving this here causes unit test failures - need to check why # before committing the move @@ -453,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 @@ -602,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. +method does nothing. -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: +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. + +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 @@ -684,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; @@ -1328,3 +1386,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: $@"; + } + } + } +} + diff --git a/lib/Maypole/Application.pm b/lib/Maypole/Application.pm index 6804cde..ae95bb7 100644 --- a/lib/Maypole/Application.pm +++ b/lib/Maypole/Application.pm @@ -2,6 +2,7 @@ package Maypole::Application; use strict; use warnings; + use UNIVERSAL::require; use Maypole; use Maypole::Config; @@ -15,6 +16,8 @@ sub import { my $frontend = 'Apache::MVC' if $ENV{MOD_PERL}; + $frontend = 'Maypole::HTTPD::Frontend' if $ENV{MAYPOLE_HTTPD}; + my $masonx; if ( grep { /^MasonX$/ } @plugins ) { @@ -30,30 +33,31 @@ sub import { my $autosetup=0; my $autoinit=0; my @plugin_modules; + + foreach (@plugins) { - foreach (@plugins) { - if (/^\-Setup$/) { $autosetup++; } - elsif (/^\-Init$/) { $autoinit++ } - elsif (/^\-Debug(\d*)$/) { - my $d = $1 || 1; - no strict 'refs'; - *{"$caller\::debug"} = sub { $d }; - warn "Debugging (level $d) enabled for $caller"; - } - elsif (/^-.*$/) { warn "Unknown flag: $_" } - else { - my $plugin = "Maypole::Plugin::$_"; - if ($plugin->require) { - push @plugin_modules, "Maypole::Plugin::$_"; - warn "Loaded plugin: $plugin for $caller" - if $caller->can('debug') && $caller->debug; - } else { - die qq(Loading plugin "$plugin" for $caller failed: ) - . $UNIVERSAL::require::ERROR; - } + if (/^\-Setup$/) { $autosetup++; } + elsif (/^\-Init$/) { $autoinit++ } + elsif (/^\-Debug(\d*)$/) { + my $d = $1 || 1; + no strict 'refs'; + *{"$caller\::debug"} = sub { $d }; + warn "Debugging (level $d) enabled for $caller"; + } + elsif (/^-.*$/) { warn "Unknown flag: $_" } + else { + my $plugin = "Maypole::Plugin::$_"; + if ($plugin->require) { + push @plugin_modules, "Maypole::Plugin::$_"; + warn "Loaded plugin: $plugin for $caller" + if $caller->can('debug') && $caller->debug; + } else { + die qq(Loading plugin "$plugin" for $caller failed: ) + . $UNIVERSAL::require::ERROR; } } } + no strict 'refs'; push @{"${caller}::ISA"}, @plugin_modules, $frontend; $caller->config(Maypole::Config->new); diff --git a/lib/Maypole/Manual/Terminology.pod b/lib/Maypole/Manual/Terminology.pod index d7bf7f4..adc5dc8 100644 --- a/lib/Maypole/Manual/Terminology.pod +++ b/lib/Maypole/Manual/Terminology.pod @@ -151,7 +151,7 @@ The functionality provided by the Maypole model class is more accurately described as a Presentation Model (see below). In complex Maypole applications, it is good practise to separate the domain model (the 'heart' of the application) into a separate class hierarchy (see -L). The distinction is relatively unimportant when using Maypole in 'default' mode - i.e. using L, and allowing Maypole to autogenerate the @@ -179,6 +179,8 @@ point, the convenience of dropping new methods into the 'shared' classes will be outweighed by the heuristic advantage of separating different layers into separate class hierarchies. +=back + =head3 Presentation Model This pattern more accurately describes the role of the Maypole model. @@ -196,8 +198,6 @@ queries the Presentation Model to retrieve these new values. In Maypole, this is the role of the C method on L, which transmits the new values to the templates. -=back - =head1 AUTHOR David Baird, C<< >> diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm index 26288c2..338f0e8 100644 --- a/lib/Maypole/Model/Base.pm +++ b/lib/Maypole/Model/Base.pm @@ -4,6 +4,7 @@ use strict; use Maypole::Constants; use attributes (); +# don't know why this is a global - drb our %remember; sub MODIFY_CODE_ATTRIBUTES @@ -28,6 +29,7 @@ sub process { $r->{template} = $method; my $obj = $class->fetch_objects($r); $r->objects([$obj]) if $obj; + $class->$method( $r, $obj, @{ $r->{args} } ); } @@ -195,7 +197,7 @@ sub is_public return 1 if $attrs{Exported}; - warn "$action not exported" if Maypole->debug; + warn "'$action' not exported"; return 0; } diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index df8d6c8..6ae19f5 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -105,48 +105,70 @@ sub related_class { } -sub do_edit : Exported { - my ( $self, $r ) = @_; - my $h = CGI::Untaint->new( %{ $r->{params} } ); - my $creating = 0; - my ($obj) = @{ $r->objects || [] }; +sub do_edit : Exported +{ + my ($self, $r, $obj) = @_; + + my $config = $r->config; + my $table = $r->table; + + my $required_cols = $config->{$table}->{required_cols} || []; + + ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols); + + # handle errors, if none, proceed to view the newly created/updated object + my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; + + if (%errors) + { + # Set it up as it was: + $r->template_args->{cgi_params} = $r->params; + $r->template_args->{errors} = \%errors; + + undef $obj if $creating; + $r->template("edit"); + } + else + { + $r->template("view"); + } + + $r->objects( $obj ? [$obj] : []); +} + +# drb - I've (probably temporarily) split this out from do_edit, so it's +# reported by Mp::P::Trace +sub _do_update_or_create +{ + my ($self, $r, $obj, $required_cols) = @_; + my $fatal; - if ($obj) { + my $creating = 0; + my $h = CGI::Untaint->new( %{$r->params} ); + + # update or create + if ($obj) + { # We have something to edit - eval { - $obj->update_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); - }; + eval { $obj->update_from_cgi( $h => {required => $required_cols} ) }; $fatal = $@; } - else { - eval { - $obj = - $self->create_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); + else + { + eval { + $obj = $self->create_from_cgi( $h => {required => $required_cols} ) }; - if ($fatal = $@) { + + if ($fatal = $@) + { warn "$fatal" if $r->debug; } $creating++; } - if ( my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors ) { - - # Set it up as it was: - $r->{template_args}{cgi_params} = $r->{params}; - $r->{template_args}{errors} = \%errors; - - undef $obj if $creating; - $r->template("edit"); - } - else { - $r->{template} = "view"; - } - $r->objects( $obj ? [$obj] : []); + + return $obj, $fatal, $creating; } - + sub delete : Exported { return shift->SUPER::delete(@_) if caller ne "Maypole::Model::Base"; my ( $self, $r ) = @_; diff --git a/t/03podcoverage.t b/t/03podcoverage.t index d8d403d..fa45ce2 100644 --- a/t/03podcoverage.t +++ b/t/03podcoverage.t @@ -4,6 +4,6 @@ use strict; use Test::More; eval "use Test::Pod::Coverage 1.04"; -plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage ($@)" if $@; all_pod_coverage_ok({ also_private => [ qr/^[A-Z_]+$/ ], }); diff --git a/t/maypole.t b/t/maypole.t index 4a0cd02..9e49186 100755 --- a/t/maypole.t +++ b/t/maypole.t @@ -32,7 +32,8 @@ my @API = qw/ config init_done view_object params query param objects model_clas make_uri get_template_root get_request parse_location send_output start_request_hook - session get_session + get_session + get_user /; can_ok(Maypole => @API); diff --git a/templates/maypole.css b/templates/factory/maypole.css similarity index 100% rename from templates/maypole.css rename to templates/factory/maypole.css diff --git a/wishlist.txt b/wishlist.txt index 7ee5bfb..1ce65b5 100644 --- a/wishlist.txt +++ b/wishlist.txt @@ -12,7 +12,7 @@ Fix bug 14570 - returning error codes breaks CGI::Maypole Write Maypole::Manual::Exceptions Test and refactor external_redirect() -Fix Mp::P::USC +Fix Mp::P::USC. 2.12 ==== @@ -25,7 +25,9 @@ Handle repeat form submissions. Implement internal_redirect(). Build a more sophisticated app for testing. Move class_of() to the controller - need to do this to support multiple models. -Multiple model support. +Multiple model support - URLs like /$base/$model/$table/$action/$id. +Refactor M-P-USC and M-P-Session into M-P-User, M-P-Session, and M-P-Cookie + 3.0 ==== -- 2.39.5