From: Ben Hutchings Date: Tue, 4 Nov 2008 03:31:30 +0000 (+0000) Subject: Merge commit '2.11+2.111' into HEAD X-Git-Tag: 2.11+2.111-1~23 X-Git-Url: https://git.decadent.org.uk/gitweb/?a=commitdiff_plain;h=83769a6653a8736141d035a8a963c6cc99970a17;hp=73df58543e31b805fe123e4e818ab863eaac07de;p=maypole.git Merge commit '2.11+2.111' into HEAD --- diff --git a/AUTHORS b/AUTHORS index 3651033..34ec949 100644 --- a/AUTHORS +++ b/AUTHORS @@ -3,17 +3,20 @@ AUTHORS The following people have written and documented Maypole: -Simon Cozens - Original Author -Sebastian Riedel - Maintainer -Simon Flack - Maintainer -Aaron Trevena - Maintainer -Dave Howarth - Contributor +Simon Cozens - Author Emeritus +Sebastian Riedel - Maintainer (1.x to 2.x) +Simon Flack - Maintainer ( 2.x to 2.9 ) +Aaron Trevena - Maintainer (2.10 to present) +Dave Howorth - Developer +David Baird - Developer Thanks also to for fixes and other contributions: Randal Schwartz Jester -David Baird -David Howorth Marcus Ramberg Steven Simms +Kevin Connor +Dagfinn Ilmari Mannsåker +Danijel Milicevic +Dave Slack diff --git a/Changes b/Changes index 030e9ff..3f69490 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,126 @@ This file documents the revision history for Perl extension Maypole. For information about current developments and future releases, see: http://maypole.perl.org/?TheRoadmap +2.111 Sat 21 April 2007 + +Fixes : + Fixed typo in edit form template + Fixed extra html filter in link macro in factory templates + Fixed typo in _do_update_or_create (bug 26495) + fix to display_line macro in factory templates (bug 22920) + fixed template path with array refs + fixed redirect_request + fixed db_colinfo.t test when no mysql + + +2.11 Mon 31 July 2006 + +SVN revision 519 + +Deprecated: + Directly accessing the attributes of the request object, or the parameters + in $r->params, or anything else, is DEPRECATED and likely to break in future + releases. Be good, and use proper method calls. + + Maypole no longer uses Class::DBI::AsForm, instead Maypole::Model::CDBI::AsForm + has replaced it. + + $config->{$table}{required_cols} is deprecated, please use $class->required_columns instead + + +Incompatible API changes: + Maypole + - is_applicable() deprecated for is_model_applicable(). is_applicable is + an alias for is_model_applicable now. + Maypole::Constants + - ERROR constant now 500, previously -1 (bug #18901) + Maypole::Model + - delete and search actions are now deprecated - use do_search and do_delete + instead + Maypole::View + - table name rather than moniker is used to find templates + +API additions and enhancements: + Maypole::Application: + - -Init flag (wishlist 14123) + - recognises Maypole::HTTPD and installs Maypole::HTTPD::Frontend + as its frontend + Maypole::Headers: + add() alias to push() (wishlist 14142) + Maypole: + - 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() + - improved exception handling + - now uses File::MMagic::XS to guess mime type of output unless already set + - new component method provides Maypole::Component functionality + - new object method gets/sets first/only object in objects + Maypole::Model + - do_delete, do_search in place of delete/search actions + Maypole::View::TT: + - new report_error method + - new embedded error report page in __DATA__ + Templates: + - Improved pager macro/include + - Improved factory templates + - added the status() attribute, although it's not used in many places + yet + - Changed factory edit/view to use object instead of objects + Maypole::Model::CDBI + - improved error messages in do_edit action + - new required_columns mutator method + - new column_required accessor method + +Bug fixes: + Fix to cgi_maypole.t (bug 11346) + Fix to TT error reporting (bug 13991) + Template xhtml validation (bug 13975) + Apache2 fixes in Apache::MVC (bug 13888) + Fixed inheritance issues in Mp::Application - Mp::App now manipulates the + caller's @ISA directly, and doesn't inject itself into the chain (bugs + 12923 & 14120) + Improved Template error reporting (14133) + Maypole::Session::generate_unique_id() now returns the id (bug 14124) + Moved ar accessor to Apache::MVC (bug 14014) + Refactored core to support further development in 2.11 and onwards + Fixed related_class() method (bug 14566) + Added a cgi() attribute in Maypole::CGI + Factory templates now less vulnerable to XSS (bug 16659) + Reduced risk of XSS in factory templates (bug 16659) + model search/delete methods in model and subclassing the cdbi mode (bug 16661) + fixed problems with stringify_self and untaint missing ignore columns (bug 15678) + fixed Maypole::Model::CDBI::Plain to JustWork(TM) with plain CDBI Classes (bug 16977) + some silent death scenarios resolved + Now initializes template_args, stash, parmas, objects and others to correct data type. (bug 15147) + +Documentation: + Fix to documentation for CGI::Maypole (bug 7263) + Simplified Net::Amazon example (bug 14073) + Numerous major and minor updates to docs. + Renamed Maypole::Manual::Request to Maypole::Manual::Cookbook + Added Maypole::Manual::Install, with material removed from + Maypole::Manual::About + Added Maypole::Manual::Inheritance + Added Maypole::Manual::Terminology + - updated Maypole::Manual::View + - updated Maypole::View:TT + Examples of fancy forms and templates using new features + +Requirements: + HTTP::Body now required + CGI::Untaint >= 1.26 now required rather than >= 0 + + 2.10 Tue 19 Jul 2005 Multiple Template Paths added ( http://rt.cpan.org/NoAuth/Bug.html?id=13447 ) Small fix to templates/factory/frontpage ( http://rt.cpan.org/NoAuth/Bug.html?id=11236 ) diff --git a/MANIFEST b/MANIFEST index 6647351..d5515b9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,7 +1,25 @@ Changes ex/BeerDB.pm +ex/BeerDB/Base.pm +ex/BeerDB/Beer.pm +ex/beerdb.sql +ex/fancy_example/BeerDB.pm +ex/fancy_example/beerdb.sql +ex/fancy_example/BeerDB/Base.pm +ex/fancy_example/BeerDB/Beer.pm +ex/fancy_example/BeerDB/Brewery.pm +ex/fancy_example/BeerDB/Drinker.pm +ex/fancy_example/templates/custom/addnew +ex/fancy_example/templates/custom/display_inputs +ex/fancy_example/templates/custom/display_search_inputs +ex/fancy_example/templates/custom/edit +ex/fancy_example/templates/custom/header +ex/fancy_example/templates/custom/maypole.css +ex/fancy_example/templates/custom/metadata +ex/fancy_example/templates/custom/search_form lib/Apache/MVC.pm lib/CGI/Maypole.pm +lib/CGI/Untaint/Maypole.pm lib/Maypole.pm lib/Maypole/Application.pm lib/Maypole/CLI.pm @@ -11,11 +29,13 @@ lib/Maypole/Headers.pm lib/Maypole/Session.pm lib/Maypole/Manual.pod lib/Maypole/Manual/About.pod +lib/Maypole/Manual/Install.pod lib/Maypole/Manual/Beer.pod lib/Maypole/Manual/BuySpy.pod lib/Maypole/Manual/Flox.pod lib/Maypole/Manual/Model.pod -lib/Maypole/Manual/Request.pod +lib/Maypole/Manual/Cookbook.pod +lib/Maypole/Manual/Inheritance.pod lib/Maypole/Manual/StandardTemplates.pod lib/Maypole/Manual/View.pod lib/Maypole/Manual/Workflow.pod @@ -23,15 +43,18 @@ lib/Maypole/Manual/Plugins.pod lib/Maypole/Model/Base.pm lib/Maypole/Model/CDBI.pm lib/Maypole/Model/CDBI/Plain.pm +lib/Maypole/Model/CDBI/AsForm.pm +lib/Maypole/Model/CDBI/FromCGI.pm lib/Maypole/View/Base.pm lib/Maypole/View/TT.pm Makefile.PL MANIFEST MANIFEST.SKIP -META.yml Module meta-data (added by MakeMaker) +META.yml README AUTHORS t/01basics.t +t/01.httpd-basic.t t/02pod.t t/03podcoverage.t t/apache_mvc.t @@ -39,23 +62,25 @@ t/cgi_maypole.t t/constants.t t/headers.t t/maypole.t +t/pathtools.t +t/db_colinfo.t t/templates/custom/classdata t/templates/custom/frontpage t/templates/custom/list t/templates/custom/view -templates/beer/addnew -templates/factory/addnew -templates/factory/edit -templates/factory/footer -templates/factory/frontpage -templates/factory/header -templates/factory/list -templates/factory/login -templates/factory/macros -templates/factory/maypole -templates/factory/navbar -templates/factory/pager -templates/factory/search_form -templates/factory/title -templates/factory/view -templates/maypole.css +lib/Maypole/templates/beer/addnew +lib/Maypole/templates/factory/addnew +lib/Maypole/templates/factory/edit +lib/Maypole/templates/factory/footer +lib/Maypole/templates/factory/frontpage +lib/Maypole/templates/factory/header +lib/Maypole/templates/factory/list +lib/Maypole/templates/factory/login +lib/Maypole/templates/factory/macros +lib/Maypole/templates/factory/maypole +lib/Maypole/templates/factory/navbar +lib/Maypole/templates/factory/pager +lib/Maypole/templates/factory/search_form +lib/Maypole/templates/factory/title +lib/Maypole/templates/factory/view +lib/Maypole/templates/factory/maypole.css diff --git a/META.yml b/META.yml index 02da7a5..6fd72b6 100644 --- a/META.yml +++ b/META.yml @@ -1,29 +1,34 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Maypole -version: 2.10 +version: 2.111 version_from: lib/Maypole.pm installdirs: site requires: CGI::Simple: 0 - CGI::Untaint: 0 + CGI::Untaint: 1.26 + CGI::Untaint::date: 0 + CGI::Untaint::email: 0 Class::DBI: 0.96 Class::DBI::AbstractSearch: 0 - Class::DBI::AsForm: 2.2 - Class::DBI::FromCGI: 0.94 Class::DBI::Loader: 0.02 Class::DBI::Loader::Relationship: 0 Class::DBI::Pager: 0 Class::DBI::Plugin::RetrieveAll: 0 - Class::DBI::SQLite: 0 + Class::DBI::Plugin::Type: 0 + Class::DBI::SQLite: 0.08 Digest::MD5: 0 + File::MMagic::XS: 0.08 + HTML::Element: 0 + HTTP::Body: 0.5 HTTP::Headers: 1.59 Template: 0 Template::Plugin::Class: 0 Test::MockModule: 0 UNIVERSAL::moniker: 0 UNIVERSAL::require: 0 + URI: 0 URI::QueryParam: 0 distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.17 +generated_by: ExtUtils::MakeMaker version 6.30 diff --git a/Makefile.PL b/Makefile.PL index dbb6545..935c677 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,28 +11,33 @@ WriteMakefile( Class::DBI::AbstractSearch => 0, Class::DBI::Pager => 0, Class::DBI::Plugin::RetrieveAll => 0, - Class::DBI::AsForm => 2.2, - Class::DBI::FromCGI => 0.94, Class::DBI::Loader::Relationship => 0, Class::DBI => 0.96, - Class::DBI::SQLite => 0, - CGI::Untaint => 0, + Class::DBI::SQLite => 0.08, + CGI::Untaint => 1.26, + CGI::Untaint::date => 0, + CGI::Untaint::email => 0, UNIVERSAL::moniker => 0, UNIVERSAL::require => 0, + URI => 0, URI::QueryParam => 0, CGI::Simple => 0, + HTTP::Body => 0.5, + HTML::Element => 0, HTTP::Headers => 1.59, Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, - Digest::MD5 => 0, + Digest::MD5 => 0, + File::MMagic::XS => 0.08, + Class::DBI::Plugin::Type => 0, }, # e.g., Module::Name => 1.1 ( $] >= 5.005 ? ## Add these new keywords supported since 5.005 ( ABSTRACT_FROM => 'lib/Maypole.pm', # retrieve abstract from module - AUTHOR => 'Simon flack ' + AUTHOR => 'Aaron TEEJAY Trevena ' ) : () ), @@ -81,7 +86,7 @@ create table beer ( style integer, name varchar(30), url varchar(120), -# tasted date, + tasted date, score integer(2), price varchar(12), abv varchar(10), diff --git a/README b/README index a8f509c..c4721a4 100644 --- a/README +++ b/README @@ -3,9 +3,9 @@ NAME DESCRIPTION Maypole is a Perl framework for MVC-oriented web applications, similar - to Jakarta's Struts. Maypole is designed to minimize coding requirements - for creating simple web interfaces to databases, while remaining flexible - enough to support enterprise web applications. + to Jakarta's Struts or Ruby on Rails. Maypole is designed to minimize + coding requirements for creating simple web interfaces to databases, + while remaining flexible enough to support enterprise web applications. QUICK START Maypole ships with a basic demo application, the Beer Database. @@ -29,7 +29,7 @@ LINKS http://maypole.perl.org - Maypole's home. tips & tricks, mailing list AUTHOR - Maypole is currently maintained by Simon Flack, C + Maypole is currently maintained by Aaron Trevena, C AUTHOR EMERITUS Simon Cozens, C diff --git a/ex/BeerDB.pm b/ex/BeerDB.pm index 778185a..e0b2894 100644 --- a/ex/BeerDB.pm +++ b/ex/BeerDB.pm @@ -2,12 +2,13 @@ package BeerDB; use Maypole::Application; use Class::DBI::Loader::Relationship; -sub debug { $ENV{BEERDB_DEBUG} } +sub debug { $ENV{BEERDB_DEBUG} || 0 } # This is the sample application. Change this to the path to your # database. (or use mysql or something) use constant DBI_DRIVER => 'SQLite'; use constant DATASOURCE => $ENV{BEERDB_DATASOURCE} || 't/beerdb.db'; + BEGIN { my $dbi_driver = DBI_DRIVER; if ($dbi_driver =~ /^SQLite/) { @@ -29,8 +30,10 @@ BeerDB->config->application_name('The Beer Database'); BeerDB->config->uri_base( $ENV{BEERDB_BASE} || "http://localhost/beerdb/" ); # Change this to the htdoc root for your maypole application. -BeerDB->config->template_root( $ENV{BEERDB_TEMPLATE_ROOT} ) if $ENV{BEERDB_TEMPLATE_ROOT}; +my @root= ('t/templates'); +push @root,$ENV{BEERDB_TEMPLATE_ROOT} if ($ENV{BEERDB_TEMPLATE_ROOT}); +BeerDB->config->template_root( [@root] ); # Specify the rows per page in search results, lists, etc : 10 is a nice round number BeerDB->config->rows_per_page(10); @@ -41,10 +44,16 @@ BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); BeerDB::Beer->untaint_columns( printable => [qw/abv name price notes url/], integer => [qw/style brewery score/], - date =>[ qw/date/], + date =>[ qw/tasted/], ); BeerDB::Pub->untaint_columns(printable => [qw/name notes url/]); +# Required Fields +BeerDB->config->{brewery}{required_cols} = [qw/name/]; +BeerDB->config->{style}{required_cols} = [qw/name/]; +BeerDB->config->{beer}{required_cols} = [qw/brewery name price/]; +BeerDB->config->{pub}{required_cols} = [qw/name/]; + BeerDB->config->{loader}->relationship($_) for ( "a brewery produces beers", "a style defines beers", diff --git a/ex/BeerDB/Base.pm b/ex/BeerDB/Base.pm new file mode 100644 index 0000000..75ed338 --- /dev/null +++ b/ex/BeerDB/Base.pm @@ -0,0 +1,7 @@ +package BeerDB::Base; +use strict; +use warnings; + +sub floob {} + +1; diff --git a/ex/BeerDB/Beer.pm b/ex/BeerDB/Beer.pm new file mode 100644 index 0000000..d7de346 --- /dev/null +++ b/ex/BeerDB/Beer.pm @@ -0,0 +1,10 @@ +package BeerDB::Beer; +use strict; +use warnings; + +# do this to test we get the expected @ISA after setup_model() +use base 'BeerDB::Base'; + +sub fooey : Exported {} + +1; diff --git a/ex/beerdb.sql b/ex/beerdb.sql new file mode 100644 index 0000000..0c6a0df --- /dev/null +++ b/ex/beerdb.sql @@ -0,0 +1,38 @@ +CREATE TABLE style ( + id integer primary key auto_increment, + name varchar(60), + notes text +); + +CREATE TABLE pub ( + id integer primary key auto_increment, + name varchar(60), + url varchar(120), + notes text +); + +CREATE TABLE handpump ( + id integer primary key auto_increment, + beer integer, + pub integer +); + +CREATE TABLE beer ( + id integer primary key auto_increment, + brewery integer, + style integer, + name varchar(30), + url varchar(120), + score integer(2), + price varchar(12), + abv varchar(10), + notes text, + tasted date +); + +CREATE TABLE brewery ( + id integer primary key auto_increment, + name varchar(30), + url varchar(50), + notes text +); diff --git a/ex/fancy_example/BeerDB.pm b/ex/fancy_example/BeerDB.pm new file mode 100644 index 0000000..cb72574 --- /dev/null +++ b/ex/fancy_example/BeerDB.pm @@ -0,0 +1,78 @@ +package BeerDB; +use Maypole::Application; +use Class::DBI::Loader::Relationship; + +sub debug { $ENV{BEERDB_DEBUG} || 0 } +# This is the sample application. Change this to the path to your +# database. (or use mysql or something) +use constant DBI_DRIVER => 'SQLite'; +use constant DATASOURCE => '/home/peter/Desktop/maypolebeer/beerdb'; + +BeerDB->config->model('BeerDB::Base'); + +BeerDB->setup("dbi:mysql:beerdb",'root', ''); + +# Give it a name. +BeerDB->config->application_name('The Beer Database'); + +# Change this to the root of the web site for your maypole application. +BeerDB->config->uri_base( $ENV{BEERDB_BASE} || "http://localhost/beerdb/" ); + +# Change this to the htdoc root for your maypole application. + +my @root= ('/home/peter/Desktop/maypolebeer/templates'); +push @root,$ENV{BEERDB_TEMPLATE_ROOT} if ($ENV{BEERDB_TEMPLATE_ROOT}); +BeerDB->config->template_root( [@root] ); +# Specify the rows per page in search results, lists, etc : 10 is a nice round number +BeerDB->config->rows_per_page(10); + +# Let TT templates recursively include themselves +BeerDB->config->{view_options} = { RECURSION => 1, }; + +# Handpumps should not show up. +BeerDB->config->display_tables([qw[beer brewery pub style drinker pint person]]); +# Access handpumps if want +BeerDB->config->ok_tables([ @{BeerDB->config->display_tables}, qw[handpump]]); + +BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] ); +BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); +BeerDB::Beer->untaint_columns( + printable => [qw/abv name price notes/], + integer => [qw/style brewery score/], + date =>[ qw/tasted/], +); +BeerDB::Pub->untaint_columns(printable => [qw/name notes url/]); +BeerDB::Drinker->untaint_columns( printable => [qw/handle created/] ); +BeerDB::Pint->untaint_columns( printable => [qw/date_and_time/]); + + +# Required Fields +BeerDB->config->{brewery}{required_cols} = [qw/name url/]; +BeerDB->config->{style}{required_cols} = [qw/name/]; +BeerDB->config->{beer}{required_cols} = [qw/brewery name price/]; +BeerDB->config->{pub}{required_cols} = [qw/name/]; +BeerDB->config->{drinker}{required_cols} = [qw/handle person/]; +BeerDB->config->{pint}{required_cols} = [qw/drinker handpump/]; +BeerDB->config->{person}{required_cols} = [qw/first_name sur_name dob email/]; + +# Columns to display +sub BeerDB::Handpump::display_columns { qw/pub beer/ } + +BeerDB->config->{loader}->relationship($_) for ( + "a brewery produces beers", + "a style defines beers", + "a pub has beers on handpumps", + "a handpump defines pints", + "a drinker drinks pints",); + +# For testing classmetadata +#sub BeerDB::Beer::classdata :Exported {}; +sub BeerDB::Beer::list_columns { return qw/score name price style brewery/}; + +sub BeerDB::Handpump::stringify_self { + my $self = shift; + return $self->beer . " @ " . $self->pub; +} + + +1; diff --git a/ex/fancy_example/BeerDB/Base.pm b/ex/fancy_example/BeerDB/Base.pm new file mode 100644 index 0000000..aaafce1 --- /dev/null +++ b/ex/fancy_example/BeerDB/Base.pm @@ -0,0 +1,51 @@ +package BeerDB::Base; +use base qw/Maypole::Model::CDBI/; +use strict; +use warnings; +use Data::Dumper; + +# Overide list to add display_columns to cgi +# Perhaps do this in AsForm? +sub list : Exported { + use Data::Dumper; + my ($self, $r) = @_; + $self->SUPER::list($r); + my %cols = map { $_ => 1 } $self->columns, $self->display_columns; + my @cols = keys %cols; + $r->template_args->{classmetadata}{cgi} = { $self->to_cgi(@cols) }; +} + +# Override view to make inputs and process form to add to related +sub view : Exported { + my ($self, $r, $obj) = @_; + $self->_croak( "Object method only") unless $obj; + + if ($r->params->{submit}) { + my @related = $obj->add_to_from_cgi($r, { required => [$self->related ]}); + if (my $errs = $obj->cgi_update_errors) { + $r->template_args->{errors} = $errs; + } + } + + # Inputs to add to related on the view page + # Now done on the view template + # my %cgi = $self->to_cgi($self->related); + #$r->template_args->{classmetadata}{cgi} = \%cgi ; +} + + +# Template switcheroo bug bit me -- was seeing view page but the view action was never +# being executed after an edit. +sub do_edit : Exported { + my ($self, $r) = (shift, shift); + $self->SUPER::do_edit($r, @_); + if (my $obj = $r->object) { + my $url = $r->config->uri_base . "/" . $r->table . "/view/" . $obj->id; + $r->redirect_request(url => $url); + } +} + +sub metadata: Exported {} + + +1; diff --git a/ex/fancy_example/BeerDB/Beer.pm b/ex/fancy_example/BeerDB/Beer.pm new file mode 100644 index 0000000..d7de346 --- /dev/null +++ b/ex/fancy_example/BeerDB/Beer.pm @@ -0,0 +1,10 @@ +package BeerDB::Beer; +use strict; +use warnings; + +# do this to test we get the expected @ISA after setup_model() +use base 'BeerDB::Base'; + +sub fooey : Exported {} + +1; diff --git a/ex/fancy_example/BeerDB/Brewery.pm b/ex/fancy_example/BeerDB/Brewery.pm new file mode 100644 index 0000000..ad99483 --- /dev/null +++ b/ex/fancy_example/BeerDB/Brewery.pm @@ -0,0 +1,10 @@ +package BeerDB::Brewery; +use strict; +use warnings; + +use Data::Dumper; + +sub display_columns { qw/name url beers/ } # note has_man beers +sub list_columns { qw/name url/ } + +1; diff --git a/ex/fancy_example/BeerDB/Drinker.pm b/ex/fancy_example/BeerDB/Drinker.pm new file mode 100644 index 0000000..db798fd --- /dev/null +++ b/ex/fancy_example/BeerDB/Drinker.pm @@ -0,0 +1,48 @@ +package BeerDB::Drinker; +use strict; +use warnings; + +use Data::Dumper; + +__PACKAGE__->columns('Stringify' => qw/handle/); + +# A drinker is a person but we do not want to select who that person is +# from a list because this is a 1:1 relationship rather than a M:1. +# The no_select option tells AsForm not to bother making a select box + +__PACKAGE__->has_a(person => 'BeerDB::Person', no_select => 1); + +# Drinker drinks many beers at pubs if they are lucky. I like to specify the +# name of the foreign key unless i can control the order that the +# cdbi classes are created. CDBI does not guess very well the fk column. + +#__PACKAGE__->has_many(pints => 'BeerDB::Pint', 'drinker'); + +# When we create a drinker we want to create a person as well +# So tell AsForm to display the person inputs too. + +sub display_columns { qw/person handle/ } +sub list_columns { qw/person handle/ } +# AsForm and templates may check for search_colums when making +#sub search_columns { qw/person handle/ } + +# We need to tweak the cgi inputs a little. +# Since list is where addnew is, override that. +# Person is a has_a rel and AsForm wont make foreign inputs automatically so +# we manually do it. + +sub list : Exported { + my ($self, $r) = @_; + $self->SUPER::list($r); + my %cgi = $self->to_cgi; + $cgi{person} = $self->to_field('person', 'foreign_inputs'); + $r->template_args->{classmetadata}{cgi} = \%cgi; + #$r->template_args->{classmetadata}{search_cgi} = $self->search_inputs; +} + + + + +#sub foreign_input_delimiter { '__IMODDD__'} + +1; diff --git a/ex/fancy_example/beerdb.sql b/ex/fancy_example/beerdb.sql new file mode 100644 index 0000000..6089c94 --- /dev/null +++ b/ex/fancy_example/beerdb.sql @@ -0,0 +1,67 @@ +CREATE TABLE style ( + id integer primary key auto_increment, + name varchar(60), + notes text +); + +CREATE TABLE pub ( + id integer primary key auto_increment, + name varchar(60), + url varchar(120), + notes text +); + +CREATE TABLE handpump ( + id integer primary key auto_increment, + beer integer, + pub integer +); + +CREATE TABLE beer ( + id integer primary key auto_increment, + brewery integer, + style integer, + name varchar(30), + score integer(2), + price varchar(12), + abv varchar(10), + notes text, + tasted date +); + +CREATE TABLE brewery ( + id integer primary key auto_increment, + name varchar(30), + url varchar(50), + notes text +); + +CREATE TABLE drinker ( + id INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, + person INTEGER UNSIGNED NOT NULL, + handle VARCHAR(20) NOT NULL, + created TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + PRIMARY KEY(id), + INDEX drinker_FKIndex1(person) +); + +CREATE TABLE person ( + id INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, + first_name VARCHAR(50) NULL, + sur_name VARCHAR(50) NULL, + dob DATE NULL, + username VARCHAR(20) NULL, + password VARCHAR(20) NULL, + email VARCHAR(255) NULL, + PRIMARY KEY(id) +); + +CREATE TABLE pint ( + id INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, + drinker INTEGER UNSIGNED NOT NULL, + handpump INTEGER UNSIGNED NOT NULL, + date_and_time TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + PRIMARY KEY(id) +); + + diff --git a/ex/fancy_example/templates/custom/addnew b/ex/fancy_example/templates/custom/addnew new file mode 100644 index 0000000..7053240 --- /dev/null +++ b/ex/fancy_example/templates/custom/addnew @@ -0,0 +1,24 @@ +[%# + +=head1 addnew + +This is the interface to adding a new instance of an object. (or a new +row in the database, if you want to look at it that way) It displays a +form containing a list of HTML components for each of the columns in the +table. + +=cut + +#%] +[% tbl = classmetadata.table; %] + +
+
+
+Add a new [% config.TABLES.$tbl.singular || tbl | ucfirst | replace('_',' '); %] + [% INCLUDE display_inputs; %] + + +
+
+
diff --git a/ex/fancy_example/templates/custom/display_inputs b/ex/fancy_example/templates/custom/display_inputs new file mode 100644 index 0000000..6baf703 --- /dev/null +++ b/ex/fancy_example/templates/custom/display_inputs @@ -0,0 +1,114 @@ +[%# + +=head1 display_inputs + +This *RECURSIVELY* displays inputs for a hash of html elements + +Vars it needs: + classmetadata-- the hash of bunch of data: + cgi -- inputs keyed on column names + table -- table inputs are for + columns -- list in order want displayed inputs + colnames -- hash of what to label inputs + +errors -- hash of errors keyed on columns + + +TODO -- make it recognize a general submit button for redisplaying +values on errors + +=cut + +# +%] + +[% # some variables + foreign = []; + names = []; + # get hash of related classes keyed on accessor for Foreign Inputs + USE this = Class(classmetadata.name); + tbl = classmetadata.table; + required = { }; + FOR c IN request.config.$tbl.required_cols; + required.$c = 1; + END; + +%] + +[% +SET heading_shown = 0; +FOR col = classmetadata.columns; + NEXT IF !classmetadata.cgi.$col; + NEXT IF col == "id" OR col == classmetadata.table _ "_id"; + # Display foreign inputs last + IF (mykeys = classmetadata.cgi.$col.keys); + foreign.push(col); + names.push(classmetadata.colnames.$col); + NEXT; + END; + IF ! heading_shown; + heading = classmetadata.moniker | ucfirst; + "

$heading

"; + SET heading_shown = 1; + END; +%] + +[% # Base case starts here + + SET elem = classmetadata.cgi.$col; #.clone; # not sure why clone + IF elem.type == 'hidden'; + elem.as_XML; + NEXT; + ELSIF cgi_params; + param_col = col_prefix _ col; + IF elem.tag == "textarea"; + elem = elem.push_content(cgi_params.$param_col); + ELSIF elem.tag == "select"; + oldval = set_selected(elem, cgi_params.$col); + ELSE; + oldval = elem.attr("value", cgi_params.$param_col); + END; + END; +%] + + + + [% IF errors.$col %] + [% errors.$col | html %] + [% END %] +[% END; %] + + + +[% USE this = Class(classmetadata.name); + FOR col IN foreign; + # has_many mapping throws a stick in our spokes because related_class returns the mapped + # class. Sometimes we just want the has_many class. + + # In case of Pub Handpumps maps to Beer and we want to add Handpump to Pub, we dont + # want the mapped data . + # In case of "Create New Handpump" -- we want the mapped data probably so we get + # Beer inputs and Pub select box. + + fclass_rel_meta = this.related_meta(request, col); + fclass = fclass_rel_meta.foreign_class; # ignor args.mapping + fclass_meta = this.get_classmetadata(fclass); + fclass_meta.cgi = classmetadata.cgi.$col; + # USE Dumper; Dumper.dump(fclass_meta); + INCLUDE display_inputs + col_prefix = col _ "__AF__" _ col_prefix + errors = errors.$col + heading = names.shift + classmetadata = fclass_meta; # localize + END; +%] + diff --git a/ex/fancy_example/templates/custom/display_search_inputs b/ex/fancy_example/templates/custom/display_search_inputs new file mode 100644 index 0000000..9985bfb --- /dev/null +++ b/ex/fancy_example/templates/custom/display_search_inputs @@ -0,0 +1,63 @@ +[%# + +=head1 display_search_inputs + +This displays inputs for search page. Override in individual class template +directories as needed. + +Vars it needs: +classmetadata-- the hash of inputs keyed on column names +errors -- hash of errors keyed on columns +=cut + +#%] + +[% IF errors.FATAL; "FATAL ERROR: "; errors.FATAL; "
"; END %] + +[% USE this = Class(classmetadata.name); + SET srch_fields = classmetadata.search_columns || + classmetadata.columns; + SET cgi = classmetadata.cgi; + SET delimiter = this.foreign_input_delimiter; + FOR field IN srch_fields; + NEXT IF !cgi.$field; + # Recursivly call this tmeplate if we have foreign field + # (hash of foreign inputs should come with it) + IF ( cgi.$field.keys ); + fclass = this.related_class(request, field); + fclass_meta = this.get_classmetadata(fclass); + fclass_meta.cgi = cgi.$field; + tbl = fclass_meta.table; + INCLUDE display_search_inputs + col_prefix = col _ delimiter _ col_prefix + classmetadata = fclass_meta; + NEXT; + END; + + NEXT IF field == 'id' OR field == classmetadata.table _ 'id'; + SET element = cgi.$field; +%] + + +[% END; %] + + diff --git a/ex/fancy_example/templates/custom/edit b/ex/fancy_example/templates/custom/edit new file mode 100644 index 0000000..dae8c42 --- /dev/null +++ b/ex/fancy_example/templates/custom/edit @@ -0,0 +1,72 @@ +[%# + +=head1 edit + +This is the edit page. It edits the passed-in object, by displaying a +form similar to L but with the current values filled in. + +=cut + +#%] +[% PROCESS macros %] +[% INCLUDE header %] +[% INCLUDE title %] + +[% IF request.action == 'edit' %] +[% INCLUDE navbar %] +[% END %] + +[% IF objects.size %] +
Edit a [% classmetadata.moniker %]
+[% FOR item = objects; %] +
+
+Edit [% item.name %] +[% FOR col = classmetadata.columns; + NEXT IF col == "id" OR col == classmetadata.table _ "_id"; + '"; + IF errors.$col; + ''; errors.$col;''; + END; + END %] + + +
+ + [% END %] +[% ELSE %] + +
+
+
+Add a new [% classmetadata.moniker %] + [% FOR col = classmetadata.columns %] + [% NEXT IF col == "id" %] + + [% IF errors.$col %] + [% errors.$col | html %] + [% END %] + + [% END; %] + + +
+
+
+ +[% END %] +[% INCLUDE footer %] diff --git a/ex/fancy_example/templates/custom/header b/ex/fancy_example/templates/custom/header new file mode 100644 index 0000000..c21fff7 --- /dev/null +++ b/ex/fancy_example/templates/custom/header @@ -0,0 +1,16 @@ + + + + + [% + title || config.application_name || + "A poorly configured Maypole application" + %] + + + + + + +
diff --git a/ex/fancy_example/templates/custom/maypole.css b/ex/fancy_example/templates/custom/maypole.css new file mode 100644 index 0000000..b13b4f1 --- /dev/null +++ b/ex/fancy_example/templates/custom/maypole.css @@ -0,0 +1,382 @@ +html { + padding-right: 0px; + padding-left: 0px; + padding-bottom: 0px; + margin: 0px; + padding-top: 0px +} +body { + font-family: sans-serif; + padding-right: 0px; + padding-left: 0px; + padding-bottom: 0px; + margin: 0px; padding-top: 0px; + background-color: #fff; +} +#frontpage_list { + position: absolute; + z-index: 5; + padding: 0px 100px 0px 0px; + margin:0 0.5%; + margin-bottom:1em; + margin-top: 1em; + background-color: #fff; +} + +#frontpage_list a:hover { + background-color: #d0d8e4; +} + +#frontpage_list ul { + list-style-type: square; +} + +.content { + padding: 12px; + margin-top: 1px; + margin-bottom:0px; + margin-left: 15px; + margin-right: 15px; + border-color: #000000; + border-top: 0px; + border-bottom: 0px; + border-left: 1px; + border-right: 1px; +} + +A { + text-decoration: none; + color:#225 +} +A:hover { + text-decoration: underline; + color:#222 +} + +#title { + z-index: 6; + width: 100%; + height: 18px; + margin-top: 10px; + font-size: 90%; + border-bottom: 1px solid #ddf; + text-align: left; +} + +#subtitle { + postion: absolute; + z-index: 6; + padding: 10px; + margin-top: 2em; + height: 18px; + text-align: left; + background-color: #fff; +} + +input[type=text] { + height: 16px; + width: 136px; + font-family: sans-serif; + font-size: 11px; + color: #2E415A; + padding: 0px; + margin-bottom: 5px; +} + +input[type=submit] { + height: 18px; + width: 60px; + font-family: sans-serif; + font-size: 11px; + border: 1px outset; + background-color: #fff; + padding: 0px 0px 2px 0px; + margin-bottom: 5px; +} + +input:hover[type=submit] { + color: #fff; + background-color: #7d95b5; +} + +textarea { + width: 136px; + font-family: sans-serif; + font-size: 11px; + color: #2E415A; + padding: 0px; + margin-bottom: 5px; +} + +select { + height: 16px; + width: 140px; + font-family: sans-serif; + font-size: 12px; + color: #202020; + padding: 0px; + margin-bottom: 5px; +} + +.deco1 { + font-size: 0px; + z-index:1; + border:0px; + border-style:solid; + border-color:#4d6d99; + background-color:#4d6d99; +} + +.deco2 { + z-index:2; + border:0px; + border-style:solid; + border-color:#627ea5; + background-color:#627ea5; +} + + +.deco3 { + z-index:3; + border:0px; + border-style:solid; + border-color:#7d95b5; + background-color:#7d95b5; +} + +.deco4 { + z-index:4; + border:0px; + border-style:solid; + border-color:#d0d8e4; + background-color:#d0d8e4; +} + + +table { + border: 0px solid; + background-color: #ffffff; +} + +#matrix { width: 100%; } + +#matrix th { + background-color: #b5cadc; + border: 1px solid #778; + font: bold 12px Verdana, sans-serif; +} + +#matrix #actionth { + width: 1px; + padding: 0em 1em 0em 1em; +} + +#matrix tr.alternate { background-color:#e3eaf0; } +#matrix tr:hover { background-color: #b5cadc; } +#matrix td { font: 12px Verdana, sans-serif; } + +#navlist { + padding: 3px 0; + margin-left: 0; + margin-top:3em; + border-bottom: 1px solid #778; + font: bold 12px Verdana, sans-serif; +} + +#navlist li { + list-style: none; + margin: 0; + display: inline; +} + +#navlist li a { + padding: 3px 0.5em; + margin-left: 3px; + border: 1px solid #778; + border-bottom: none; + background: #b5cadc; + text-decoration: none; +} + +#navlist li a:link { color: #448; } +#navlist li a:visited { color: #667; } + +#navlist li a:hover { + color: #000; + background: #eef; + border-top: 4px solid #7d95b5; + border-color: #227; +} + +#navlist #active a { + background: white; + border-bottom: 1px solid white; + border-top: 4px solid; +} + +td { font: 12px Verdana, sans-serif; } + + +fieldset { + margin-top: 1em; + padding: 1em; + background-color: #f3f6f8; + font:80%/1 sans-serif; + border:1px solid #ddd; +} + +legend { + padding: 0.2em 0.5em; + background-color: #fff; + border:1px solid #aaa; + font-size:90%; + text-align:right; +} + +label { + display:block; +} + +label.error { + display:block; + border-color: red; + border-width: 1px; +} + +label .field { + float:left; + width:25%; + margin-right:0.5em; + padding-top:0.2em; + text-align:right; + font-weight:bold; +} + +#vlist { + padding: 0 1px 1px; + margin-left: 0; + font: bold 12px Verdana, sans-serif; + background: gray; + width: 13em; +} + +#vlist li { + list-style: none; + margin: 0; + border-top: 1px solid gray; + text-align: left; +} + +#vlist li a { + display: block; + padding: 0.25em 0.5em 0.25em 0.75em; + border-left: 1em solid #7d95b5; + background: #d0d8e4; + text-decoration: none; +} + +#vlist li a:hover { + border-color: #227; +} + +.view .field { + background-color: #f3f6f8; + border-left: 1px solid #7695b5; + border-top: 1px solid #7695b5; + padding: 1px 10px 0px 2px; +} + +#addnew { + width: 50%; + float: left; +} + +#search { + width: 50%; + float:right; +} + +.error { color: #d00; } + +.action { + border: 1px outset #7d95b5; + style:block; +} + +.action:hover { + color: #fff; + text-decoration: none; + background-color: #7d95b5; +} + +.actionform { + display: inline; +} + +.actionbutton { + height: 16px; + width: 40px; + font-family: sans-serif; + font-size: 10px; + border: 1px outset; + background-color: #fff; + margin-bottom: 0px; +} + +.actionbutton:hover { + color: #fff; + background-color: #7d95b5; +} + +.actions { + white-space: nowrap; +} + +.field { + display:inline; +} + +#login { width: 400px; } + +#login input[type=text] { width: 150px; } +#login input[type=password] { width: 150px; } + +.pager { + font: 11px Arial, Helvetica, sans-serif; + text-align: center; + border: solid 1px #e2e2e2; + border-left: 0; + border-right: 0; + padding-top: 10px; + padding-bottom: 10px; + margin: 0px; + background-color: #f3f6f8; +} + +.pager a { + padding: 2px 6px; + border: solid 1px #ddd; + background: #fff; + text-decoration: none; +} + +.pager a:visited { + padding: 2px 6px; + border: solid 1px #ddd; + background: #fff; + text-decoration: none; +} + +.pager .current-page { + padding: 2px 6px; + font-weight: bold; + vertical-align: top; +} + +.pager a:hover { + color: #fff; + background: #7d95b5; + border-color: #036; + text-decoration: none; +} + diff --git a/ex/fancy_example/templates/custom/metadata b/ex/fancy_example/templates/custom/metadata new file mode 100644 index 0000000..e15fb6a --- /dev/null +++ b/ex/fancy_example/templates/custom/metadata @@ -0,0 +1,5 @@ +

Class::DBI meta info for [% classmetadata.name %]

+[% + USE this = Class(classmetadata.name); + USE Dumper; Dumper.dump(this.meta_info); +%] diff --git a/ex/fancy_example/templates/custom/search_form b/ex/fancy_example/templates/custom/search_form new file mode 100644 index 0000000..5d540fb --- /dev/null +++ b/ex/fancy_example/templates/custom/search_form @@ -0,0 +1,9 @@ + diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index c7bfdef..4d32dc4 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,95 +1,46 @@ package Apache::MVC; -our $VERSION = '2.09'; +our $VERSION = '2.11'; use strict; use warnings; +use URI; +use URI::QueryParam; + use base 'Maypole'; -use mod_perl; use Maypole::Headers; - -use constant APACHE2 => $mod_perl::VERSION >= 1.99; - -if (APACHE2) { - require Apache2; - require Apache::RequestIO; - require Apache::RequestRec; - require Apache::RequestUtil; - require APR::URI; -} -else { require Apache } -require Apache::Request; - -sub get_request { - my ( $self, $r ) = @_; - $self->{ar} = Apache::Request->new($r); -} - -sub parse_location { - my $self = shift; - - # Reconstruct the request headers - $self->headers_in(Maypole::Headers->new); - my %headers; - if (APACHE2) { %headers = %{$self->{ar}->headers_in}; - } else { %headers = $self->{ar}->headers_in; } - for (keys %headers) { - $self->headers_in->set($_, $headers{$_}); - } - - $self->{path} = $self->{ar}->uri; - my $loc = $self->{ar}->location; - no warnings 'uninitialized'; - $self->{path} .= '/' if $self->{path} eq $loc; - $self->{path} =~ s/^($loc)?\///; - $self->parse_path; - $self->parse_args; -} - -sub parse_args { - my $self = shift; - $self->{params} = { $self->_mod_perl_args( $self->{ar} ) }; - $self->{query} = { $self->_mod_perl_args( $self->{ar} ) }; -} - -sub send_output { - my $r = shift; - $r->{ar}->content_type( - $r->{content_type} =~ m/^text/ - ? $r->{content_type} . "; charset=" . $r->{document_encoding} - : $r->{content_type} - ); - $r->{ar}->headers_out->set( - "Content-Length" => do { use bytes; length $r->{output} } - ); - - foreach ($r->headers_out->field_names) { - next if /^Content-(Type|Length)/; - $r->{ar}->headers_out->set($_ => $r->headers_out->get($_)); +use Maypole::Constants; + +__PACKAGE__->mk_accessors( qw( ar ) ); + +our $MODPERL2; +our $modperl_version; + +BEGIN { + $MODPERL2 = ( exists $ENV{MOD_PERL_API_VERSION} and + $ENV{MOD_PERL_API_VERSION} >= 2 ); + if ($MODPERL2) { + eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION;'; + if ($@) { + $modperl_version = $Apache2::RequestRec::VERSION; + } + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import + require APR::URI; + require HTTP::Body; + } else { + eval ' use mod_perl; '; + require Apache; + require Apache::Request; + eval 'use Apache::Constants -compile => qw/REDIRECT/;'; + $modperl_version = 1; } - APACHE2 || $r->{ar}->send_http_header; - $r->{ar}->print( $r->{output} ); } -sub get_template_root { - my $r = shift; - $r->{ar}->document_root . "/" . $r->{ar}->location; -} - -sub _mod_perl_args { - my ( $self, $apr ) = @_; - my %args; - foreach my $key ( $apr->param ) { - my @values = $apr->param($key); - $args{$key} = @values == 1 ? $values[0] : \@values; - } - return %args; -} - -1; - =head1 NAME Apache::MVC - Apache front-end to Maypole @@ -97,15 +48,7 @@ Apache::MVC - Apache front-end to Maypole =head1 SYNOPSIS package BeerDB; - use base 'Apache::MVC'; - BeerDB->setup("dbi:mysql:beerdb"); - BeerDB->config->uri_base("http://your.site/"); - BeerDB->config->display_tables([qw[beer brewery pub style]]); - # Now set up your database: - # has-a relationships - # untaint columns - - 1; + use Maypole::Application; =head1 DESCRIPTION @@ -115,7 +58,7 @@ L. =head1 INSTALLATION -Create a driver module like the one above. +Create a driver module like the one illustrated in L. Put the following in your Apache config: @@ -124,15 +67,13 @@ Put the following in your Apache config: PerlHandler BeerDB -Copy the templates found in F into the -F directory off the web root. When the designers get -back to you with custom templates, they are to go in -F. If you need to do override templates on a -database-table-by-table basis, put the new template in -F>. +Copy the templates found in F into the F +directory off the web root. When the designers get back to you with custom +templates, they are to go in F. If you need to override templates +on a database-table-by-table basis, put the new template in F>. -This will automatically give you C, C, C, C and -C commands; for instance, a list of breweries, go to +This will automatically give you C, C, C, C and C +commands; for instance, to see a list of breweries, go to http://your.site/beer/brewery/list @@ -141,31 +82,210 @@ see L. =head1 Implementation -This class overrides a set of methods in the base Maypole class to provide it's +This class overrides a set of methods in the base Maypole class to provide its functionality. See L for these: =over =item get_request -=item get_template_root +=cut -=item parse_args +sub get_request { + my ($self, $r) = @_; + my $ar; + if ($MODPERL2) { + $ar = eval {require Apache2::Request} ? Apache2::Request->new($r) : $r; + } + else { $ar = Apache::Request->instance($r); } + $self->ar($ar); +} =item parse_location +=cut + +sub parse_location { + my $self = shift; + + # Reconstruct the request headers + $self->headers_in(Maypole::Headers->new); + my %headers; + if ($MODPERL2) { %headers = %{$self->ar->headers_in}; + } else { %headers = $self->ar->headers_in; } + for (keys %headers) { + $self->headers_in->set($_, $headers{$_}); + } + my $path = $self->ar->uri; + my $loc = $self->ar->location; + { + no warnings 'uninitialized'; + $path .= '/' if $path eq $loc; + $path =~ s/^($loc)?\///; + } + $self->path($path); + $self->parse_path; + $self->parse_args; +} + +=item parse_args + +=cut + +sub parse_args { + my $self = shift; + $self->params( { $self->_mod_perl_args( $self->ar ) } ); + $self->query( $self->params ); +} + +=item redirect_request + +=cut + +sub redirect_request { + my $r = shift; + my $redirect_url = $_[0]; + my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : + eval 'Apache::Constants::REDIRECT;'; # why have to eval this? + if ($_[1]) { + my %args = @_; + if ($args{url}) { + $redirect_url = $args{url}; + } else { + my $path = $args{path} || $r->path; + my $host = $args{domain} || $r->ar->hostname; + my $protocol = $args{protocol} || $r->get_protocol; + + $redirect_url = URI->new; + $redirect_url->scheme($protocol); + $redirect_url->host($host); + $redirect_url->path($path); + } + $status = $args{status} if ($args{status}); + } + + $r->ar->status($status); + $r->ar->headers_out->set('Location' => $redirect_url); + return OK; +} + +=item get_protocol + +=cut + +sub get_protocol { + my $self = shift; + my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ; + return $protocol; +} + =item send_output +=cut + +sub send_output { + my $r = shift; + $r->ar->content_type( + $r->content_type =~ m/^text/ + ? $r->content_type . "; charset=" . $r->document_encoding + : $r->content_type + ); + $r->ar->headers_out->set( + "Content-Length" => do { use bytes; length $r->output } + ); + + foreach ($r->headers_out->field_names) { + next if /^Content-(Type|Length)/; + $r->ar->headers_out->set($_ => $r->headers_out->get($_)); + } + + $MODPERL2 || $r->ar->send_http_header; + $r->ar->print( $r->output ); +} + +=item get_template_root + +=cut + +sub get_template_root { + my $r = shift; + $r->ar->document_root . "/" . $r->ar->location; +} + =back +=cut + +######################################################### +# private / internal methods and subs + + +sub _mod_perl_args { + my ( $self, $apr ) = @_; + my %args; + if ($apr->isa('Apache::Request')) { + foreach my $key ( $apr->param ) { + my @values = $apr->param($key); + $args{$key} = @values == 1 ? $values[0] : \@values; + } + } else { + my $body = $self->_prepare_body($apr); + %args = %{$body->param}; + my $uri = URI->new($self->ar->unparsed_uri); + foreach my $key ($uri->query_param) { + if (ref $args{$key}) { + push (@{$args{$key}}, $uri->query_param($key)); + } else { + if ($args{$key}) { + $args{$key} = [ $args{$key}, $uri->query_param($key) ]; + } else { + my @args = $uri->query_param($key); + if (scalar @args > 1) { + $args{$key} = [ $uri->query_param($key) ]; + } else { + $args{$key} = $uri->query_param($key); + } + } + } + } + } + return %args; +} + +sub _prepare_body { + my ( $self, $r ) = @_; + + unless ($self->{__http_body}) { + my $content_type = $r->headers_in->get('Content-Type'); + my $content_length = $r->headers_in->get('Content-Length'); + my $body = HTTP::Body->new( $content_type, $content_length ); + my $length = $content_length; + while ( $length ) { + $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 ); + $length -= length($buffer); + $body->add($buffer); + } + $self->{__http_body} = $body; + } + return $self->{__http_body}; +} + + + =head1 AUTHOR Simon Cozens, C + +=head1 CREDITS + +Aaron Trevena Marcus Ramberg, C -Screwed up by Sebastian Riedel, C +Sebastian Riedel, C =head1 LICENSE You may distribute this code under the same terms as Perl itself. =cut + +1; diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm index f8c1229..b8a0a48 100644 --- a/lib/CGI/Maypole.pm +++ b/lib/CGI/Maypole.pm @@ -5,73 +5,11 @@ use strict; use warnings; use CGI::Simple; use Maypole::Headers; +use Maypole::Constants; -our $VERSION = '2.09'; +our $VERSION = '2.11'; -sub run { - my $self = shift; - return $self->handler(); -} - -sub get_request { - shift->{cgi} = CGI::Simple->new(); -} - - -sub parse_location { - my $self = shift; - my $cgi = $self->{cgi}; - - # Reconstruct the request headers (as far as this is possible) - $self->headers_in(Maypole::Headers->new); - for my $http_header ($cgi->http) { - (my $field_name = $http_header) =~ s/^HTTPS?_//; - $self->headers_in->set($field_name => $cgi->http($http_header)); - } - - $self->{path} = $cgi->url( -absolute => 1, -path_info => 1 ); - my $loc = $cgi->url( -absolute => 1 ); - no warnings 'uninitialized'; - $self->{path} .= '/' if $self->{path} eq $loc; - $self->{path} =~ s/^($loc)?\///; - $self->parse_path; - $self->parse_args; -} - -sub parse_args { - my $self = shift; - my (%vars) = $self->{cgi}->Vars; - while ( my ( $key, $value ) = each %vars ) { - my @values = split "\0", $value; - $vars{$key} = @values <= 1 ? $values[0] : \@values; - } - $self->{params} = {%vars}; - $self->{query} = {%vars}; -} - -sub send_output { - my $r = shift; - - # Collect HTTP headers - my %headers = ( - -type => $r->{content_type}, - -charset => $r->{document_encoding}, - -content_length => do { use bytes; length $r->{output} }, - ); - foreach ($r->headers_out->field_names) { - next if /^Content-(Type|Length)/; - $headers{"-$_"} = $r->headers_out->get($_); - } - - print $r->{cgi}->header(%headers), $r->{output}; -} - -sub get_template_root { - my $r = shift; - $r->{cgi}->document_root . "/" . $r->{cgi}->url( -relative => 1 ); -} - -1; +__PACKAGE__->mk_accessors( qw/cgi/ ); =head1 NAME @@ -80,16 +18,7 @@ CGI::Maypole - CGI-based front-end to Maypole =head1 SYNOPSIS package BeerDB; - use base 'CGI::Maypole'; - BeerDB->setup("dbi:mysql:beerdb"); - BeerDB->config->uri_base("http://your.site/cgi-bin/beer.cgi/"); - BeerDB->config->display_tables([qw[beer brewery pub style]]); - BeerDB->config->template_root("/var/www/beerdb/"); - # Now set up your database: - # has-a relationships - # untaint columns - - 1; + use Maypole::Application; ## example beer.cgi: @@ -101,12 +30,17 @@ CGI::Maypole - CGI-based front-end to Maypole Now to access the beer database, type this URL into your browser: http://your.site/cgi-bin/beer.cgi/frontpage +NOTE: this Maypole frontend requires additional modules that won't be installed +or included with Maypole. Please see below. + =head1 DESCRIPTION This is a CGI platform driver for Maypole. Your application can inherit from CGI::Maypole directly, but it is recommended that you use L. +This module requires CGI::Simple which you will have to install yourself via +CPAN or manually. =head1 METHODS @@ -118,6 +52,14 @@ Call this from your CGI script to start the Maypole application. =back +=cut + +sub run +{ + my $self = shift; + return $self->handler; +} + =head1 Implementation This class overrides a set of methods in the base Maypole class to provide it's @@ -127,16 +69,155 @@ functionality. See L for these: =item get_request -=item get_template_root +=cut -=item parse_args +sub get_request +{ + shift->cgi( CGI::Simple->new ); +} =item parse_location +=cut + +sub parse_location +{ + my $r = shift; + my $cgi = $r->cgi; + + # Reconstruct the request headers (as far as this is possible) + $r->headers_in(Maypole::Headers->new); + for my $http_header ($cgi->http) { + (my $field_name = $http_header) =~ s/^HTTPS?_//; + $r->headers_in->set($field_name => $cgi->http($http_header)); + } + + my $path = $cgi->url( -absolute => 1, -path_info => 1 ); + my $loc = $cgi->url( -absolute => 1 ); + { + no warnings 'uninitialized'; + $path .= '/' if $path eq $loc; + $path =~ s/^($loc)?\///; + } + $r->path($path); + + $r->parse_path; + $r->parse_args; +} + +=item parse_args + +=cut + +sub parse_args +{ + my $r = shift; + my (%vars) = $r->cgi->Vars; + while ( my ( $key, $value ) = each %vars ) { + my @values = split "\0", $value; + $vars{$key} = @values <= 1 ? $values[0] : \@values; + } + $r->params( {%vars} ); + $r->query( $r->params ); +} + +=item redirect_request + +=cut + +# FIXME: use headers_in to gather host and other information? +sub redirect_request +{ + my $r = shift; + my $redirect_url = $_[0]; + my $status = "302"; + if ($_[1]) { + my %args = @_; + if ($args{url}) { + $redirect_url = $args{url}; + } else { + my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1); + my $host = $args{domain}; + ($host = $r->cgi->url(-base => 1)) =~ s/^https?:\/\///i unless ($host); + my $protocol = $args{protocol} || $r->get_protocol; + $redirect_url = "${protocol}://${host}/${path}"; + } + $status = $args{status} if ($args{status}); + } + + $r->headers_out->set('Status' => $status); + $r->headers_out->set('Location' => $redirect_url); + + return; +} + +=item get_protocol + +=cut + +sub get_protocol +{ + my $self = shift; + my $protocol = ($self->cgi->https) ? 'https' : 'http'; + return $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, + -charset => $r->document_encoding, + -content_length => do { use bytes; length $r->output }, + ); + foreach ($r->headers_out->field_names) { + next if /^Content-(Type|Length)/; + $headers{"-$_"} = $r->headers_out->get($_); + } + + return $r->cgi->header(%headers) . $r->output; +} + +=item get_template_root + +=cut + +sub get_template_root { + my $r = shift; + $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 ); +} + +1; + + =back +=head1 DEPENDANCIES + +CGI::Simple + =head1 AUTHORS Dave Ranney C diff --git a/lib/CGI/Untaint/Maypole.pm b/lib/CGI/Untaint/Maypole.pm new file mode 100644 index 0000000..38321ef --- /dev/null +++ b/lib/CGI/Untaint/Maypole.pm @@ -0,0 +1,129 @@ +package CGI::Untaint::Maypole; + +use strict; +use warnings; +our $VERSION = '0.01'; +use base 'CGI::Untaint'; +use Carp; + +=head1 NAME + +CGI::Untaint::Maypole - Use instead of CGI::Untaint. Based on CGI::Untaint + +=head1 SYNOPSIS + + use CGI::Untaint::Maypole; + my $h = CGI::Untaint::Maypole->new($params); + $value = $h->extract(-as_printable => 'name); + + if ($h->error =~ /No input for/) { + # caught empty input now handle it + .... + } + if ($h->raw_data->{$field} eq $object->$field) { + # Raw data same as database data. Perhaps we should not update field + ... + } + +=head1 DESCRIPTION + +This patches some issues I have with CGI::Untaint. You still need it installed +and you install handlers the same. + +1) Instead of passing the empty string to the untaint handlers and relying on +them to handle it to everyone's liking, it seems better +to have CGI::Untaint just say "No input for field" if the field is blank. + +2) It adds the method C to the get back the parameters the handler +was created with. + +=cut + +=head2 raw_data + +Returns the parameters the handler was created with as a hashref + +=cut + +sub raw_data { + return shift->{__data}; +} + +# offending method ripped from base and patched +sub _do_extract { + my $self = shift; + + my %param = @_; + + #---------------------------------------------------------------------- + # Make sure we have a valid data handler + #---------------------------------------------------------------------- + my @as = grep /^-as_/, keys %param; + croak "No data handler type specified" unless @as; + croak "Multiple data handler types specified" unless @as == 1; + + my $field = delete $param{ $as[0] }; + my $skip_valid = $as[0] =~ s/^(-as_)like_/$1/; + my $module = $self->_load_module($as[0]); + + #---------------------------------------------------------------------- + # Do we have a sensible value? Check the default untaint for this + # type of variable, unless one is passed. + #---------------------------------------------------------------------- + + ################# PETER'S PATCH ##################### + my $raw = $self->{__data}->{$field} ; + die "No parameter for '$field'\n" if !defined($raw); + die "No input for '$field'\n" if $raw eq ''; + ##################################################### + + + my $handler = $module->_new($self, $raw); + + my $clean = eval { $handler->_untaint }; + if ($@) { # Give sensible death message + die "$field ($raw) is in invalid format.\n" + if $@ =~ /^Died at/; + die $@; + } + + #---------------------------------------------------------------------- + # Are we doing a validation check? + #---------------------------------------------------------------------- + unless ($skip_valid) { + if (my $ref = $handler->can('is_valid')) { + die "$field ($raw) is in invalid format.\n" + unless $handler->is_valid; + } + } + + return $handler->untainted; +} + +=head1 BUGS + +None known yet. + +=head1 SEE ALSO + +L. L. + +=head1 AUTHOR + +Peter Speltz. + +=head1 BUGS and QUERIES + +Please direct all correspondence regarding this module to: + bug-Maypole@rt.cpan.org + +=head1 COPYRIGHT and LICENSE + +Copyright (C) 2006 Peter Speltz. All rights reserved. + +This module is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 7854caf..211bd05 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -3,48 +3,363 @@ use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; use strict; use warnings; +use Data::Dumper; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; +use URI(); +use URI::QueryParam; +use NEXT; +use File::MMagic::XS qw(:compat); -our $VERSION = '2.10'; +our $VERSION = '2.111'; +our $mmagic = File::MMagic::XS->new(); + +# 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 + +=head1 NAME + +Maypole - MVC web application framework + +=head1 SYNOPSIS + +The canonical example used in the Maypole documentation is the beer database: + + package BeerDB; + use strict; + use warnings; + + # choose a frontend, initialise the config object, and load a plugin + use Maypole::Application qw/Relationship/; + + # set everything up + __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); + + # get the empty config object created by Maypole::Application + my $config = __PACKAGE__->config; + + # basic settings + $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/]); + + # table relationships + $config->relationships([ + "a brewery produces beers", + "a style defines beers", + "a pub has beers on handpumps", + ]); + + # validation + BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] ); + BeerDB::Pub->untaint_columns( printable => [qw/name notes url/] ); + BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); + BeerDB::Beer->untaint_columns( + printable => [qw/abv name price notes/], + integer => [qw/style brewery score/], + date => [ qw/date/], + ); + + # note : set up model before calling this method + BeerDB::Beer->required_columns([qw/name/]); + + 1; + +=head1 DESCRIPTION + +This documents the Maypole request object. See the L, 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 driver package which represents your entire +application. This is the C package used as an example in the manual. + +This needs to first use L which will make your package +inherit from the appropriate platform driver such as C or +C. Then, the driver calls C. This sets up the model classes +and configures your application. The default model class for Maypole uses +L to map a database to classes, but this can be changed by altering +configuration (B calling setup.) + + +=head1 DOCUMENTATION AND SUPPORT + +Note that some details in some of these resources may be out of date. + +=over 4 + +=item The Maypole Manual + +The primary documentation is the Maypole manual. This lives in the +C pod documents included with the distribution. + +=item Embedded POD + +Individual packages within the distribution contain (more or less) detailed +reference documentation for their API. + +=item Mailing lists + +There are two mailing lists - maypole-devel and maypole-users - see +http://maypole.perl.org/?MailingList + +=item The Maypole Wiki + +The Maypole wiki provides a useful store of extra documentation - +http://maypole.perl.org + +In particular, there's a FAQ (http://maypole.perl.org/?FAQ) and a cookbook +(http://maypole.perl.org/?Cookbook). Again, certain information on these pages +may be out of date. + +=item Web applications with Maypole + +A tutorial written by Simon Cozens for YAPC::EU 2005 - +http://www.aarontrevena.co.uk/opensource/maypole/maypole-tutorial.pdf [228KB]. + +=item A Database-Driven Web Application in 18 Lines of Code + +By Paul Barry, published in Linux Journal, March 2005. + +http://www.linuxjournal.com/article/7937 + +"From zero to Web-based database application in eight easy steps". + +Maypole won a 2005 Linux Journal Editor's Choice Award +(http://www.linuxjournal.com/article/8293) after featuring in this article. + +=item Build Web apps with Maypole + +By Simon Cozens, on IBM's DeveloperWorks website, May 2004. + +http://www-128.ibm.com/developerworks/linux/library/l-maypole/ + +=item Rapid Web Application Deployment with Maypole + +By Simon Cozens, on O'Reilly's Perl website, April 2004. + +http://www.perl.com/pub/a/2004/04/15/maypole.html + +=item Authentication + +Some notes written by Simon Cozens. A little bit out of date, but still +very useful: http://www.aarontrevena.co.uk/opensource/maypole/authentication.html + +=item CheatSheet + +There's a refcard for the Maypole (and Class::DBI) APIs on the wiki - +http://maypole.perl.org/?CheatSheet. Probably a little out of date now - it's a +wiki, so feel free to fix any errors! + +=item Plugins and add-ons + +There are a large and growing number of plugins and other add-on modules +available on CPAN - http://search.cpan.org/search?query=maypole&mode=module + +=item del.icio.us + +You can find a range of useful Maypole links, particularly to several thoughtful +blog entries, starting here: http://del.icio.us/search/?all=maypole + +=item CPAN ratings + +There are a couple of short reviews here: +http://cpanratings.perl.org/dist/Maypole + +=back + +=cut + +__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); -__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 ) + headers_in headers_out stash status parent) ); + __PACKAGE__->config( Maypole::Config->new() ); + __PACKAGE__->init_done(0); +__PACKAGE__->model_classes_loaded(0); + +=head1 HOOKABLE METHODS + +As a framework, Maypole provides a number of B - methods that are +intended to be overridden. Some of these methods come with useful default +behaviour, others do nothing by default. Hooks include: + + Class methods + ------------- + debug + setup + setup_model + load_model_subclass + init + + Instance methods + ---------------- + start_request_hook + is_model_applicable + get_session + authenticate + exception + additional_data + preprocess_path + +=head1 CLASS METHODS + +=over 4 + +=item debug + + sub My::App::debug {1} + +Returns the debugging flag. Override this in your application class to +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 } -sub setup { - my $calling_class = shift; - $calling_class = ref $calling_class if ref $calling_class; - { - no strict 'refs'; - no warnings 'redefine'; +=item config - # 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 } ) { - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - $config->model->adopt($subclass) - if $config->model->can("adopt"); - } +Returns the L object + +=item setup + + My::App->setup($data_source, $user, $password, \%attr); + +Initialise the Maypole application and plugins and model classes. +Your application should call this B setting up configuration data via +L<"config">. + +It calls the hook C to setup the model. The %attr hash contains +options and arguments used to set up the model. See the particular model's +documentation. However here is the most usage of setup where +Maypole::Model::CDBI is the base class. + + My::App->setup($data_source, $user, $password, + { options => { # These are DB connection options + AutoCommit => 0, + RaiseError => 1, + ... + }, + # These are Class::DBI::Loader arguments. + relationships => 1, + ... + } + ); + +Also, see L. + +=cut + + +sub setup +{ + my $class = shift; + + $class->setup_model(@_); } -sub init { +=item setup_model + +Called by C. This method builds the Maypole model hierarchy. + +A likely target for over-riding, if you need to build a customised model. + +This method also ensures any code in custom model classes is loaded, so you +don't need to load them in the driver. + +=cut + +sub setup_model { + my $class = shift; + $class = ref $class if ref $class; + my $config = $class->config; + $config->model || $config->model('Maypole::Model::CDBI'); + $config->model->require or die sprintf + "Couldn't load the model class %s: %s", $config->model, $@; + + # among other things, this populates $config->classes + $config->model->setup_database($config, $class, @_); + + foreach my $subclass ( @{ $config->classes } ) { + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + unshift @{ $subclass . "::ISA" }, $config->model; + } + + # Load custom model code, if it exists - nb this must happen after the + # unshift, to allow code attributes to work, but before adopt(), + # in case adopt() calls overridden methods on $subclass + foreach my $subclass ( @{ $config->classes } ) { + $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); + $config->model->adopt($subclass) if $config->model->can("adopt"); + } + +} + +=item load_model_subclass($subclass) + +This method is called from C. It attempts to load the +C<$subclass> package, if one exists. So if you make a customized C +package, you don't need to explicitly load it. + +If automatic loading causes problems, Override load_model_subclass in your driver. + +sub load_model_subclass {}; + +Or perhaps during development, if you don't want to load up custom classes, you +can override this method and load them manually. + +=cut + +sub load_model_subclass { + my ($class, $subclass) = @_; + + my $config = $class->config; + + # Load any external files for the model base class or subclasses + # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from + # Maypole::Plugin::Loader and Class::DBI. + if ( $subclass->require ) { + warn "Loaded external module for '$subclass'\n" if $class->debug > 1; + } else { + (my $filename = $subclass) =~ s!::!/!g; + die "Loading '$subclass' failed: $@\n" + unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; + warn "No external module for '$subclass'" + if $class->debug > 1; + } +} + +=item init + +Loads the view class and instantiates the view object. + +You should not call this directly, but you may wish to override this to add +application-specific initialisation - see L. + +=cut + +sub init +{ my $class = shift; my $config = $class->config; $config->view || $config->view("Maypole::View::TT"); @@ -54,439 +369,1084 @@ sub init { || $config->display_tables( $class->config->tables ); $class->view_object( $class->config->view->new ); $class->init_done(1); - } -sub handler { +=item new + +Constructs a very minimal new Maypole request object. - # See Maypole::Workflow before trying to understand this. - my ( $class, $req ) = @_; - $class->init unless $class->init_done; +=cut - # Create the request object - my $r = bless { - template_args => {}, - config => $class->config +sub new +{ + my ($class) = @_; + my $self = bless { + config => $class->config, }, $class; - $r->headers_out(Maypole::Headers->new); - $r->get_request($req); - $r->parse_location(); - my $status = $r->handler_guts(); - return $status unless $status == OK; - $r->send_output; - return $status; + + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + + return $self; } -# The root of all evil -sub handler_guts { - my $r = shift; - $r->model_class( $r->config->model->class_of( $r, $r->{table} ) ); +=item view_object + +Get/set the Maypole::View object + +=back + +=head1 INSTANCE METHODS + +=head2 Workflow + +=over 4 - my $applicable = $r->is_applicable; - unless ( $applicable == OK ) { +=item handler + +This method sets up the class if it's not done yet, sets some defaults and +leaves the dirty work to C. + +=cut + +# 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 +sub handler : method { + # See Maypole::Workflow before trying to understand this. + my ($class, $req) = @_; + + $class->init unless $class->init_done; + + my $self = $class->new; + + # initialise the request + $self->headers_out(Maypole::Headers->new); + $self->get_request($req); + + $self->parse_location; + + # 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(); + die "status undefined after start_request_hook()" unless defined + $self->status; + $self->get_session; + $self->get_user; + my $status = $self->handler_guts; + return $status unless $status == OK; + # TODO: require send_output to return a status code + $self->send_output; + return $status; +} + +=item component + + Run Maypole sub-requests as a component of the request + + [% request.component("/beer/view_as_component/20") %] + + Allows you to integrate the results of a Maypole request into an existing +request. You'll need to set up actions and templates +which return fragments of HTML rather than entire pages, but once you've +done that, you can use the C method of the Maypole request object +to call those actions. You may pass a query string in the usual URL style. + +You should not fully qualify the Maypole URLs. + +Note: any HTTP POST or URL parameters passed to the parent are not passed to the +component sub-request, only what is included in the url passed as an argyument +to the method + +=cut + +sub component { + my ( $r, $path ) = @_; + my $self = bless { parent => $r, config => $r->{config}, } , ref $r; + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + + $self->get_user; + my $url = URI->new($path); + warn "path : $path\n"; + $self->{path} = $url->path; + $self->parse_path; + $self->params( $url->query_form_hash ); + $self->handler_guts; + return $self->output; +} - # It's just a plain template - delete $r->{model_class}; - $r->{path} =~ s{/$}{}; # De-absolutify - $r->template( $r->{path} ); +sub get_template_root { + my $self = shift; + my $r = shift; + return $r->parent->get_template_root if $r->{parent}; + return $self->NEXT::DISTINCT::get_template_root( $r, @_ ); +} + +sub view_object { + my $self = shift; + my $r = shift; + return $r->parent->view_object if $r->{parent}; + return $self->NEXT::DISTINCT::view_object( $r, @_ ); +} + +# 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 +request/response and defines the workflow within Maypole. + +B. + +=cut + +# The root of all evil +sub handler_guts +{ + my ($self) = @_; + + $self->__load_request_model; + + my $applicable = $self->is_model_applicable == OK; - # We authenticate every request, needed for proper session management my $status; - eval { $status = $r->call_authenticate }; - if ( my $error = $@ ) { - $status = $r->call_exception($error); - if ( $status != OK ) { + + # handle authentication + eval { $status = $self->call_authenticate }; + if ( my $error = $@ ) + { + $status = $self->call_exception($error, "authentication"); + if ( $status != OK ) + { warn "caught authenticate error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } - if ( $r->debug and $status != OK and $status != DECLINED ) { - $r->view_object->error( $r, + if ( $self->debug and $status != OK and $status != DECLINED ) + { + $self->view_object->error( $self, "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 ) { - eval { $r->model_class->process($r) }; - if ( my $error = $@ ) { - $status = $r->call_exception($error); - if ( $status != OK ) { - warn "caught model error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + $self->additional_data; + + if ($applicable) { + eval { $self->model_class->process($self) }; + if ( my $error = $@ ) + { + $status = $self->call_exception($error, "model"); + if ( $status != OK ) + { + warn "caught model error: $error"; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } + } else { + $self->__setup_plain_template; } - 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; - } - } - return $status; + + # less frequent path - perhaps output has been set to an error message + return OK if $self->output; + + # normal path - no output has been generated yet + my $processed_view_ok = $self->__call_process_view; + + $self->{content_type} ||= $self->__get_mime_type(); + $self->{document_encoding} ||= "utf-8"; + + + return $processed_view_ok; +} + +my %filetypes = ( + 'js' => 'text/javascript', + 'css' => 'text/css', + 'htm' => 'text/html', + 'html' => 'text/html', + ); + +sub __get_mime_type { + my $self = shift; + my $type = 'text/html'; + if ($self->path =~ m/.*\.(\w{3,4})$/) { + $type = $filetypes{$1}; + } else { + my $output = $self->output; + if (defined $output) { + $type = $mmagic->checktype_contents($output); + } + } + return $type; +} + +sub __load_request_model +{ + my ($self) = @_; + # We may get a made up class from class_of + my $mclass = $self->config->model->class_of($self, $self->table); + if ( eval {$mclass->isa('Maypole::Model::Base')} ) { + $self->model_class( $mclass ); + } + elsif ($self->debug) { + warn "***Warning: No $mclass class appropriate for model. @_"; + } +} + + +# 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 ($self) = @_; + + # It's just a plain template + $self->model_class(undef); + + my $path = $self->path; + $path =~ s{/$}{}; # De-absolutify + $self->path($path); + + $self->template($self->path); +} + +# The model has been processed or skipped (if is_applicable returned false), +# any exceptions have been handled, and there's no content in $self->output +sub __call_process_view { + my ($self) = @_; + + my $status = eval { $self->view_object->process($self) }; + + my $error = $@ || $self->{error}; + + if ( $error ) { + $status = $self->call_exception($error, "view"); + + if ( $status != OK ) { + warn "caught view error: $error" if $self->debug; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } - else { return OK; } + } + + return $status; } -sub is_applicable { - my $self = shift; +=item get_request + +You should only need to define this method if you are writing a new +Maypole backend. It should return something that looks like an Apache +or CGI request object, it defaults to blank. + +=cut + +sub get_request { } + +=item parse_location + +Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a Maypole +request. It does this by setting the C, and invoking C and +C. + +You should only need to define this method if you are writing a new Maypole +backend. + +=cut + +sub parse_location +{ + die "parse_location is a virtual method. Do not use Maypole directly; " . + "use Apache::MVC or similar"; +} + +=item start_request_hook + +This is called immediately after setting up the basic request. The default +method does nothing. + +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) = @_; + + $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 { } + +=item is_applicable + +B as of version 2.11. If you have overridden it, +please override C instead, and change the return type +from a Maypole:Constant to a true/false value. + +Returns a Maypole::Constant to indicate whether the request is valid. + +=cut + +sub is_applicable { return shift->is_model_applicable(@_); } + +=item is_model_applicable + +Returns true or false to indicate whether the request is valid. + +The default implementation checks that C<< $r->table >> is publicly +accessible and that the model class is configured to handle the +C<< $r->action >>. + +=cut + +sub is_model_applicable { + my ($self) = @_; + + # Establish which tables should be processed by the model my $config = $self->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" - . "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} }; + if ref $config->ok_tables eq "ARRAY"; + + my $ok_tables = $config->ok_tables; + + # Does this request concern a table to be processed by the model? + my $table = $self->table; + + my $ok = 0; + + if (exists $ok_tables->{$table}) + { + $ok = 1; + } - # Is it public? - return DECLINED unless $self->model_class->is_public( $self->{action} ); - return OK(); + if (not $ok) + { + warn "We don't have that table ($table).\n" + . "Available tables are: " + . join( ",", keys %$ok_tables ) + if $self->debug and not $ok_tables->{$table}; + + return DECLINED; + } + + # Is the action public? + my $action = $self->action; + return OK if $self->model_class->is_public($action); + + warn "The action '$action' is not applicable to the table '$table'" + if $self->debug; + + return DECLINED; } -sub call_authenticate { - my $self = shift; +=item get_session - # 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 +Called immediately after C. + +This method should return a session, which will be stored in the request's +C attribute. + +The default method is empty. + +=cut + +sub get_session { } + +=item get_user + +Called immediately after C. + +This method should return a user, which will be stored in the request's C +attribute. + +The default method is empty. + +=cut + +sub get_user {} + +=item call_authenticate + +This method first checks if the relevant model class +can authenticate the user, or falls back to the default +authenticate method of your Maypole application. + +=cut + +sub call_authenticate +{ + my ($self) = @_; + + # Check if we have a model class with an authenticate() to delegate to + return $self->model_class->authenticate($self) + if $self->model_class and $self->model_class->can('authenticate'); + + # Interface consistency is a Good Thing - + # the invocant and the argument may one day be different things + # (i.e. controller and request), like they are when authenticate() + # is called on a model class (i.e. model and request) + return $self->authenticate($self); } -sub call_exception { - my $self = shift; - my ($error) = @_; +=item authenticate - # Check if we have a model class - if ( $self->{model_class} - && $self->model_class->can('exception') ) +Returns a Maypole::Constant to indicate whether the user is authenticated for +the Maypole request. + +The default implementation returns C + +=cut + +sub authenticate { return OK } + + +=item 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 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. + +=cut + +sub call_exception +{ + 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); +} + + +=item exception + +This method is called if any exceptions are raised during the authentication or +model/view processing. It should accept the exception as a parameter and return +a Maypole::Constant to indicate whether the request should continue to be +processed. + +=cut + +sub exception { + my ($self, $error, $when) = @_; + if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) { + $self->view_object->report_error($self, $error, $when); + return OK; + } + return ERROR; } +=item additional_data + +Called before the model processes the request, this method gives you a chance to +do some processing for each request, for example, manipulating C. + +=cut + sub additional_data { } -sub authenticate { return OK } +=item send_output + +Sends the output and additional headers to the user. -sub exception { return ERROR } +=cut -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 send_output { + die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} + + +=back + +=head2 Path processing and manipulation + +=over 4 + +=item path + +Returns the request path + +=item parse_path + +Parses the request path and sets the C, C and C +properties. Calls C before parsing path and setting properties. + +=cut + +sub parse_path +{ + my ($self) = @_; + + # Previous versions unconditionally set table, action and args to whatever + # was in @pi (or else to defaults, if @pi is empty). + # Adding preprocess_path(), and then setting table, action and args + # conditionally, broke lots of tests, hence this: + $self->$_(undef) for qw/action table args/; + $self->preprocess_path; + $self->path || $self->path('frontpage'); + + my @pi = grep {length} split '/', $self->path; + + + $self->table || $self->table(shift @pi); + $self->action || $self->action( shift @pi or 'index' ); + $self->args || $self->args(\@pi); } -sub param { # like CGI::param(), but read-only +=item preprocess_path + +Sometimes when you don't want to rewrite or over-ride parse_path but +want to rewrite urls or extract data from them before it is parsed. + +This method is called after parse_location has populated the request +information and before parse_path has populated the model and action +information, and is passed the request object. + +You can set action, args or table in this method and parse_path will +then leave those values in place or populate them if not present + +=cut + +sub preprocess_path { }; + +=item make_path( %args or \%args or @args ) + +This is the counterpart to C. It generates a path to use +in links, form actions etc. To implement your own path scheme, just override +this method and C. + + %args = ( table => $table, + action => $action, + additional => $additional, # optional - generally an object ID + ); + + \%args = as above, but a ref + + @args = ( $table, $action, $additional ); # $additional is optional + +C can be used as an alternative key to C. + +C<$additional> can be a string, an arrayref, or a hashref. An arrayref is +expanded into extra path elements, whereas a hashref is translated into a query +string. + +=cut + +sub make_path +{ 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}}; + + my %args; + + if (@_ == 1 and ref $_[0] and ref $_[0] eq 'HASH') + { + %args = %{$_[0]}; + } + elsif ( @_ > 1 and @_ < 4 ) + { + $args{table} = shift; + $args{action} = shift; + $args{additional} = shift; } + else + { + %args = @_; + } + + do { die "no $_" unless $args{$_} } for qw( table action ); + + my $additional = $args{additional} || $args{id}; + + my @add = (); + + if ($additional) + { + # if $additional is a href, make_uri() will transform it into a query + @add = (ref $additional eq 'ARRAY') ? @$additional : ($additional); + } + + my $uri = $r->make_uri($args{table}, $args{action}, @add); + + return $uri->as_string; } -sub get_template_root { "." } -sub get_request { } -sub parse_location { - die "Do not use Maypole directly; use Apache::MVC or similar"; -} -sub send_output { - die "Do not use Maypole directly; use Apache::MVC or similar"; +=item make_uri( @segments ) + +Make a L object given table, action etc. Automatically adds +the C. + +If the final element in C<@segments> is a hash ref, C will render it +as a query string. + +=cut + +sub make_uri +{ + my ($r, @segments) = @_; + + my $query = (ref $segments[-1] eq 'HASH') ? pop(@segments) : undef; + + my $base = $r->config->uri_base; + $base =~ s|/$||; + + my $uri = URI->new($base); + $uri->path_segments($uri->path_segments, grep {length} @segments); + + my $abs_uri = $uri->abs('/'); + $abs_uri->query_form($query) if $query; + return $abs_uri; } -# Session and Repeat Submission Handling +=item parse_args -sub make_random_id { - use Maypole::Session; - return Maypole::Session::generate_unique_id(); +Turns post data and query string paramaters into a hash of C. + +You should only need to define this method if you are writing a new Maypole +backend. + +=cut + +sub parse_args +{ + die "parse_args() is a virtual method. Do not use Maypole directly; ". + "use Apache::MVC or similar"; } -=head1 NAME +=item get_template_root -Maypole - MVC web application framework +Implementation-specific path to template root. -=head1 SYNOPSIS +You should only need to define this method if you are writing a new Maypole +backend. Otherwise, see L -See L. +=cut -=head1 DESCRIPTION +=back -This documents the Maypole request object. See the L, for a -detailed guide to using Maypole. +=head2 Request properties -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. +=over 4 -To use it, you need to create a package which represents your entire -application. In our example above, this is the C package. +=item model_class -This needs to first use L which will make your package -inherit from the appropriate platform driver such as C or -C, and then call setup. This sets up the model classes and -configures your application. The default model class for Maypole uses -L to map a database to classes, but this can be changed by altering -configuration. (B calling setup.) +Returns the perl package name that will serve as the model for the +request. It corresponds to the request C
attribute. -=head2 CLASS METHODS -=head3 config +=item objects -Returns the L object +Get/set a list of model objects. The objects will be accessible in the view +templates. -=head3 setup +If the first item in C<$self-Eargs> can be Cd by the model +class, it will be removed from C and the retrieved object will be added to +the C list. See L for more information. - My::App->setup($data_source, $user, $password, \%attr); -Initialise the maypole application and model classes. Your application should -call this after setting configuration via L<"config"> +=item object -=head3 init +Alias to get/set the first/only model object. The object will be accessible +in the view templates. -You should not call this directly, but you may wish to override this to -add -application-specific initialisation. +When used to set the object, will overwrite the request objects +with a single object. -=head3 view_object +=cut -Get/set the Maypole::View object +sub object { + my ($r,$object) = @_; + $r->objects([$object]) if ($object); + return undef unless $r->objects(); + return $r->objects->[0]; +} -=head3 debug +=item template_args - sub My::App::debug {1} + $self->template_args->{foo} = 'bar'; -Returns the debugging flag. Override this in your application class to -enable/disable debugging. +Get/set a hash of template variables. -=head2 INSTANCE METHODS +Maypole reserved words for template variables will over-ride values in template_variables. -=head3 parse_location +Reserved words are : r, request, object, objects, base, config and errors, as well as the +current class or object name. -Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a -Maypole -request. It does this by setting the C, and invoking C -and -C. +=item stash -You should only need to define this method if you are writing a new -Maypole -backend. +A place to put custom application data. Not used by Maypole itself. -=head3 path +=item template -Returns the request path +Get/set the template to be used by the view. By default, it returns +C<$self-Eaction> -=head3 parse_path -Parses the request path and sets the C, C and C
-properties +=item error + +Get/set a request error -=head3 table +=item output + +Get/set the response output. This is usually populated by the view class. You +can skip view processing by setting the C. + +=item table The table part of the Maypole request path -=head3 action +=item action The action part of the Maypole request path -=head3 args +=item args A list of remaining parts of the request path after table and action have been removed -=head3 headers_in +=item headers_in A L object containing HTTP headers for the request -=head3 headers_out +=item headers_out A L object that contains HTTP headers for the output -=head3 parse_args +=item document_encoding -Turns post data and query string paramaters into a hash of C. - -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 -query string and POST data. - -B Where muliple values of a parameter were supplied, the -C -value -will be an array reference. +Get/set the output encoding. Default: utf-8. -=head3 get_template_root +=item content_type -Implementation-specific path to template root. +Get/set the output content type. Default: text/html -You should only need to define this method if you are writing a new -Maypole -backend. Otherwise, see L +=item get_protocol -=head3 get_request +Returns the protocol the request was made with, i.e. https -You should only need to define this method if you are writing a new -Maypole backend. It should return something that looks like an Apache -or CGI request object, it defaults to blank. +=cut +sub get_protocol { + die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} -=head3 is_applicable +=back -Returns a Maypole::Constant to indicate whether the request is valid. +=head2 Request parameters -The default implementation checks that C<$r-Etable> is publicly -accessible -and that the model class is configured to handle the C<$r-Eaction> +The source of the parameters may vary depending on the Maypole backend, but they +are usually populated from request query string and POST data. -=head3 authenticate +Maypole supplies several approaches for accessing the request parameters. Note +that the current implementation (via a hashref) of C and C is +likely to change in a future version of Maypole. So avoid direct access to these +hashrefs: -Returns a Maypole::Constant to indicate whether the user is -authenticated for -the Maypole request. + $r->{params}->{foo} # bad + $r->params->{foo} # better -The default implementation returns C + $r->{query}->{foo} # bad + $r->query->{foo} # better -=head3 model_class + $r->param('foo') # best -Returns the perl package name that will serve as the model for the -request. It corresponds to the request C
attribute. +=over 4 -=head3 additional_data +=item param -Called before the model processes the request, this method gives you a -chance -to do some processing for each request, for example, manipulating -C. +An accessor (get or set) for request parameters. It behaves similarly to +CGI::param() for accessing CGI parameters, i.e. -=head3 objects + $r->param # returns list of keys + $r->param($key) # returns value for $key + $r->param($key => $value) # returns old value, sets to new value -Get/set a list of model objects. The objects will be accessible in the -view -templates. +=cut -If the first item in C<$r-Eargs> can be Cd by the model -class, -it will be removed from C and the retrieved object will be added -to the -C list. See L for more information. +sub param +{ + my ($self, $key) = (shift, shift); + + return keys %{$self->params} unless defined $key; + + return unless exists $self->params->{$key}; + + my $val = $self->params->{$key}; + + if (@_) + { + my $new_val = shift; + $self->params->{$key} = $new_val; + } + + return ref $val ? @$val : ($val) if wantarray; + + return ref $val ? $val->[0] : $val; +} -=head3 template_args - $r->template_args->{foo} = 'bar'; +=item params -Get/set a hash of template variables. +Returns a hashref of request parameters. -=head3 template +B Where muliple values of a parameter were supplied, the C value +will be an array reference. -Get/set the template to be used by the view. By default, it returns -C<$r-Eaction> +=item query -=head3 exception +Alias for C. -This method is called if any exceptions are raised during the -authentication -or -model/view processing. It should accept the exception as a parameter and -return -a Maypole::Constant to indicate whether the request should continue to -be -processed. +=back -=head3 error +=head3 Utility methods -Get/set a request error +=over 4 -=head3 output +=item redirect_request -Get/set the response output. This is usually populated by the view -class. You -can skip view processing by setting the C. +Sets output headers to redirect based on the arguments provided -=head3 document_encoding +Accepts either a single argument of the full url to redirect to, or a hash of +named parameters : -Get/set the output encoding. Default: utf-8. +$r->redirect_request('http://www.example.com/path'); -=head3 content_type +or -Get/set the output content type. Default: text/html +$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..'); -=head3 send_output +The named parameters are protocol, domain, path, status and url -Sends the output and additional headers to the user. +Only 1 named parameter is required but other than url, they can be combined as +required and current values (from the request) will be used in place of any +missing arguments. The url argument must be a full url including protocol and +can only be combined with status. -=head3 call_authenticate +=cut -This method first checks if the relevant model class -can authenticate the user, or falls back to the default -authenticate method of your Maypole application. +sub redirect_request { + die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; +} +=item redirect_internal_request -=head3 call_exception +=cut -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. +sub redirect_internal_request { -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. +=item make_random_id -=head3 handler +returns a unique id for this request can be used to prevent or detect repeat +submissions. -This method sets up the class if it's not done yet, sets some -defaults and leaves the dirty work to handler_guts. +=cut -=head3 handler_guts +# Session and Repeat Submission Handling +sub make_random_id { + use Maypole::Session; + return Maypole::Session::generate_unique_id(); +} -This is the core of maypole. You don't want to know. +=back + +=head1 SEQUENCE DIAGRAMS + +See L for a detailed discussion of the sequence of +calls during processing of a request. This is a brief summary: + + INITIALIZATION + Model e.g. + BeerDB Maypole::Model::CDBI + | | + setup | | + o-------->|| | + || setup_model | setup_database() creates + ||------+ | a subclass of the Model + |||<----+ | for each table + ||| | | + ||| setup_database | | + |||--------------------->|| 'create' * + ||| ||----------> $subclass + ||| | | + ||| load_model_subclass | | + foreach |||------+ ($subclass) | | + $subclass ||||<----+ | require | + ||||--------------------------------------->| + ||| | | + ||| adopt($subclass) | | + |||--------------------->|| | + | | | + | | | + |-----+ init | | + ||<---+ | | + || | new | view_object: e.g. + ||---------------------------------------------> Maypole::View::TT + | | | | + | | | | + | | | | + | | | | + | | | | + + + + HANDLING A REQUEST + + + BeerDB Model $subclass view_object + | | | | + handler | | | | + o-------->| new | | | + |-----> r:BeerDB | | | + | | | | | + | | | | | + | || | | | + | ||-----+ parse_location | | | + | |||<---+ | | | + | || | | | + | ||-----+ start_request_hook | | | + | |||<---+ | | | + | || | | | + | ||-----+ get_session | | | + | |||<---+ | | | + | || | | | + | ||-----+ get_user | | | + | |||<---+ | | | + | || | | | + | ||-----+ handler_guts | | | + | |||<---+ | | | + | ||| class_of($table) | | | + | |||------------------------->|| | | + | ||| $subclass || | | + | |||<-------------------------|| | | + | ||| | | | + | |||-----+ is_model_applicable| | | + | ||||<---+ | | | + | ||| | | | + | |||-----+ call_authenticate | | | + | ||||<---+ | | | + | ||| | | | + | |||-----+ additional_data | | | + | ||||<---+ | | | + | ||| process | | | + | |||--------------------------------->|| fetch_objects + | ||| | ||-----+ | + | ||| | |||<---+ | + | ||| | || | + | ||| | || $action + | ||| | ||-----+ | + | ||| | |||<---+ | + | ||| process | | | + | |||------------------------------------------->|| template + | ||| | | ||-----+ + | ||| | | |||<---+ + | ||| | | | + | || send_output | | | + | ||-----+ | | | + | |||<---+ | | | + $status | || | | | + <------------------|| | | | + | | | | | + | X | | | + | | | | + | | | | + | | | | + + =head1 SEE ALSO -There's more documentation, examples, and a information on our mailing lists +There's more documentation, examples, and information on our mailing lists at the Maypole web site: L @@ -495,12 +1455,14 @@ L, L, L. =head1 AUTHOR -Maypole is currently maintained by Simon Flack C +Maypole is currently maintained by Aaron Trevena. =head1 AUTHOR EMERITUS Simon Cozens, C +Simon Flack maintained Maypole from 2.05 to 2.09 + Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 =head1 THANKS TO @@ -516,3 +1478,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 cd4318f..ae95bb7 100644 --- a/lib/Maypole/Application.pm +++ b/lib/Maypole/Application.pm @@ -2,19 +2,22 @@ package Maypole::Application; use strict; use warnings; + use UNIVERSAL::require; use Maypole; use Maypole::Config; -our @ISA; -our $VERSION = '2.09'; +our $VERSION = '2.11'; sub import { - my ( $class, @plugins ) = @_; + shift; # not interested in this - we manipulate the caller's @ISA directly + my @plugins = @_; my $caller = caller(0); my $frontend = 'Apache::MVC' if $ENV{MOD_PERL}; + $frontend = 'Maypole::HTTPD::Frontend' if $ENV{MAYPOLE_HTTPD}; + my $masonx; if ( grep { /^MasonX$/ } @plugins ) { @@ -26,39 +29,41 @@ sub import { $frontend ||= 'CGI::Maypole'; $frontend->require or die "Loading $frontend frontend failed: $@"; - push @ISA, $frontend; my $autosetup=0; + my $autoinit=0; my @plugin_modules; + + foreach (@plugins) { - foreach (@plugins) { - if (/^\-Setup$/) { $autosetup++; } - 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::$_"; - unshift @ISA, "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, $class; + push @{"${caller}::ISA"}, @plugin_modules, $frontend; $caller->config(Maypole::Config->new); $caller->config->masonx({}) if $masonx; $caller->setup() if $autosetup; + $caller->init() if $autosetup && $autoinit; } 1; @@ -83,19 +88,42 @@ Maypole::Application - Universal Maypole Frontend This is a universal frontend for mod_perl1, mod_perl2, HTML::Mason and CGI. -You can omit the Maypole::Plugin:: prefix from plugins. -So Maypole::Plugin::Config::YAML becomes Config::YAML. +Automatically determines the appropriate frontend for your environment (unless +you want to use L, in which case include C in the +arguments). + +Loads plugins supplied in the C statement. + +Responds to flags supplied in the C statement. + +Initializes the application's configuration object. + +You can omit the Maypole::Plugin:: prefix from plugins. So +Maypole::Plugin::Config::YAML becomes Config::YAML. use Maypole::Application qw(Config::YAML); -You can also set special flags like -Setup and -Debug. +You can also set special flags like -Setup, -Debug and -Init. use Maypole::Application qw(-Debug Config::YAML -Setup); -The position of plugins and flags in the chain is important, -because they are loaded/executed in the same order they appear. +The position of plugins in the chain is important, because they are +loaded/executed in the same order they appear. + +=head1 FRONTEND + +Under mod_perl (1 or 2), selects L. + +Otherwise, selects L. -=head2 -Setup +If C is specified, sets L as the frontend. This +currently also requires a mod_perl environment. + +=head1 FLAGS + +=over + +=item -Setup use Maypole::Application qw(-Setup); @@ -108,7 +136,26 @@ Note that no options are passed to C. You must ensure that the required model config parameters are set in Cconfig>. See L for more information. -=head2 -Debug +=item -Init + + use Maypole::Application qw(-Setup -Init); + +is equivalent to + + use Maypole::Application; + MyApp->setup; + MyApp->init; + +Note that the C<-Setup> flag is required for the C<-Init> flag to work. + +In persistent environments (e.g. C), it is useful to call C +once in the parent server, rather than at the beginning of the first request +to each child server, in order to share the view code loaded during C. +Note that you must supply all the config data to your app before calling +C and C, probably by using one of the C +plugins. + +=item -Debug use Maypole::Application qw(-Debug); @@ -119,6 +166,8 @@ is equivalent to You can specify a higher debug level by saying C<-Debug2> etc. +=back + =head1 AUTHOR Sebastian Riedel, C diff --git a/lib/Maypole/Config.pm b/lib/Maypole/Config.pm index 88dc8ee..040a4c8 100644 --- a/lib/Maypole/Config.pm +++ b/lib/Maypole/Config.pm @@ -5,7 +5,7 @@ use attributes (); use strict; use warnings; -our $VERSION = "1." . sprintf "%04d", q$Rev: 333 $ =~ /: (\d+)/; +our $VERSION = "1." . sprintf "%04d", q$Rev: 334 $ =~ /: (\d+)/; # Public accessors. __PACKAGE__->mk_accessors( diff --git a/lib/Maypole/Constants.pm b/lib/Maypole/Constants.pm index 9c018f9..b70a06c 100644 --- a/lib/Maypole/Constants.pm +++ b/lib/Maypole/Constants.pm @@ -3,9 +3,9 @@ use strict; use base 'Exporter'; use constant OK => 0; use constant DECLINED => -1; -use constant ERROR => -1; +use constant ERROR => 500; our @EXPORT = qw(OK DECLINED ERROR); -our $VERSION = "1." . sprintf "%04d", q$Rev: 354 $ =~ /: (\d+)/; +our $VERSION = "1." . sprintf "%04d", q$Rev: 483 $ =~ /: (\d+)/; 1; diff --git a/lib/Maypole/Headers.pm b/lib/Maypole/Headers.pm index dff1ced..28675fc 100644 --- a/lib/Maypole/Headers.pm +++ b/lib/Maypole/Headers.pm @@ -4,7 +4,7 @@ use base 'HTTP::Headers'; use strict; use warnings; -our $VERSION = "1." . sprintf "%04d", q$Rev: 324 $ =~ /: (\d+)/; +our $VERSION = "1." . sprintf "%04d", q$Rev: 376 $ =~ /: (\d+)/; sub get { shift->header(shift); @@ -14,6 +14,8 @@ sub set { shift->header(@_); } +*add = \&push; # useful for Apache::Session::Wrapper support + sub push { shift->push_header(@_); } @@ -84,6 +86,10 @@ Add a value to the field named C<$header>. Previous values are maintained. An alias to Cpush_header> +=item add + +Alias to C - useful for C support, in CGI mode. + =item init($header =C $value) Set the value for the field named C<$header>, but only if that header is diff --git a/lib/Maypole/Manual.pod b/lib/Maypole/Manual.pod index dc60222..d556ae9 100644 --- a/lib/Maypole/Manual.pod +++ b/lib/Maypole/Manual.pod @@ -71,6 +71,15 @@ This document also introduces the theory behind Maypole's actions and templates, showing you how to write your own so that you can have a highly customized application. +=item L - writing Maypole plugins + +Useful information for plugin authors. + +=item L - pinning down usage + +As well as defining common terms used in Maypole discussions, this document +briefly discusses the MVC-ness of Maypole. + =item L - Description of the Request Workflow This is a technical document that describes the progress of a @@ -83,7 +92,7 @@ and not to most of those who are using it. This document gives a close look at the Beer database that was introduced in L. -=item L - The Request Cookbook +=item L - The Maypole Cookbook This extensive document is Maypole's main "How do I do X?" FAQ. It provides a wide variety of cookbook-like techniques that diff --git a/lib/Maypole/Manual/About.pod b/lib/Maypole/Manual/About.pod index d78be34..6f48663 100644 --- a/lib/Maypole/Manual/About.pod +++ b/lib/Maypole/Manual/About.pod @@ -74,48 +74,6 @@ logic of your application. This is one of the reasons why Maypole lets you develop so rapidly: because most of the time, you don't need to do any development at all. -=head2 Installing Maypole - -The first thing you're going to need to do to get Maypole running is to -install it. Maypole needs an absolute shedload of Perl modules from CPAN -to do its job. I am unrepentant about this. Maypole does a lot of work, -so that you don't have to. This is called code re-use, and if we're -serious about code re-use, then Maypole should be re-using as much code -as possible in terms of Perl modules. In another sense, this gives the -impression that Maypole doesn't actually do all that much itself, -because all it's doing is gluing together already-existing code. Well, -welcome to code re-use. - -The downside of code re-use is, of course, that you then have to install -a shedload of Perl modules from CPAN. If you're using OpenBSD or -FreeBSD, the wonderful ports system will be your friend. There's a -Maypole port in C. Just type C. - -Debian users, hang in there. There's a package coming. - -For other Unices, the L or C modules will help with -this. If you don't have C installed, my recommendation is to -use C to install it and then throw -C away. In any case, one of these two should get all that -Maypole needs: - - % perl -MCPANPLUS -e 'install Maypole' - % perl -MCPAN -e 'install Maypole' - -I don't know if Maypole works on Windows. I'm not sure I care. - -You're also going to need a database server and a web server. For -databases, I recommend SQLite (if you install the C module, -you get the SQLite library for free) for prototyping and mysql for -production; heavier duty users should use Postgresql or Oracle - Maypole -should be happy with them all. Maypole is happiest when running under -Apache C, with the C module installed, but as -I said, it is a blank slate, and everything is customizable. There is a -C frontend available to run as a standalone CGI script. - -As well as the documentation embedded in the Perl modules the distribution -also includes the manual, of which this is a part. You can access it using the -perldoc command, the man command, or by browsing CPAN. =head2 The Beer Database example diff --git a/lib/Maypole/Manual/Beer.pod b/lib/Maypole/Manual/Beer.pod index 542b570..f99e0a2 100644 --- a/lib/Maypole/Manual/Beer.pod +++ b/lib/Maypole/Manual/Beer.pod @@ -185,12 +185,15 @@ The equivalent in ordinary C would be: BeerDB::Handpump->has_a(beer => "BeerDB::Beer"); BeerDB::Handpump->has_a(pub => "BeerDB::Pub"); - BeerDB::Pub->has_many(beers => [ BeerDB::Handpump => 'beer' ]); - BeerDB::Beer->has_many(pubs => [ BeerDB::Handpump => 'pub' ]); + BeerDB::Pub->has_many(beers => [ 'BeerDB::Handpump' => 'beer' ]); + BeerDB::Beer->has_many(pubs => [ 'BeerDB::Handpump' => 'pub' ]); Maypole's default templates will use this information to display, for instance, a list of a brewery's beers on the brewery view page. +Note the quoting in 'BeerDB::Handpump' => 'beer', if you forget to quote the +left side when using strict you will get compilation errors. + This is the complete beer database application; Maypole's default templates and the actions in the view class do the rest. But what if we want to do a little more. How would we begin to extend this application? diff --git a/lib/Maypole/Manual/Cookbook.pod b/lib/Maypole/Manual/Cookbook.pod new file mode 100644 index 0000000..1d2395c --- /dev/null +++ b/lib/Maypole/Manual/Cookbook.pod @@ -0,0 +1,839 @@ +=head1 NAME + +Maypole::Manual::Cookbook - Maypole Cookbook + +=head1 DESCRIPTION + +Hacks; design patterns; recipes: call it what you like, this chapter is a +developing collection of techniques which can be slotted in to Maypole +applications to solve common problems or make the development process easier. + +As Maypole developers, we don't necessarily know the "best practice" for +developing Maypole applications ourselves, in the same way that Larry Wall +didn't know all about the best Perl programming style as soon as he wrote +Perl. These techniques are what we're using at the moment, but they may +be refined, modularized, or rendered irrelevant over time. But they've +certainly saved us a bunch of hours work. + +=head2 Frontend hacks + +These hacks deal with changing the way Maypole relates to the outside world; +alternate front-ends to the Apache and CGI interfaces, or subclassing chunks +of the front-end modules to alter Maypole's behaviour in particular ways. + +=head3 Separate model class modules + +You want to put all the C routines in a separate module, +so you say: + + package BeerDB::Beer; + BeerDB::Beer->has_a(brewery => "BeerDB::Brewery"); + sub foo :Exported {} + +And in F, you put: + + use BeerDB::Beer; + +It doesn't work. + +B: It doesn't work because of the timing of the module loading. +C will try to set up the C relationships +at compile time, when the database tables haven't even been set up, +since they're set up by + + BeerDB->setup("...") + +which does its stuff at runtime. There are two ways around this; you can +either move the C call to compile time, like so: + + BEGIN { BeerDB->setup("...") } + +or move the module loading to run-time (my preferred solution): + + BeerDB->setup("..."); + BeerDB::Beer->require; + +=head3 Redirecting to SSL for sensitive information + +You have a website with forms that people will be entering sensitive information into, +such as credit cards or login details. You want to make sure that they aren't sent +in plain text but over SSL instead. + +B + +The solution is a bit tricky for 2 reasons : + +Firstly -- Many browsers and web clients will change a redirected +POST request into a GET request (which displays all that sensitive information in the +browser, or access logs and possibly elsewhere) and/or drops the values on the floor. + +Secondly -- If somebody has sent that sensitive information in plain text already, then +sending it again over SSL won't solve the problem. + +Redirecting a request is actually rather simple : + +$r->redirect_request('https://www.example.com/path'); # perldoc Maypole for API + +.. as is checking the protocol : + +$r->get_protocol(); # returns 'http' or 'https' + +You should check that the action that generates the form that people will enter +the sensitive information into is https and redirect if not. + +You should also check that no information is lost when redirecting, possibly by +storing it in a session and retrieving it later - see Maypole::Plugin::Session + +=head3 Debugging with the command line + +You're seeing bizarre problems with Maypole output, and you want to test it in +some place outside of the whole Apache/mod_perl/HTTP/Internet/browser circus. + +B: Use the L module to go directly from a URL to +standard output, bypassing Apache and the network altogether. + +L is not a standalone front-end, but to allow you to debug your +applications without having to change the front-end they use, it temporarily +"borgs" an application. If you run it from the command line, you're expected +to use it like so: + + perl -MMaypole::CLI=Application -e1 'http://your.server/path/table/action' + +For example: + + perl -MMaypole::CLI=BeerDB -e1 'http://localhost/beerdb/beer/view/1?o2=desc' + +You can also use the C module programatically to create +test suites for your application. See the Maypole tests themselves or +the documentation to C for examples of this. + +Don't forget also to turn on debugging output in your application: + + package BeerDB; + use strict; + use warnings; + use Maypole::Application qw(-Debug); + +=head3 Changing how URLs are parsed + +You don't like the way Maypole URLs look, and want something that either +fits in with the rest of your site or hides the internal workings of the +system. + +B: So far we've been using the C
form +of a URL as though it was "the Maypole way"; well, there is no Maypole +way. Maypole is just a framework and absolutely everything about it is +overridable. + +If we want to provide our own URL handling, the method to override in +the driver class is C. This is responsible for taking +C<$r-Epath> and filling the C, C and C slots +of the request object. Normally it does this just by splitting the path +on 'C' characters, but you can do it any way you want, including +getting the information from C form parameters or session variables. + +For instance, suppose we want our URLs to be of the form +C, we could provide a C method +like so: + + sub parse_path { + my $r = shift; + $r->path("ProductList.html") unless $r->path; + ($r->path =~ /^(.*?)([A-Z]\w+)\.html/); + $r->table(lc $1); + $r->action(lc $2); + my %query = $r->ar->args; + $self->args([ $query{id} ]); + } + +This takes the path, which already has the query parameters stripped off +and parsed, and finds the table and action portions of the filename, +lower-cases them, and then grabs the C from the query. Later methods +will confirm whether or not these tables and actions exist. + +See the L for another +example of custom URL processing. + +=head3 Maypole for mobile devices + +You want Maypole to use different templates to display on particular +browsers. + +B: There are several ways to do this, but here's the neatest +we've found. Maypole chooses where to get its templates either by +looking at the C config parameter or, if this is not +given, calling the C method to ask the front-end to +try to work it out. We can give the front-end a little bit of help, by +putting this method in our driver class: + + sub get_template_root { + my $r = shift; + my $browser = $r->headers_in->get('User-Agent'); + if ($browser =~ /mobile|palm|nokia/i) { + "/home/myapp/templates/mobile"; + } else { + "/home/myapp/templates/desktop"; + } + } + +(Maybe there's a better way to detect a mobile browser, but you get the +idea.) + +=head2 Content display hacks + +These hacks deal primarily with the presentation of data to the user, +modifying the F template or changing the way that the results of +particular actions are displayed. + +=head3 Null Action + +You need an "action" which doesn't really do anything, but just formats +up a template. + +B: There are two ways to do this, depending on what precisely +you need. If you just need to display a template, C +style, with no Maypole objects in it, then you don't need to write any +code; just create your template, and it will be available in the usual +way. + +If, on the other hand, you want to display some data, and what you're +essentially doing is a variant of the C action, then you need to +ensure that you have an exported action, as described in the +L and C"> +chapter: + + sub my_view :Exported { } + +=head3 Template Switcheroo + +An action doesn't have any data of its own to display, but needs to display +B. + +B: This is an B common hack. You've just issued an +action like C, which updates the database. You don't want +to display a page that says "Record updated" or similar. Lesser +application servers would issue a redirect to have the browser request +C> instead, but we can actually modify the Maypole +request on the fly and, after doing the update, pretend that we were +going to C> all along. We do this by setting the +objects in the C slot and changing the C