From: Ben Hutchings Date: Tue, 4 Nov 2008 03:34:39 +0000 (+0000) Subject: Merge commit '2.13' into HEAD X-Git-Url: https://git.decadent.org.uk/gitweb/?a=commitdiff_plain;h=fadcae3ffddebaa38da172f9624cc60176d80b33;hp=d813b3413bbd58789200c2ef02c7386e33cabe00;p=maypole.git Merge commit '2.13' into HEAD --- diff --git a/Changes b/Changes index 3f69490..d7fa765 100644 --- a/Changes +++ b/Changes @@ -2,17 +2,78 @@ 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 : + +2.13 April 2008 +SVN Revision + +Bug Fixes : + DBD::SQLite no longer required by Makefile.PL + CGI handler now produces response for fatal error (bug 29981) + Fix to link macro + Fix to redirect_request in Apache::MVC + Fix to mime detection by file extension + Fixed MODIFY_CODE_ATTRIBUTES and FETCH_CODE_ATTRIBUTES to work with mod_perl threaded model + - Patch from Ben Hutchings http://rt.cpan.org/Public/Bug/Display.html?id=29984 + fixes for bug 29982 Inconsistency between examples and tutorial (patch from Ben Hutchings) + fixed apache_mvc.t to work with Apache2 (bug #29979 patch from Ben Hutchings) + added post_chomp as default option for TT view + +Improvements : + link macro now takes a target argument, and has slightly better pod + +2.121 29 August 2007 + +SVN revision 581 + +Bug Fixes : + Apache::Request is fetched with a new object instead of instance if request options are provided + additional, request_options and view_options attributes of Maypole::Config are initialised with hashref + do_delete action now has exported attribute in ::Model::CDBI::Base + Fixed links in flox to cookbook (bug 22899) + Applied change from bug 14565 + +2.12 22 June 2007 + +SVN revision 573 + +Bug Fixes : + Fixed some db_colinfo test bugs 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) + AsForm fixes to stringification _to_select + made DFV and FromCGI warn instead of die on unexpected cgi params + small improvements to some factory templates + fix to path handling in mod_perl and CGI when location ends in / + fixed template path ordering so i.e. /tablename/list is used before /list when provided with a tablename fixed template path with array refs - fixed redirect_request - fixed db_colinfo.t test when no mysql + fix to template being reset from path in plain templates (i.e. where no model), may affect those relying on the bug ( bug 23722 ) + fix to display_line macro in factory templates (bug 22920) + fix to correct problem with LocationMatch and regex based Location directives in apache config. + fix to redirect_request + Fixed typo in _do_update_or_create (bug 26495) + + +API additions and enhancements : + new Class::DBI::DFV based model + New config method : additional, for stashing additional info, especially from additional_data method + new warn method in maypole/request class/object, over-ridden by Apache::MVC, etc or own driver + new build_form_elements attribute for Maypole request and Maypole::Config, set it to 0 to avoid building cgi form if you don't need it + added CGI params to TT error template + improvements to factory templates + added search_columns method to base cdbi model class, provides display_columns unless over-ridden + added new hook - preprocess_location + added new attribute to Maypole::Config - request_options + improved pager template macro + + +Internal additions and enhancements : + Inheritence simpler and nicer and less hacked + add_model_superclass method moves @ISA munging into the model + new test to check everything compiles + Model inheritance re-organised +2.111 Mon 30 April 2007 + - forked - see 2.111 changelog 2.11 Mon 31 July 2006 diff --git a/MANIFEST b/MANIFEST index d5515b9..83a2a6d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,27 +1,29 @@ 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 +examples/BeerDB.pm +examples/BeerDB/Base.pm +examples/BeerDB/Beer.pm +examples/beerdb.sql +examples/fancy_example/BeerDB.pm +examples/fancy_example/beerdb.sql +examples/fancy_example/BeerDB/Base.pm +examples/fancy_example/BeerDB/Beer.pm +examples/fancy_example/BeerDB/Brewery.pm +examples/fancy_example/BeerDB/Drinker.pm +examples/fancy_example/templates/custom/addnew +examples/fancy_example/templates/custom/display_inputs +examples/fancy_example/templates/custom/display_search_inputs +examples/fancy_example/templates/custom/edit +examples/fancy_example/templates/custom/header +examples/fancy_example/templates/custom/maypole.css +examples/fancy_example/templates/custom/metadata +examples/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/HTTPD.pm +lib/Maypole/HTTPD/Frontend.pm lib/Maypole/CLI.pm lib/Maypole/Config.pm lib/Maypole/Constants.pm @@ -45,6 +47,8 @@ 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/Model/CDBI/Base.pm +lib/Maypole/Model/CDBI/DFV.pm lib/Maypole/View/Base.pm lib/Maypole/View/TT.pm Makefile.PL @@ -53,6 +57,7 @@ MANIFEST.SKIP META.yml README AUTHORS +t/00compile.t t/01basics.t t/01.httpd-basic.t t/02pod.t diff --git a/META.yml b/META.yml index 6fd72b6..17c5cfb 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Maypole -version: 2.111 +version: 2.13 version_from: lib/Maypole.pm installdirs: site requires: @@ -16,19 +16,16 @@ requires: Class::DBI::Pager: 0 Class::DBI::Plugin::RetrieveAll: 0 Class::DBI::Plugin::Type: 0 - Class::DBI::SQLite: 0.08 Digest::MD5: 0 File::MMagic::XS: 0.08 - HTML::Element: 0 + HTML::Tree: 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.30 diff --git a/Makefile.PL b/Makefile.PL index 935c677..5b7ca8b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -13,18 +13,15 @@ WriteMakefile( Class::DBI::Plugin::RetrieveAll => 0, Class::DBI::Loader::Relationship => 0, Class::DBI => 0.96, - 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, + HTML::Tree => 0, Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, diff --git a/ex/BeerDB.pm b/ex/BeerDB.pm deleted file mode 100644 index e0b2894..0000000 --- a/ex/BeerDB.pm +++ /dev/null @@ -1,66 +0,0 @@ -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 => $ENV{BEERDB_DATASOURCE} || 't/beerdb.db'; - - -BEGIN { - my $dbi_driver = DBI_DRIVER; - if ($dbi_driver =~ /^SQLite/) { - die sprintf "SQLite datasource '%s' not found, correct the path or " - . "recreate the database by running Makefile.PL", DATASOURCE - unless -e DATASOURCE; - eval "require DBD::SQLite"; - if ($@) { - eval "require DBD::SQLite2" and $dbi_driver = 'SQLite2'; - } - } - BeerDB->setup(join ':', "dbi", $dbi_driver, DATASOURCE); -} - -# 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= ('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); - -# Handpumps should not show up. -BeerDB->config->display_tables([qw[beer brewery pub style]]); -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 url/], - integer => [qw/style brewery score/], - 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", - "a pub has beers on handpumps"); - -# For testing classmetadata -sub BeerDB::Beer::classdata :Exported {}; -sub BeerDB::Beer::list_columns { return qw/score name price style brewery url/}; - -1; diff --git a/ex/BeerDB/Base.pm b/ex/BeerDB/Base.pm deleted file mode 100644 index 75ed338..0000000 --- a/ex/BeerDB/Base.pm +++ /dev/null @@ -1,7 +0,0 @@ -package BeerDB::Base; -use strict; -use warnings; - -sub floob {} - -1; diff --git a/ex/BeerDB/Beer.pm b/ex/BeerDB/Beer.pm deleted file mode 100644 index d7de346..0000000 --- a/ex/BeerDB/Beer.pm +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index 0c6a0df..0000000 --- a/ex/beerdb.sql +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index cb72574..0000000 --- a/ex/fancy_example/BeerDB.pm +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index aaafce1..0000000 --- a/ex/fancy_example/BeerDB/Base.pm +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index d7de346..0000000 --- a/ex/fancy_example/BeerDB/Beer.pm +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index ad99483..0000000 --- a/ex/fancy_example/BeerDB/Brewery.pm +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index db798fd..0000000 --- a/ex/fancy_example/BeerDB/Drinker.pm +++ /dev/null @@ -1,48 +0,0 @@ -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 deleted file mode 100644 index 6089c94..0000000 --- a/ex/fancy_example/beerdb.sql +++ /dev/null @@ -1,67 +0,0 @@ -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 deleted file mode 100644 index 7053240..0000000 --- a/ex/fancy_example/templates/custom/addnew +++ /dev/null @@ -1,24 +0,0 @@ -[%# - -=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 deleted file mode 100644 index 6baf703..0000000 --- a/ex/fancy_example/templates/custom/display_inputs +++ /dev/null @@ -1,114 +0,0 @@ -[%# - -=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 deleted file mode 100644 index 9985bfb..0000000 --- a/ex/fancy_example/templates/custom/display_search_inputs +++ /dev/null @@ -1,63 +0,0 @@ -[%# - -=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 deleted file mode 100644 index dae8c42..0000000 --- a/ex/fancy_example/templates/custom/edit +++ /dev/null @@ -1,72 +0,0 @@ -[%# - -=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 deleted file mode 100644 index c21fff7..0000000 --- a/ex/fancy_example/templates/custom/header +++ /dev/null @@ -1,16 +0,0 @@ - - - - - [% - 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 deleted file mode 100644 index b13b4f1..0000000 --- a/ex/fancy_example/templates/custom/maypole.css +++ /dev/null @@ -1,382 +0,0 @@ -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 deleted file mode 100644 index e15fb6a..0000000 --- a/ex/fancy_example/templates/custom/metadata +++ /dev/null @@ -1,5 +0,0 @@ -

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 deleted file mode 100644 index 5d540fb..0000000 --- a/ex/fancy_example/templates/custom/search_form +++ /dev/null @@ -1,9 +0,0 @@ - diff --git a/examples/BeerDB.pm b/examples/BeerDB.pm new file mode 100644 index 0000000..e0b2894 --- /dev/null +++ b/examples/BeerDB.pm @@ -0,0 +1,66 @@ +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 => $ENV{BEERDB_DATASOURCE} || 't/beerdb.db'; + + +BEGIN { + my $dbi_driver = DBI_DRIVER; + if ($dbi_driver =~ /^SQLite/) { + die sprintf "SQLite datasource '%s' not found, correct the path or " + . "recreate the database by running Makefile.PL", DATASOURCE + unless -e DATASOURCE; + eval "require DBD::SQLite"; + if ($@) { + eval "require DBD::SQLite2" and $dbi_driver = 'SQLite2'; + } + } + BeerDB->setup(join ':', "dbi", $dbi_driver, DATASOURCE); +} + +# 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= ('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); + +# Handpumps should not show up. +BeerDB->config->display_tables([qw[beer brewery pub style]]); +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 url/], + integer => [qw/style brewery score/], + 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", + "a pub has beers on handpumps"); + +# For testing classmetadata +sub BeerDB::Beer::classdata :Exported {}; +sub BeerDB::Beer::list_columns { return qw/score name price style brewery url/}; + +1; diff --git a/examples/BeerDB/Base.pm b/examples/BeerDB/Base.pm new file mode 100644 index 0000000..75ed338 --- /dev/null +++ b/examples/BeerDB/Base.pm @@ -0,0 +1,7 @@ +package BeerDB::Base; +use strict; +use warnings; + +sub floob {} + +1; diff --git a/examples/BeerDB/Beer.pm b/examples/BeerDB/Beer.pm new file mode 100644 index 0000000..d7de346 --- /dev/null +++ b/examples/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/examples/beerdb.sql b/examples/beerdb.sql new file mode 100644 index 0000000..0c6a0df --- /dev/null +++ b/examples/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/examples/fancy_example/BeerDB.pm b/examples/fancy_example/BeerDB.pm new file mode 100644 index 0000000..427aee7 --- /dev/null +++ b/examples/fancy_example/BeerDB.pm @@ -0,0 +1,89 @@ +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 => $ENV{BEERDB_DATASOURCE} || 't/beerdb.db'; + +BeerDB->config->model('BeerDB::Base'); + +BEGIN { + my $dbi_driver = DBI_DRIVER; + if ($dbi_driver =~ /^SQLite/) { + unless -e (DATASOURCE) { + die sprintf("SQLite datasource '%s' not found, correct the path or recreate the database by running Makefile.PL", DATASOURCE), "\n"; + } + eval "require DBD::SQLite"; + if ($@) { + eval "require DBD::SQLite2" and $dbi_driver = 'SQLite2'; + } + } + BeerDB->setup(join ':', "dbi", $dbi_driver, DATASOURCE); +} + +# 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= ('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); + +# 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/]; +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/examples/fancy_example/BeerDB/Base.pm b/examples/fancy_example/BeerDB/Base.pm new file mode 100644 index 0000000..aaafce1 --- /dev/null +++ b/examples/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/examples/fancy_example/BeerDB/Beer.pm b/examples/fancy_example/BeerDB/Beer.pm new file mode 100644 index 0000000..d7de346 --- /dev/null +++ b/examples/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/examples/fancy_example/BeerDB/Brewery.pm b/examples/fancy_example/BeerDB/Brewery.pm new file mode 100644 index 0000000..ad99483 --- /dev/null +++ b/examples/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/examples/fancy_example/BeerDB/Drinker.pm b/examples/fancy_example/BeerDB/Drinker.pm new file mode 100644 index 0000000..db798fd --- /dev/null +++ b/examples/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/examples/fancy_example/beerdb.sql b/examples/fancy_example/beerdb.sql new file mode 100644 index 0000000..bd1b6d6 --- /dev/null +++ b/examples/fancy_example/beerdb.sql @@ -0,0 +1,67 @@ +CREATE TABLE style ( + id integer UNSIGNED NOT NULL primary key auto_increment, + name varchar(60), + notes text +); + +CREATE TABLE pub ( + id integer UNSIGNED NOT NULLprimary key auto_increment, + name varchar(60), + url varchar(120), + notes text +); + +CREATE TABLE handpump ( + id integer UNSIGNED NOT NULL primary key auto_increment, + beer integer, + pub integer +); + +CREATE TABLE beer ( + id integer UNSIGNED NOT NULL 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 UNSIGNED NOT NULL 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/examples/fancy_example/templates/custom/addnew b/examples/fancy_example/templates/custom/addnew new file mode 100644 index 0000000..7053240 --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/display_inputs b/examples/fancy_example/templates/custom/display_inputs new file mode 100644 index 0000000..6baf703 --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/display_search_inputs b/examples/fancy_example/templates/custom/display_search_inputs new file mode 100644 index 0000000..9985bfb --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/edit b/examples/fancy_example/templates/custom/edit new file mode 100644 index 0000000..dae8c42 --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/header b/examples/fancy_example/templates/custom/header new file mode 100644 index 0000000..c21fff7 --- /dev/null +++ b/examples/fancy_example/templates/custom/header @@ -0,0 +1,16 @@ + + + + + [% + title || config.application_name || + "A poorly configured Maypole application" + %] + + + + + + +
diff --git a/examples/fancy_example/templates/custom/maypole.css b/examples/fancy_example/templates/custom/maypole.css new file mode 100644 index 0000000..b13b4f1 --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/metadata b/examples/fancy_example/templates/custom/metadata new file mode 100644 index 0000000..e15fb6a --- /dev/null +++ b/examples/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/examples/fancy_example/templates/custom/search_form b/examples/fancy_example/templates/custom/search_form new file mode 100644 index 0000000..5d540fb --- /dev/null +++ b/examples/fancy_example/templates/custom/search_form @@ -0,0 +1,9 @@ + diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 4d32dc4..0dba642 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,6 +1,6 @@ package Apache::MVC; -our $VERSION = '2.11'; +our $VERSION = '2.121'; use strict; use warnings; @@ -93,14 +93,37 @@ functionality. See L for these: sub get_request { my ($self, $r) = @_; + my $request_options = $self->config->request_options || {}; my $ar; if ($MODPERL2) { - $ar = eval {require Apache2::Request} ? Apache2::Request->new($r) : $r; - } - else { $ar = Apache::Request->instance($r); } + $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r; + } else { + if (keys %$request_options) { + $ar = Apache::Request->new($r,%{$request_options}); + } else { + $ar = Apache::Request->instance($r); + } + } $self->ar($ar); } +=item warn + +=cut + +sub warn { + my ($self,@args) = @_; + my ($package, $line) = (caller)[0,2]; + my $ar = $self->parent ? $self->parent->{ar} : $self->{ar}; + if ( $args[0] and ref $self ) { + $ar->warn("[$package line $line] ", @args) ; + } else { + print "warn called by ", caller, " with ", @_, "\n"; + } + return; +} + + =item parse_location =cut @@ -110,19 +133,30 @@ sub parse_location { # 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{$_}); } + + $self->preprocess_location(); + my $path = $self->ar->uri; - my $loc = $self->ar->location; + my $base = URI->new($self->config->uri_base); + my $loc = $base->path; + { no warnings 'uninitialized'; $path .= '/' if $path eq $loc; - $path =~ s/^($loc)?\///; + if ($loc =~ /\/$/) { + $path =~ s/^($loc)?//; + } else { + $path =~ s/^($loc)?\///; + } } + $self->path($path); $self->parse_path; $self->parse_args; @@ -140,13 +174,30 @@ sub parse_args { =item redirect_request +Sets output headers to redirect based on the arguments provided + +Accepts either a single argument of the full url to redirect to, or a hash of +named parameters : + +$r->redirect_request('http://www.example.com/path'); + +or + +$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..'); + +The named parameters are protocol, domain, path, status and url + +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. + =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? + my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;'; if ($_[1]) { my %args = @_; if ($args{url}) { @@ -166,9 +217,11 @@ sub redirect_request { $r->ar->status($status); $r->ar->headers_out->set('Location' => $redirect_url); + $r->output('redirecting...

redirecting..

') unless ($r->output); return OK; } + =item get_protocol =cut diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm index b8a0a48..6448480 100644 --- a/lib/CGI/Maypole.pm +++ b/lib/CGI/Maypole.pm @@ -7,7 +7,7 @@ use CGI::Simple; use Maypole::Headers; use Maypole::Constants; -our $VERSION = '2.11'; +our $VERSION = '2.13'; __PACKAGE__->mk_accessors( qw/cgi/ ); @@ -54,10 +54,19 @@ Call this from your CGI script to start the Maypole application. =cut -sub run -{ - my $self = shift; - return $self->handler; +sub run { + my $self = shift; + my $status = $self->handler; + if ($status != OK) { + print <Maypole application error +

Maypole application error

+EOT + } + return $status; } =head1 Implementation @@ -71,9 +80,11 @@ functionality. See L for these: =cut -sub get_request -{ - shift->cgi( CGI::Simple->new ); +sub get_request { + my $self = shift; + my $request_options = $self->config->request_options || {}; + $CGI::Simple::POST_MAX = $request_options->{POST_MAX} if ($request_options->{POST_MAX}); + $self->cgi( CGI::Simple->new ); } =item parse_location @@ -92,12 +103,18 @@ sub parse_location $r->headers_in->set($field_name => $cgi->http($http_header)); } + $r->preprocess_location(); + 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)?\///; + if ($loc =~ /\/$/) { + $path =~ s/^($loc)?//; + } else { + $path =~ s/^($loc)?\///; + } } $r->path($path); @@ -105,6 +122,17 @@ sub parse_location $r->parse_args; } +=item warn + +=cut + +sub warn { + my ($self,@args) = @_; + my ($package, $line) = (caller)[0,2]; + warn "[$package line $line] ", @args ; + return; +} + =item parse_args =cut diff --git a/lib/CGI/Untaint/Maypole.pm b/lib/CGI/Untaint/Maypole.pm index 38321ef..d5eab49 100644 --- a/lib/CGI/Untaint/Maypole.pm +++ b/lib/CGI/Untaint/Maypole.pm @@ -6,7 +6,7 @@ our $VERSION = '0.01'; use base 'CGI::Untaint'; use Carp; -=head1 NAME +=head1 NAME CGI::Untaint::Maypole - Use instead of CGI::Untaint. Based on CGI::Untaint diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 211bd05..1a86f53 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -12,7 +12,7 @@ use URI::QueryParam; use NEXT; use File::MMagic::XS qw(:compat); -our $VERSION = '2.111'; +our $VERSION = '2.13'; our $mmagic = File::MMagic::XS->new(); # proposed privacy conventions: @@ -183,10 +183,11 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path args action template error document_encoding content_type table - headers_in headers_out stash status parent) + headers_in headers_out stash status parent build_form_elements + user session) ); -__PACKAGE__->config( Maypole::Config->new() ); +__PACKAGE__->config( Maypole::Config->new({additional => { }, request_options => { }, view_options => { },}) ); __PACKAGE__->init_done(0); @@ -299,14 +300,10 @@ sub setup_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; - } + $config->model->add_model_superclass($config); # Load custom model code, if it exists - nb this must happen after the - # unshift, to allow code attributes to work, but before adopt(), + # adding the model superclass, 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()); @@ -384,13 +381,12 @@ sub new config => $class->config, }, $class; - $self->stash({}); - $self->params({}); - $self->query({}); - $self->template_args({}); - $self->args([]); - $self->objects([]); - + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); return $self; } @@ -439,8 +435,12 @@ sub handler : method { 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 $session = $self->get_session; + $self->session($self->{session} || $session); + my $user = $self->get_user; + $self->user($self->{user} || $user); + my $status = $self->handler_guts; return $status unless $status == OK; # TODO: require send_output to return a status code @@ -463,7 +463,7 @@ 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 +component sub-request, only what is included in the url passed as an argument to the method =cut @@ -471,16 +471,17 @@ to the method 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; + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + + $self->session($self->get_session); + $self->user($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 ); @@ -540,71 +541,69 @@ sub __call_hook 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; +sub handler_guts { + my ($self) = @_; + $self->build_form_elements(1) unless (defined ($self->config->build_form_elements) && $self->config->build_form_elements == 0); + $self->__load_request_model; - my $applicable = $self->is_model_applicable == OK; + my $applicable = $self->is_model_applicable == OK; - my $status; + my $status; - # 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 $self->debug ? - $self->view_object->error($self, $error) : ERROR; - } - } - if ( $self->debug and $status != OK and $status != DECLINED ) - { - $self->view_object->error( $self, - "Got unexpected status $status from calling authentication" ); + # handle authentication + eval { $status = $self->call_authenticate }; + if ( my $error = $@ ) { + $status = $self->call_exception($error, "authentication"); + if ( $status != OK ) { + $self->warn("caught authenticate error: $error"); + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } + } + 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; + return $status unless $status == OK; - # We run additional_data for every request - $self->additional_data; + # We run additional_data for every request + $self->additional_data; - if ($applicable) { + # process request with model if applicable and template not set. + if ($applicable) { + unless ($self->{template}) { 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 ( my $error = $@ ) { + $status = $self->call_exception($error, "model"); + if ( $status != OK ) { + $self->warn("caught model error: $error"); + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; + } + } } + } else { + $self->__setup_plain_template; + } - # 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; - + # less frequent path - perhaps output has been set to an error message + if ($self->output) { $self->{content_type} ||= $self->__get_mime_type(); $self->{document_encoding} ||= "utf-8"; + return OK; + } + + # 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; + return $processed_view_ok; } my %filetypes = ( @@ -617,7 +616,7 @@ my %filetypes = ( sub __get_mime_type { my $self = shift; my $type = 'text/html'; - if ($self->path =~ m/.*\.(\w{3,4})$/) { + if ($self->path =~ m/.*\.(\w{2,4})$/) { $type = $filetypes{$1}; } else { my $output = $self->output; @@ -636,8 +635,8 @@ sub __load_request_model if ( eval {$mclass->isa('Maypole::Model::Base')} ) { $self->model_class( $mclass ); } - elsif ($self->debug) { - warn "***Warning: No $mclass class appropriate for model. @_"; + elsif ($self->debug > 1) { + $self->warn("***Warning: No $mclass class appropriate for model. @_"); } } @@ -650,13 +649,16 @@ sub __setup_plain_template my ($self) = @_; # It's just a plain template + $self->build_form_elements(0); $self->model_class(undef); - - my $path = $self->path; - $path =~ s{/$}{}; # De-absolutify - $self->path($path); - - $self->template($self->path); + + unless ($self->template) { + # FIXME: this is likely to be redundant and is definately causing problems. + 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), @@ -681,6 +683,32 @@ sub __call_process_view { return $status; } +=item warn + +$r->warn('its all gone pete tong'); + +Warn must be implemented by the backend, i.e. Apache::MVC +and warn to stderr or appropriate logfile. + +You can also over-ride this in your Maypole driver, should you +want to use something like Log::Log4perl instead. + +=cut + +sub warn { } + +=item build_form_elements + +$r->build_form_elements(0); + +Specify (in an action) whether to build HTML form elements and populate +the cgi element of classmetadata in the view. + +You can set this globally using the accessor of the same name in Maypole::Config, +this method allows you to over-ride that setting per action. + +=cut + =item get_request You should only need to define this method if you are writing a new @@ -798,9 +826,9 @@ sub is_model_applicable { if (not $ok) { - warn "We don't have that table ($table).\n" + $self->warn ("We don't have that table ($table).\n" . "Available tables are: " - . join( ",", keys %$ok_tables ) + . join( ",", keys %$ok_tables )) if $self->debug and not $ok_tables->{$table}; return DECLINED; @@ -810,7 +838,7 @@ sub is_model_applicable { my $action = $self->action; return OK if $self->model_class->is_public($action); - warn "The action '$action' is not applicable to the table '$table'" + $self->warn("The action '$action' is not applicable to the table '$table'") if $self->debug; return DECLINED; @@ -959,8 +987,7 @@ properties. Calls C before parsing path and setting properties. =cut -sub parse_path -{ +sub parse_path { my ($self) = @_; # Previous versions unconditionally set table, action and args to whatever @@ -969,10 +996,13 @@ sub parse_path # 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; + # use frontpage template for frontpage + unless ($self->path && $self->path ne '/') { + $self->path('frontpage'); + } + my @pi = grep {length} split '/', $self->path; $self->table || $self->table(shift @pi); $self->action || $self->action( shift @pi or 'index' ); @@ -982,19 +1012,32 @@ sub parse_path =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. +want to rewrite urls or extract data from them before it is parsed, +the preprocess_path/location methods allow you to munge paths and urls +before maypole maps them to actions, classes, etc. 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 +then leave those values in place or populate them based on the current +value of the path attribute if they are not present. =cut sub preprocess_path { }; +=item preprocess_location + +This method is called at the start of parse_location, after the headers in, and allows you +to rewrite the url used by maypole, or dynamically set configuration +like the base_uri based on the hostname or path. + +=cut + +sub preprocess_location { }; + =item make_path( %args or \%args or @args ) This is the counterpart to C. It generates a path to use @@ -1018,6 +1061,7 @@ string. =cut + sub make_path { my $r = shift; @@ -1267,9 +1311,9 @@ sub param $self->params->{$key} = $new_val; } - return ref $val ? @$val : ($val) if wantarray; + return (ref $val eq 'ARRAY') ? @$val : ($val) if wantarray; - return ref $val ? $val->[0] : $val; + return (ref $val eq 'ARRAY') ? $val->[0] : $val; } @@ -1316,13 +1360,13 @@ sub redirect_request { die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; } -=item redirect_internal_request - -=cut - -sub redirect_internal_request { - -} +# =item redirect_internal_request +# +# =cut +# +# sub redirect_internal_request { +# +# } =item make_random_id diff --git a/lib/Maypole/CLI.pm b/lib/Maypole/CLI.pm index de8fab6..39abf15 100644 --- a/lib/Maypole/CLI.pm +++ b/lib/Maypole/CLI.pm @@ -26,9 +26,19 @@ sub import { sub get_template_root { $ENV{MAYPOLE_TEMPLATES} || "." } +sub warn { + my ($self,@args) = @_; + my ($package, $line) = (caller)[0,2]; + warn "[$package line $line] ", @args ; + return; +} + sub parse_location { my $self = shift; my $url = URI->new( shift @ARGV ); + + $self->preprocess_location(); + (my $uri_base = $self->config->uri_base) =~ s:/$::; my $root = URI->new( $uri_base )->path; $self->{path} = $url->path; @@ -137,6 +147,8 @@ functionality. See L for these: =item send_output +=item warn + =back =cut diff --git a/lib/Maypole/Config.pm b/lib/Maypole/Config.pm index 040a4c8..3e80811 100644 --- a/lib/Maypole/Config.pm +++ b/lib/Maypole/Config.pm @@ -5,14 +5,19 @@ use attributes (); use strict; use warnings; -our $VERSION = "1." . sprintf "%04d", q$Rev: 334 $ =~ /: (\d+)/; +our $VERSION = 2.121; # Public accessors. __PACKAGE__->mk_accessors( - qw( view view_options uri_base template_root template_extension model - loader display_tables ok_tables rows_per_page dsn user pass opts - application_name) -); + qw( + view view_options template_root template_extension build_form_elements + uri_base rows_per_page application_name + model loader display_tables ok_tables + dsn user pass opts + additional + request_options + ) + ); # Should only be modified by model. __PACKAGE__->mk_ro_accessors(qw( classes tables)); @@ -65,6 +70,15 @@ makes URLs. The name of the view class for your Maypole Application. Defaults to "Maypole::View::TT". +=head3 build_form_elements + +Globally specify whether to build form elements; populating the cgi metadata with +autogenerated HTML::Element widgets for the class/object. + +Can be over-ridden per action using the method of the same name for the request. + +If not set, then Maypole will assume it is true. + =head3 view_options A hash of configuration options for the view class. Consult the documentation @@ -115,8 +129,21 @@ Other options to the DBI connect call. Username to log into the database with. +=head3 build_form_elements + +Flag specifying whether to build metadata for form elements in factory templates + +=head3 request_options + +Hashref of options passed when creating cgi or apache request + =head2 Adding additional configuration data +You can use the 'additional' attribute for stashing additional info, especially from additional_data method, +i.e. $r->config->additional({foo=>bar}); + +Or.. + If your modules need to store additional configuration data for their own use or to make available to templates, add a line like this to your module: diff --git a/lib/Maypole/HTTPD.pm b/lib/Maypole/HTTPD.pm new file mode 100644 index 0000000..221e303 --- /dev/null +++ b/lib/Maypole/HTTPD.pm @@ -0,0 +1,120 @@ +package Maypole::HTTPD; +use strict; +use warnings; + +use base 'HTTP::Server::Simple::CGI'; +use HTTP::Server::Simple::Static; +use Maypole::Constants; +use UNIVERSAL::require; + +# signal to Maypole::Application +BEGIN { $ENV{MAYPOLE_HTTPD} = 1 } + +our $VERSION = '0.2'; + +=head1 NAME + +Maypole::HTTPD - Stand alone HTTPD for running Maypole Applications + +=head1 SYNOPSIS + + use Maypole::HTTPD; + my $httpd=Maypole::HTTPD->new(module=>"BeerDB"); + $httpd->run(); + +=head1 DESCRIPTION + +This is a stand-alone HTTPD for running your Maypole Applications. + +=cut + +=head2 new + +The constructor. Takes a hash of arguments. Currently supported: + port - TCP port to listen to + module - Maypole application Module name. + +=cut + +sub new +{ + my ($class, %args) = @_; + my $self = $class->SUPER::new($args{port}); + $self->module($args{module}); + #eval "use $self->{module}"; + #die $@ if $@; + $self->module->require or die "Couldn't load driver: $@"; + $self->module->config->uri_base("http://localhost:".$self->port."/"); + return $self; +} + +=head2 module + +Accessor for application module. + +=cut + +sub module { + my $self = shift; + $self->{'module'} = shift if (@_); + return ( $self->{'module'} ); +} + +=head2 handle_request + +Handles the actual request processing. Should not be called directly. + +=cut + +sub handle_request +{ + my ($self,$cgi) = @_; + + my $rv; + my $path = $cgi->url( -absolute => 1, -path_info => 1 ); + + if ($path =~ m|^/static|) + { + $rv=DECLINED; + } + else + { + $rv = $self->module->run; + } + + if ($rv == OK) { + print "HTTP/1.1 200 OK\n"; + $self->module->output_now; + return; + } + elsif ($rv == DECLINED) + { + return $self->serve_static($cgi,"./"); + } + else + { + print "HTTP/1.1 404 Not Found\n\nPage not found"; + } +} + +1; + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Marcus Ramberg, Emarcus@thefeed.no +Based on Simon Cozens' original implementation. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Marcus Ramberg + + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Maypole/HTTPD/Frontend.pm b/lib/Maypole/HTTPD/Frontend.pm new file mode 100644 index 0000000..bea8aa6 --- /dev/null +++ b/lib/Maypole/HTTPD/Frontend.pm @@ -0,0 +1,50 @@ +package Maypole::HTTPD::Frontend; +use strict; +use warnings; + +use CGI::Maypole 2.11; # 2.11 has collect_output() + +use base 'CGI::Maypole'; + +sub get_request { shift->cgi(CGI->new) } + +{ + my $output; + sub send_output { $output = shift->collect_output } + sub output_now { print $output; undef $output } +} + +1; + +=head1 NAME + +Maypole::HTTPD::Frontend - Maypole driver class for Maypole::HTTPD + +=head1 DESCRIPTION + +This is a simple CGI based Maypole driver for L. It's used +automatically as the frontend by L. + +It overrides the following functions in L: + +=over 4 + +=item get_request + +Instantiates a L object representing the request. + +=item send_output + +Stores generated output in a buffer. + +=back + +=head2 output_now + +Actually output what's been buffered by send_output. Used by L + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Maypole/Manual.pod b/lib/Maypole/Manual.pod index d556ae9..d2f4ed6 100644 --- a/lib/Maypole/Manual.pod +++ b/lib/Maypole/Manual.pod @@ -107,7 +107,7 @@ Orkut. It shows, specifically, the database structure and the variety of customized techniques that make such a system work. -=item L - Case Study: iBuySpy * +=item L - Case Study: iBuySpy * This is an example of the C sample portal application ported to Maypole. L is a fictional diff --git a/lib/Maypole/Manual/About.pod b/lib/Maypole/Manual/About.pod index 6f48663..e0cdf3b 100644 --- a/lib/Maypole/Manual/About.pod +++ b/lib/Maypole/Manual/About.pod @@ -188,7 +188,7 @@ you need to write for a simple database front-end: "a pub has beers on handpumps"); 1; -There's a version of this program in the F directory in the Maypole +There's a version of this program in the F directory in the Maypole files that you downloaded in the F<~root/.cpan/> build area. This defines the C application. To set it up as a mod_perl handler, just tell the Apache configuration diff --git a/lib/Maypole/Manual/Flox.pod b/lib/Maypole/Manual/Flox.pod index ed3309c..8f93bf9 100644 --- a/lib/Maypole/Manual/Flox.pod +++ b/lib/Maypole/Manual/Flox.pod @@ -20,7 +20,7 @@ university student population. Flox is still in, uh, flux, but it does the essentials. We're going to see how it was put together, and how the techniques shown in the -L can help to +L can help to create a sophisticated web application. Of course, I didn't have this manual available at the time, so it took a bit longer than it should have done... @@ -152,7 +152,7 @@ Very simple, as these things are meant to be. Now let's build on it. The concept of a current user is absolutely critical in a site like Flox; it represents "me", the viewer of the page, as the site explores the connections in my world. We've described the authentication hacks -briefly in the L, +briefly in the L, but now it's time to go into a little more detail about how user handling is done. @@ -195,7 +195,7 @@ The next stage is viewing the user's photo. Assuming we've got the photo stored in the database already (which is a reasonable assumption for the moment since we don't have a way to upload a photo quite yet) then we can use a variation of the "Displaying pictures" hack from the -L: +L: sub view_picture :Exported { my ($self, $r) = @_; @@ -328,7 +328,7 @@ and the template proceeds as normal: Now we use the "Catching errors in a form" recipe from the -L and +L and write our form template:
@@ -505,5 +505,5 @@ L. L, Next L, -Previous L +Previous L diff --git a/lib/Maypole/Manual/Inheritance.pod b/lib/Maypole/Manual/Inheritance.pod index bff339d..950283d 100644 --- a/lib/Maypole/Manual/Inheritance.pod +++ b/lib/Maypole/Manual/Inheritance.pod @@ -33,8 +33,8 @@ application. =head1 Structure of a standard Maypole application A minimal Maypole application (such as the Beer database example from the -L synopsis) consists of a custom driver class (BeerDB.pm), a set of -auto-generated model classes, and a view class: +L synopsis) consists of a custom driver (or controller) class (BeerDB.pm), +a set of auto-generated model classes, and a view class: THE DRIVER @@ -76,6 +76,11 @@ auto-generated model classes, and a view class: pub(); BeerDB::Style beer(); beers(); +=head2 Ouch, that's a lot of inheritence! + +Yes, that's a lot of inheritence, at some point in the future - probably Maypole 3.x we +will move to Class::C3 + =head2 What about Maypole::Application - loading plugins The main job of L is to insert the plugins into the @@ -107,7 +112,7 @@ L identifies the appropriate L subclass and inserts it into each of these table classes' C<@ISA> ( C<< Class::DBI:: >> in the diagrams).. -Next, C B L onto the C<@ISA> +Next, C B L onto the C<@ISA> array of each of these classes. Finally, the relationships among these tables are set up. Either do this @@ -184,7 +189,7 @@ C, you would write: 1; From Maypole 2.11, this package will be loaded automatically during C, -and C is B onto it's C<@ISA>. +and C is B onto it's C<@ISA>. Configure relationships either in the individual C classes, or else all together in C itself i.e. not in the Maypole model. This @@ -234,8 +239,8 @@ The resulting model looks like this: the Maypole application, and need not know it exists at all. 2. Methods defined in the Maypole table classes, override methods defined in the -Offline table classes, because C was unshifted onto the -beginning of each Maypole table class's C<@ISA>. Perl's depth first, +Offline table classes, because C was pushed onto the +end of each Maypole table class's C<@ISA>. Perl's depth first, left-to-right method lookup from e.g. C starts in C, then C, C, C, and C, before moving on to diff --git a/lib/Maypole/Manual/Model.pod b/lib/Maypole/Manual/Model.pod index 112effc..98f54cd 100644 --- a/lib/Maypole/Manual/Model.pod +++ b/lib/Maypole/Manual/Model.pod @@ -56,6 +56,29 @@ The second reason why we want our table classes to inherit from C is because it provides a useful set of default actions. So what's an action, and why are they useful? + +=head2 Maypole::Model::CDBI::Plain + +The 'Plain' maypole Model : C allows you + + package Foo; + use 'Maypole::Application'; + + Foo->config->model("Maypole::Model::CDBI::Plain"); + Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]); + + # untaint columns and provide custom actions for each class + + Foo::SomeTable->untaint_columns(email => ['email'], printable => [qw/name description/]); + + Foo::Other::Table->untaint_columns ( ... ); + + sub Foo::SomeTable::SomeAction : Exported { + + . . . + + } + =head2 Extending a model class with actions Maypole operates primarily by turning URLs into method calls on a model @@ -118,3 +141,5 @@ chapter and our case studies. L, Next L, Previous L + +=cut diff --git a/lib/Maypole/Manual/StandardTemplates.pod b/lib/Maypole/Manual/StandardTemplates.pod index e3866c8..b36b404 100644 --- a/lib/Maypole/Manual/StandardTemplates.pod +++ b/lib/Maypole/Manual/StandardTemplates.pod @@ -61,10 +61,11 @@ This deletes a row, returning to the C page. This provides a paged list of the table suitable for browsing. -=item C +=item C This handles a search query and presents the search results back to the -F template. +F template. Previously this was called search, but obviously that +clashes with a lot of stuff, and that usage is now deprecated. =back @@ -211,13 +212,17 @@ This is usually integer, if you're using numeric IDs for your primary key. If not, you probably want C, but you probably know what you're doing anyway. -=head3 delete +=head3 do_delete -The delete method takes a number of arguments and deletes those rows from the +The do_delete method takes a number of arguments and deletes those rows from the database; it then loads up all rows and heads to the F template. You almost certainly want to override this to provide some kind of authentication. +Previously this was called delete, but obviously that clashes with a lot of stuff, +and that usage is now deprecated. + + =head3 list Listing, like viewing, is a matter of selecting objects for diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm index d5d325c..450b760 100644 --- a/lib/Maypole/Model/Base.pm +++ b/lib/Maypole/Model/Base.pm @@ -1,30 +1,36 @@ package Maypole::Model::Base; - use strict; + use Maypole::Constants; use attributes (); # don't know why this is a global - drb our %remember; -sub MODIFY_CODE_ATTRIBUTES -{ +sub MODIFY_CODE_ATTRIBUTES { shift; # class name not used my ($coderef, @attrs) = @_; - - $remember{$coderef} = \@attrs; - + $remember{$coderef} = [$coderef, \@attrs]; + # previous version took care to return an empty array, not sure why, # but shall cargo cult it until know better return; } -sub FETCH_CODE_ATTRIBUTES { @{ $remember{$_[1]} || [] } } +sub FETCH_CODE_ATTRIBUTES { @{ $remember{$_[1]}->[1] || [] } } + +sub CLONE { + # re-hash %remember + for my $key (keys %remember) { + my $value = delete $remember{$key}; + $key = $value->[0]; + $remember{$key} = $value; + } +} sub process { my ( $class, $r ) = @_; my $method = $r->action; - return if $r->{template}; # Authentication has set this, we're done. $r->{template} = $method; my $obj = $class->fetch_objects($r); @@ -215,6 +221,13 @@ sub is_public { } +=head2 add_model_superclass + +Adds model as superclass to model classes (if necessary) + +=cut + +sub add_model_superclass { return; } =head2 method_attrs @@ -249,3 +262,24 @@ sub related { 1; +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +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 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index e15745b..b3223c4 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,8 +1,6 @@ package Maypole::Model::CDBI; use strict; -use Data::Dumper; - =head1 NAME Maypole::Model::CDBI - Model class based on Class::DBI @@ -25,17 +23,13 @@ will instead use Class::DBI classes provided. =cut -use base qw(Maypole::Model::Base Class::DBI); -#use Class::DBI::Plugin::Type; +use base qw(Maypole::Model::CDBI::Base); +use Data::Dumper; use Class::DBI::Loader; -use Class::DBI::AbstractSearch; -use Class::DBI::Plugin::RetrieveAll; -use Class::DBI::Pager; -use Lingua::EN::Inflect::Number qw(to_PL); use attributes (); use Maypole::Model::CDBI::AsForm; -use Maypole::Model::CDBI::FromCGI; +use Maypole::Model::CDBI::FromCGI; use CGI::Untaint::Maypole; =head2 Untainter @@ -44,21 +38,21 @@ Set the class you use to untaint and validate form data Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint =cut -sub Untainter { 'CGI::Untaint::Maypole' }; -# or if you like bugs +sub Untainter { 'CGI::Untaint::Maypole' }; -#use Class::DBI::FromCGI; -#use CGI::Untaint; -#sub Untainter { 'CGI::Untaint' }; +=head2 add_model_superclass +Adds model as superclass to model classes (if necessary) -__PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/); +Inherited from Maypole::Model::CDBI::Base =head1 Action Methods Action methods are methods that are accessed through web (or other public) interface. +Inherited from L + =head2 do_edit If there is an object in C<$r-Eobjects>, then it should be edited @@ -67,339 +61,27 @@ be created with those parameters, and put back into C<$r-Eobjects>. The template should be changed to C, or C if there were any errors. A hash of errors will be passed to the template. -=cut - -sub do_edit : Exported { - my ($self, $r, $obj) = @_; - - my $config = $r->config; - my $table = $r->table; - - # handle cancel button hit - if ( $r->{params}->{cancel} ) { - $r->template("list"); - $r->objects( [$self->retrieve_all] ); - return; - } - - my $required_cols = $config->{$table}{required_cols} || $self->required_columns; - my $ignored_cols = $config->{$table}{ignore_cols} || []; - - ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); - - # handle errors, if none, proceed to view the newly created/updated object - my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; - - if (%errors) { - # Set it up as it was: - $r->template_args->{cgi_params} = $r->params; - - # replace user unfriendly error messages with something nicer - - foreach (@{$config->{$table}->{required_cols}}) { - next unless ($errors{$_}); - my $key = $_; - s/_/ /g; - $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value'; - $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value'; - delete $errors{$key}; - } - - foreach (keys %errors) { - my $key = $_; - s/_/ /g; - $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field'; - $r->template_args->{errors}{$key} = 'Please provide a valid value for this field'; - } - - undef $obj if $creating; - - die "do_update failed with error : $fatal" if ($fatal); - $r->template("edit"); - } else { - $r->template("view"); - } - - - - $r->objects( $obj ? [$obj] : []); -} - -# split out from do_edit to be reported by Mp::P::Trace -sub _do_update_or_create { - my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; - - my $fatal; - my $creating = 0; - - my $h = $self->Untainter->new( %{$r->params} ); - - # update or create - if ($obj) { - # We have something to edit - eval { $obj->update_from_cgi( $h => { - required => $required_cols, - ignore => $ignored_cols, - }); - $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit' - }; - $fatal = $@; - } else { - eval { - $obj = $self->create_from_cgi( $h => { - required => $required_cols, - ignore => $ignored_cols, - } ); - }; - $fatal = $@; - $creating++; - } - return $obj, $fatal, $creating; -} - -=head2 delete - -Deprecated method that calls do_delete or a given classes delete method, please -use do_delete instead - =head2 do_delete -Unsuprisingly, this command causes a database record to be forever lost. - -This method replaces the, now deprecated, delete method provided in prior versions - -=cut - -sub delete : Exported { - my $self = shift; - my ($sub) = (caller(1))[3]; - # So subclasses can still send delete down ... - $sub =~ /^(.+)::([^:]+)$/; - if ($1 ne "Maypole::Model::Base" && $2 ne "delete") { - $self->SUPER::delete(@_); - } else { - warn "Maypole::Model::CDBI delete method is deprecated\n"; - $self->do_delete(@_); - } -} - -sub do_delete { - my ( $self, $r ) = @_; - # FIXME: handle fatal error with exception - $_->SUPER::delete for @{ $r->objects || [] }; -# $self->dbi_commit; - $r->objects( [ $self->retrieve_all ] ); - $r->{template} = "list"; - $self->list($r); -} - -=head2 search +Inherited from Maypole::Model::CDBI::Base. -Deprecated searching method - use do_search instead. +This action deletes records =head2 do_search -This action method searches for database records, it replaces -the, now deprecated, search method previously provided. +Inherited from Maypole::Model::CDBI::Base. -=cut - -sub search : Exported { - my $self = shift; - my ($sub) = (caller(1))[3]; - # So subclasses can still send search down ... - if ($sub =~ /^(.+)::([^:]+)$/) { - return ($1 ne "Maypole::Model::Base" && $2 ne "search") ? - $self->SUPER::search(@_) : $self->do_search(@_); - } else { - $self->SUPER::search(@_); - } -} - -sub do_search : Exported { - my ( $self, $r ) = @_; - my %fields = map { $_ => 1 } $self->columns; - my $oper = "like"; # For now - my %params = %{ $r->{params} }; - my %values = map { $_ => { $oper, $params{$_} } } - grep { defined $params{$_} && length ($params{$_}) && $fields{$_} } - keys %params; - - $r->template("list"); - if ( !%values ) { return $self->list($r) } - my $order = $self->order($r); - $self = $self->do_pager($r); - $r->objects( - [ - $self->search_where( - \%values, ( $order ? { order_by => $order } : () ) - ) - ] - ); - $r->{template_args}{search} = 1; -} +This action method searches for database records. =head2 list +Inherited from Maypole::Model::CDBI::Base. + The C method fills C<$r-Eobjects> with all of the objects in the class. The results are paged using a pager. -=cut - -sub list : Exported { - my ( $self, $r ) = @_; - my $order = $self->order($r); - $self = $self->do_pager($r); - if ($order) { - $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); - } - else { - $r->objects( [ $self->retrieve_all ] ); - } -} - -############################################################################### -# Helper methods - =head1 Helper Methods - -=head2 adopt - -This class method is passed the name of a model class that represensts a table -and allows the master model class to do any set-up required. - -=cut - -sub adopt { - my ( $self, $child ) = @_; - $child->autoupdate(1); - if ( my $col = $child->stringify_column ) { - $child->columns( Stringify => $col ); - } -} - - -=head2 related - -This method returns a list of has-many accessors. A brewery has many -beers, so C needs to return C. - -=cut - -sub related { - my ( $self, $r ) = @_; - return keys %{ $self->meta_info('has_many') || {} }; -} - - -=head2 related_class - -Given an accessor name as a method, this function returns the class this accessor returns. - -=cut - -sub related_class { - my ( $self, $r, $accessor ) = @_; - my $meta = $self->meta_info; - my @rels = keys %$meta; - my $related; - foreach (@rels) { - $related = $meta->{$_}{$accessor}; - last if $related; - } - return unless $related; - - my $mapping = $related->{args}->{mapping}; - if ( $mapping and @$mapping ) { - return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; - } - else { - return $related->{foreign_class}; - } - } - -=head2 related_meta - - $class->related_meta($col); - -Returns the hash ref of relationship meta info for a given column. - -=cut - -sub related_meta { - my ($self,$r, $accssr) = @_; - $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; - my $class_meta = $self->meta_info; - if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } - keys %$class_meta) - { return $class_meta->{$rel_type}->{$accssr} }; -} - - - -=head2 stringify_column - - Returns the name of the column to use when stringifying - and object. - -=cut - -sub stringify_column { - my $class = shift; - return ( - $class->columns("Stringify"), - ( grep { /^(name|title)$/i } $class->columns ), - ( grep { /(name|title)/i } $class->columns ), - ( grep { !/id$/i } $class->primary_columns ), - )[0]; -} - -=head2 do_pager - - Sets the pager template argument ($r->{template_args}{pager}) - to a Class::DBI::Pager object based on the rows_per_page - value set in the configuration of the application. - - This pager is used via the pager macro in TT Templates, and - is also accessible via Mason. - -=cut - -sub do_pager { - my ( $self, $r ) = @_; - if ( my $rows = $r->config->rows_per_page ) { - return $r->{template_args}{pager} = - $self->pager( $rows, $r->query->{page} ); - } - else { return $self } -} - - -=head2 order - - Returns the SQL order syntax based on the order parameter passed - to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'. - - $sql .= $self->order($r); - - If the order column is not a column of this table, - or an order argument is not passed, then the return value is undefined. - - Note: the returned value does not start with a space. - -=cut - -sub order { - my ( $self, $r ) = @_; - my %ok_columns = map { $_ => 1 } $self->columns; - my $q = $r->query; - my $order = $q->{order}; - return unless $order and $ok_columns{$order}; - $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc'; - return $order; -} - =head2 setup This method is inherited from Maypole::Model::Base and calls setup_database, @@ -459,320 +141,27 @@ sub class_of { return $r->config->loader->_table2class($table); # why not find_class ? } -=head2 fetch_objects -Returns 1 or more objects of the given class when provided with the request +=head1 SEE ALSO -=cut +L, L. -sub fetch_objects { - my ($class, $r)=@_; - my @pcs = $class->primary_columns; - if ( $#pcs ) { - my %pks; - @pks{@pcs}=(@{$r->{args}}); - return $class->retrieve( %pks ); - } - return $class->retrieve( $r->{args}->[0] ); -} +=head1 AUTHOR +Maypole is currently maintained by Aaron Trevena. +=head1 AUTHOR EMERITUS +Simon Cozens, C +Simon Flack maintained Maypole from 2.05 to 2.09 -=head2 _isa_class +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 -Private method to return the class a column -belongs to that was inherited by an is_a relationship. -This should probably be public but need to think of API +=head1 LICENSE -=cut - -sub _isa_class { - my ($class, $col) = @_; - $class->_croak( "Need a column for _isa_class." ) unless $col; - my $isaclass; - my $isa = $class->meta_info("is_a") || {}; - foreach ( keys %$isa ) { - $isaclass = $isa->{$_}->foreign_class; - return $isaclass if ($isaclass->find_column($col)); - } - return; # col not in a is_a class -} - - -# Thanks to dave baird -- form builder for these private functions -# sub _column_info { -sub _column_info { - my $self = shift; - my $dbh = $self->db_Main; - - my $meta; # The info we are after - my ($catalog, $schema) = (undef, undef); - # Dave is suspicious this (above undefs) could - # break things if driver useses this info - - my $original_metadata; - # '%' is a search pattern for columns - matches all columns - if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) { - $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr; - $self->COLUMN_INFO ($self->_hash_type_meta( $sth )); - } else { - $self->COLUMN_INFO ($self->_hash_typeless_meta( )); - } - - return $self->COLUMN_INFO; -} - -sub _hash_type_meta { - my ($self, $sth) = @_; - my $meta; - while ( my $row = $sth->fetchrow_hashref ) { - my $colname = $row->{COLUMN_NAME} || $row->{column_name}; - - # required / nullable - $meta->{$colname}{nullable} = $row->{NULLABLE}; - $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0; - - # default - if (defined $row->{COLUMN_DEF}) { - my $default = $row->{COLUMN_DEF}; - $default =~ s/['"]?(.*?)['"]?::.*$/$1/; - $meta->{$colname}{default} = $default; - }else { - $meta->{$colname}{default} = ''; - } - - # type - my $type = $row->{mysql_type_name} || $row->{type}; - unless ($type) { - $type = $row->{TYPE_NAME}; - if ($row->{COLUMN_SIZE}) { - $type .= "($row->{COLUMN_SIZE})"; - } - } - $type =~ s/['"]?(.*)['"]?::.*$/$1/; - # Bool if tinyint - if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) { - $type = 'BOOL'; - } - $meta->{$colname}{type} = $type; - - # order - $meta->{$colname}{position} = $row->{ORDINAL_POSITION} - } - return $meta; -} - -# typeless db e.g. sqlite -sub _hash_typeless_meta { - my ( $self ) = @_; - - $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' ) - unless $self->can( 'sql_fb_meta_dummy' ); - - my $sth = $self->sql_fb_meta_dummy; - - $sth->execute or die "Error executing column info: " . $sth->errstr;; - - # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes - my $cols = $sth->{NAME}; - my $types = $sth->{TYPE}; - # my $sizes = $sth->{PRECISION}; # empty - # my $nulls = $sth->{NULLABLE}; # empty - - # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to - $sth->finish; - - my $order = 0; - my $meta; - foreach my $col ( @$cols ) { - my $col_meta; - $col_meta->{nullable} = 1; - $col_meta->{required} = 0; - $col_meta->{default} = ''; - $col_meta->{position} = $order++; - # type_name is taken literally from the schema, but is not actually used by sqlite, - # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc. - my $type = shift( @$types ); - $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ; - $meta->{$col} = $col_meta; - } - return $meta; -} - -=head2 column_type - - my $type = $class->column_type('column_name'); - -This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.) -For now, it returns "BOOL" for tinyints. - -TODO :: TEST with enums +You may distribute this code under the same terms as Perl itself. =cut -sub column_type { - my $class = shift; - my $colname = shift or die "Need a column for column_type"; - $class->_column_info() unless (ref $class->COLUMN_INFO); - - if ($class->_isa_class($colname)) { - return $class->_isa_class($colname)->column_type($colname); - } - unless ( $class->find_column($colname) ) { - warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; - return undef; - } - return $class->COLUMN_INFO->{$colname}{type}; -} - -=head2 required_columns - - Accessor to get/set required columns for forms, validation, etc. - - Returns list of required columns. Accepts an array ref of column names. - - $class->required_columns([qw/foo bar baz/]); - - Allows you to specify the required columns for a class, over-riding any - assumptions and guesses made by Maypole. - - Use this instead of $config->{$table}{required_cols} - - Note : you need to setup the model class before calling this method. - -=cut - -sub required_columns { - my ($class, $columns) = @_; - $class->_column_info() unless ref $class->COLUMN_INFO; - my $column_info = $class->COLUMN_INFO; - - if ($columns) { - foreach my $colname ( @$columns ) { - if ($class->_isa_class($colname)) { - $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1 - unless ($class->_isa_class($colname)->column_required); - next; - } - unless ( $class->find_column($colname) ) { - warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; - next; - } - $column_info->{$colname}{required} = 1; - } - $class->COLUMN_INFO($column_info); - } - - return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ; -} - -=head2 column_required - - Returns true if a column is required - - my $required = $class->column_required($column_name); - - Columns can be required by the application but not the database, but not the other way around, - hence there is also a column_nullable method which will tell you if the column is nullable - within the database itself. - -=cut - -sub column_required { - my ($class, $colname) = @_; - $colname or $class->_croak( "Need a column for column_nullable" ); - $class->_column_info() unless ref $class->COLUMN_INFO; - if ($class->_isa_class($colname)) { - return $class->_isa_class($colname)->column_required($colname); - } - unless ( $class->find_column($colname) ) { - # handle non-existant columns - warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; - return undef; - } - return $class->COLUMN_INFO->{$colname}{required} || 0; -} - -=head2 column_nullable - - Returns true if a column can be NULL within the underlying database and false if not. - - my $nullable = $class->column_nullable($column_name); - - Any columns that are not nullable will automatically be specified as required, you can - also specify nullable columns as required within your application. - - It is recomended you use column_required rather than column_nullable within your - application, this method is more useful if extending the model or handling your own - validation. - -=cut - -sub column_nullable { - my $class = shift; - my $colname = shift or $class->_croak( "Need a column for column_nullable" ); - - $class->_column_info() unless ref $class->COLUMN_INFO; - if ($class->_isa_class($colname)) { - return $class->_isa_class($colname)->column_nullable($colname); - } - unless ( $class->find_column($colname) ) { - # handle non-existant columns - warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; - return undef; - } - return $class->COLUMN_INFO->{$colname}{nullable} || 0; -} - -=head2 column_default - -Returns default value for column or the empty string. -Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times -have '' returned. - -=cut - -sub column_default { - my $class = shift; - my $colname = shift or $class->_croak( "Need a column for column_default"); - $class->_column_info() unless (ref $class->COLUMN_INFO); - if ($class->_isa_class($colname)) { - return $class->_isa_class($colname)->column_default($colname); - } - unless ( $class->find_column($colname) ) { - warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; - return undef; - } - - return $class->COLUMN_INFO->{$colname}{default}; -} - -=head2 get_classmetadata - -Gets class meta data *excluding cgi input* for the passed in class or the -calling class. *NOTE* excludes cgi inputs. This method is handy to call from -templates when you need some metadata for a related class. - -=cut - -sub get_classmetadata { - my ($self, $class) = @_; # class is class we want data for - $class ||= $self; - $class = ref $class || $class; - - my %res; - $res{name} = $class; - $res{colnames} = {$class->column_names}; - $res{columns} = [$class->display_columns]; - $res{list_columns} = [$class->list_columns]; - $res{moniker} = $class->moniker; - $res{plural} = $class->plural_moniker; - $res{table} = $class->table; - $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ; - return \%res; -} - - 1; diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 1765482..d76ecb4 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -1,14 +1,6 @@ package Maypole::Model::CDBI::AsForm; - -#TODO -- - -# TESTED and Works -- -# has_many select -- $obj->to_field($has_many_col); # select one form many -# -- $class->to_field($has_many_col); # foreign inputs -# $class->search_inputs; / - - use strict; + use warnings; use base 'Exporter'; @@ -18,7 +10,6 @@ use HTML::Element; use Carp qw/cluck/; our $OLD_STYLE = 0; -# pjs -- Added new methods to @EXPORT our @EXPORT = qw( to_cgi to_field foreign_input_delimiter search_inputs unselect_element @@ -30,7 +21,7 @@ our @EXPORT = _options_from_array _options_from_hash ); -our $VERSION = '.95'; +our $VERSION = '.97'; =head1 NAME @@ -297,17 +288,18 @@ columns and a hashref of hashes of arguments for each column. If called with an =cut sub to_cgi { - my ($class, @columns) = @_; # pjs -- added columns arg - my $args = {}; - if (not @columns) { - @columns = $class->columns; - # Eventually after stabalization, we could add display_columns - #keys map { $_ => 1 } ($class->display_columns, $class->columns); - } - else { - if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; } - } - map { $_ => $class->to_field($_, $args->{$_}) } @columns; + my ($class, @columns) = @_; + my $args = {}; + if (not @columns) { + @columns = $class->columns; + # Eventually after stabalization, we could add display_columns + #keys map { $_ => 1 } ($class->display_columns, $class->columns); + } else { + if ( ref $columns[-1] eq 'HASH' ) { + $args = pop @columns; + } + } + map { $_ => $class->to_field($_, $args->{$_}) } @columns; } =head2 to_field($field [, $how][, $args]) @@ -377,9 +369,9 @@ sub search_inputs { $class = ref $class || $class; #my $accssr_class = { $class->accessor_classes }; my %cgi; - + $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns]; - + foreach my $field ( @{ $args->{columns} } ) { my $base_args = { no_hidden_constraints => 1, @@ -407,7 +399,6 @@ sub search_inputs { my $val = $first ? $first->attr('value') : undef; if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or - #(defined $first->attr('value') or $first->attr('value') ne '')) # push an empty option on stactk $el->unshift_content(HTML::Element->new('option')); } @@ -442,35 +433,32 @@ sub search_inputs { =cut sub unselect_element { - my ($self, $el) = @_; - #unless (ref $el eq 'HTML::Element') { - #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); } - if ($el->tag eq 'select') { - foreach my $opt ($el->content_list) { - $opt->attr('selected', undef) if $opt->attr('selected'); - } - } + my ($self, $el) = @_; + if (ref $el && $el->can('tag') && $el->tag eq 'select') { + foreach my $opt ($el->content_list) { + $opt->attr('selected', undef) if $opt->attr('selected'); + } + } } =head2 _field_from_how($field, $how,$args) Returns an input element based the "how" parameter or nothing at all. -Override at will. +Override at will. =cut sub _field_from_how { - my ($self, $field, $how, $args) = @_; - return unless $how; - $args ||= {}; - no strict 'refs'; - my $meth = "_to_$how"; - if (not $self->can($meth)) { - warn "Class can not $meth"; - return; - } - return $self->$meth($field, $args); - return; + my ($self, $field, $how, $args) = @_; + return unless $how; + $args ||= {}; + no strict 'refs'; + my $meth = "_to_$how"; + if (not $self->can($meth)) { + warn "Class can not $meth"; + return; + } + return $self->$meth($field, $args); } =head2 _field_from_relationship($field, $args) @@ -483,46 +471,41 @@ For has_a it will give select box =cut sub _field_from_relationship { - my ($self, $field, $args) = @_; - return unless $field; - my $rel_meta = $self->related_meta('r',$field) || return; - my $rel_name = $rel_meta->{name}; - #my $meta = $self->meta_info; - #grep{ defined $meta->{$_}{$field} } keys %$meta; - my $fclass = $rel_meta->foreign_class; - my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; - - # maybe has_a select - if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) { - # This condictions allows for trumping of the has_a args - if (not $rel_meta->{args}{no_select} and not $args->{no_select}) - { - $args->{class} = $fclass; - return $self->_to_select($field, $args); - } - return; - } - # maybe has many select - if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) { - # This condictions allows for trumping of the has_a args - if (not $rel_meta->{args}{no_select} and not $args->{no_select}) - { - $args->{class} = $fclass; - my @itms = $self->$field; # need list not iterator - $args->{items} = \@itms; - return $self->_to_select($field, $args); - } - return; - } - - # maybe foreign inputs - my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols - if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own')) - { - $args->{related_meta} = $rel_meta; # suspect faster to set these args - return $self->_to_foreign_inputs($field, $args); - } - return; + my ($self, $field, $args) = @_; + return unless $field; + my $rel_meta = $self->related_meta('r',$field) || return; + my $rel_name = $rel_meta->{name}; + my $fclass = $rel_meta->foreign_class; + my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; + + # maybe has_a select + if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) { + # This condictions allows for trumping of the has_a args + if (not $rel_meta->{args}{no_select} and not $args->{no_select}) { + $args->{class} = $fclass; + return $self->_to_select($field, $args); + } + return; + } + # maybe has many select + if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) { + # This condictions allows for trumping of the has_a args + if (not $rel_meta->{args}{no_select} and not $args->{no_select}) { + $args->{class} = $fclass; + my @itms = $self->$field; # need list not iterator + $args->{items} = \@itms; + return $self->_to_select($field, $args); + } + return; + } + + # maybe foreign inputs + my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols + if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own')) { + $args->{related_meta} = $rel_meta; # suspect faster to set these args + return $self->_to_foreign_inputs($field, $args); + } + return; } =head2 _field_from_column($field, $args) @@ -566,102 +549,75 @@ sub _field_from_column { sub _to_textarea { - my ($self, $col, $args) = @_; - my $class = $args->{class} || $self; - $class = ref $class || $class; - $col ||= ($class->primary_columns)[0]; # TODO - # pjs added default - $args ||= {}; - my $val = $args->{value}; - - unless (defined $val) { - if (ref $self) { - $val = $self->$col; - } - else { - $val = $args->{default}; - $val = '' unless defined $val; - } - } - my ($rows, $cols) = _box($val); - $rows = $args->{rows} if $args->{rows}; - $cols = $args->{cols} if $args->{cols};; - my $name = $args->{name} || $col; - my $a = - HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols); - $a->push_content($val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $class = $args->{class} || $self; + $class = ref $class || $class; + $col ||= ($class->primary_columns)[0]; # TODO + # pjs added default + $args ||= {}; + my $val = $args->{value}; + + unless (defined $val) { + if (ref $self) { + $val = $self->$col; + } else { + $val = $args->{default}; + $val = '' unless defined $val; + } + } + my ($rows, $cols) = _box($val); + $rows = $args->{rows} if $args->{rows}; + $cols = $args->{cols} if $args->{cols};; + my $name = $args->{name} || $col; + my $a = + HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols); + $a->push_content($val); + $OLD_STYLE && return $a->as_HTML; + $a; } sub _to_textfield { - my ($self, $col, $args ) = @_; - use Carp qw/confess/; - confess "No col passed to _to_textfield" unless $col; - $args ||= {}; - my $val = $args->{value}; - my $name = $args->{name} || $col; - - unless (defined $val) { - if (ref $self) { - # Case where column inflates. - # Input would get stringification which could be not good. - # as in the case of Time::Piece objects - $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column - if (ref $val) { - if (my $meta = $self->related_meta('',$col)) { - if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) { - $val = ref $code ? &$code($val) : $val->$code; - } - elsif ( $val->isa('Class::DBI') ) { - $val = $val->id; - } - else { - #warn "No deflate4edit code defined for $val of type " . - #ref $val . ". Using the stringified value in textfield.."; - } - } - else { - $val = $val->id if $val->isa("Class::DBI"); - } - } - - } - else { - $val = $args->{default}; - $val = '' unless defined $val; - } - } - my $a; - # THIS If section is neccessary or you end up with "value" for a vaiue - # if val is - $val = '' unless defined $val; - $a = HTML::Element->new("input", type => "text", name => $name, value =>$val); - $OLD_STYLE && return $a->as_HTML; - $a; -} - - -# Old version -#sub _to_select { -# my ($self, $col, $hint) = @_; -# my $fclass = $hint || $self->__hasa_rels->{$col}->[0]; -# my @objs = $fclass->retrieve_all; -# my $a = HTML::Element->new("select", name => $col); -# for (@objs) { -# my $sel = HTML::Element->new("option", value => $_->id); -# $sel->attr("selected" => "selected") -# if ref $self -# and eval { $_->id eq $self->$col->id }; -# $sel->push_content($_->stringify_self); -# $a->push_content($sel); -# } -# $OLD_STYLE && return $a->as_HTML; -# $a; -#} - - + my ($self, $col, $args ) = @_; + use Carp qw/confess/; + confess "No col passed to _to_textfield" unless $col; + $args ||= {}; + my $val = $args->{value}; + my $name = $args->{name} || $col; + + unless (defined $val) { + if (ref $self) { + # Case where column inflates. + # Input would get stringification which could be not good. + # as in the case of Time::Piece objects + $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column + if (ref $val) { + if (my $meta = $self->related_meta('',$col)) { + if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) { + $val = ref $code ? &$code($val) : $val->$code; + } elsif ( $val->isa('Class::DBI') ) { + $val = $val->id; + } else { + #warn "No deflate4edit code defined for $val of type " . + #ref $val . ". Using the stringified value in textfield.."; + } + } else { + $val = $val->id if $val->isa("Class::DBI"); + } + } + } else { + $val = $args->{default}; + $val = '' unless defined $val; + } + } + my $a; + # THIS If section is neccessary or you end up with "value" for a vaiue + # if val is + $val = '' unless defined $val; + $a = HTML::Element->new("input", type => "text", name => $name, value =>$val); + $OLD_STYLE && return $a->as_HTML; + $a; +} =head2 recognized arguments @@ -677,10 +633,6 @@ sub _to_textfield { stringify => $stringify_coderef|$method_name - - -# select box requirements -# 1. a select box for objecs of a has_a related class -- DONE =head2 1. a select box out of a has_a or has_many related class. # For has_a the default behavior is to make a select box of every element in # related class and you choose one. @@ -713,100 +665,94 @@ sub _to_textfield { =cut sub _to_select { - my ($self, $col, $args) = @_; - $args ||= {}; - # Do we have items already ? Go no further. - if ($args->{items} and ref $args->{items}) { - my $a = $self->_select_guts($col, $args); - $OLD_STYLE && return $a->as_HTML; - if ($args->{multiple}) { $a->attr('multiple', 'multiple');} - return $a; - } - - # Proceed with work - - my $rel_meta; - if (not $col) { - unless ($args->{class}) { - $args->{class} = ref $self || $self; - # object selected if called with one - $args->{selected} = { $self->id => 1} - if not $args->{selected} and ref $self; - } - $col = $args->{class}->primary_column; - $args->{name} ||= $col; + my ($self, $col, $args) = @_; + + $args ||= {}; + # Do we have items already ? Go no further. + if ($args->{items} and ref $args->{items}) { + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + if ($args->{multiple}) { + $a->attr('multiple', 'multiple'); } - # Related Class maybe ? - elsif ($rel_meta = $self->related_meta('r:)', $col) ) { - $args->{class} = $rel_meta->{foreign_class}; - # related objects pre selected if object - - # "Has many" -- Issues: - # 1) want to select one or many from list if self is an object - # Thats about all we can do really, - # 2) except for mapping which is TODO and would - # do something like add to and take away from list of permissions for - # example. - - # Hasmany select one from list if ref self - if ($rel_meta->{name} =~ /has_many/i and ref $self) { - my @itms = $self->$col; # need list not iterator - $args->{items} = \@itms; - my $a = $self->_select_guts($col, $args); - $OLD_STYLE && return $a->as_HTML; - return $a; - } - else { - $args->{selected} ||= [ $self->$col ] if ref $self; - #warn "selected is " . Dumper($args->{selected}); - my $c = $rel_meta->{args}{constraint} || {}; - my $j = $rel_meta->{args}{join} || {}; - my @join ; - if (ref $self) { - @join = map { $_ ." = ". $self->_attr($_) } keys %$j; - } - my @constr= map { "$_ = '$c->{$_}'"} keys %$c; - $args->{where} ||= join (' AND ', (@join, @constr)); - $args->{order_by} ||= $rel_meta->{args}{order_by}; - $args->{limit} ||= $rel_meta->{args}{limit}; - } - + return $a; + } + + # Proceed with work + + my $rel_meta; + if (not $col) { + unless ($args->{class}) { + $args->{class} = ref $self || $self; + # object selected if called with one + $args->{selected} = { $self->id => 1} + if not $args->{selected} and ref $self; } - # We could say :Col is name and we are selecting out of class arg. - # DIE for now - #else { - # die "Usage _to_select. $col not related to any class to select from. "; - - #} - - # Set arguments - unless ( defined $args->{column_nullable} ) { - $args->{column_nullable} = $self->can('column_nullable') ? - $self->column_nullable($col) : 1; - } + $col = $args->{class}->primary_column; + $args->{name} ||= $col; + } + # Related Class maybe ? + elsif ($rel_meta = $self->related_meta('r:)', $col) ) { + $args->{class} = $rel_meta->{foreign_class}; + # related objects pre selected if object + # "Has many" -- Issues: + # 1) want to select one or many from list if self is an object + # Thats about all we can do really, + # 2) except for mapping which is TODO and would + # do something like add to and take away from list of permissions for + # example. + + # Hasmany select one from list if ref self + if ($rel_meta->{name} =~ /has_many/i and ref $self) { + my @itms = $self->$col; # need list not iterator + $args->{items} = \@itms; + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + return $a; + } else { + $args->{selected} ||= [ $self->$col ] if ref $self; + #warn "selected is " . Dumper($args->{selected}); + my $c = $rel_meta->{args}{constraint} || {}; + my $j = $rel_meta->{args}{join} || {}; + my @join ; + if (ref $self) { + @join = map { $_ ." = ". $self->_attr($_) } keys %$j; + } + my @constr= map { "$_ = '$c->{$_}'"} keys %$c; + $args->{where} ||= join (' AND ', (@join, @constr)); + $args->{order_by} ||= $rel_meta->{args}{order_by}; + $args->{limit} ||= $rel_meta->{args}{limit}; + } + } - # Get items to select from - my $items = _select_items($args); # array of hashrefs + # Set arguments + unless ( defined $args->{column_nullable} ) { + $args->{column_nullable} = $self->can('column_nullable') ? + $self->column_nullable($col) : 1; + } - # Turn items into objects if related - if ($rel_meta and not $args->{no_construct}) { - my @objs = (); - push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items; - $args->{items} = \@objs; - } - else { $args->{items} = $items; } - - #use Data::Dumper; - #warn "Just got items. They are " . Dumper($args->{items}); + # Get items to select from + my $items = _select_items($args); # array of hashrefs - # Make select HTML element - $a = $self->_select_guts($col, $args); + # Turn items into objects if related + if ($rel_meta and not $args->{no_construct}) { + my @objs = (); + push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items; + $args->{items} = \@objs; + } else { + $args->{items} = $items; + } - if ($args->{multiple}) {$a->attr('multiple', 'multiple');} + # Make select HTML element + $a = $self->_select_guts($col, $args); - # Return - $OLD_STYLE && return $a->as_HTML; - $a; + if ($args->{multiple}) { + $a->attr('multiple', 'multiple'); + } + + # Return + $OLD_STYLE && return $a->as_HTML; + $a; } @@ -816,64 +762,68 @@ sub _to_select { # ############# # returns the intersection of list refs a and b sub _list_intersect { - my ($a, $b) = @_; - my %isect; my %union; - foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ } - return %isect; + my ($a, $b) = @_; + my %isect; my %union; + foreach my $e (@$a, @$b) { + $union{$e}++ && $isect{$e}++; + } + return %isect; } + ############ # FUNCTION # ############ # Get Items returns array of hashrefs sub _select_items { - my $args = shift; - my $fclass = $args->{class}; - my @disp_cols = @{$args->{columns} || []}; - @disp_cols = $fclass->columns('SelectBox') unless @disp_cols; - @disp_cols = $fclass->columns('Stringify')unless @disp_cols; - @disp_cols = $fclass->_essential unless @disp_cols; - unshift @disp_cols, $fclass->columns('Primary'); - #my %isect = _list_intersect(\@pks, \@disp_cols); - #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; } - #push @sel_cols, @disp_cols; - - #warn "in select items. args are : " . Dumper($args); - my $distinct = ''; - if ($args->{'distinct'}) { - $distinct = 'DISTINCT '; - } - - my $sql = "SELECT $distinct" . join( ', ', @disp_cols) . - " FROM " . $fclass->table; + my $args = shift; + my $fclass = $args->{class}; + my @disp_cols = @{$args->{columns} || []}; + @disp_cols = $fclass->columns('SelectBox') unless @disp_cols; + @disp_cols = $fclass->columns('Stringify')unless @disp_cols; + @disp_cols = $fclass->_essential unless @disp_cols; + unshift @disp_cols, $fclass->columns('Primary'); + #my %isect = _list_intersect(\@pks, \@disp_cols); + #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; } + #push @sel_cols, @disp_cols; + + #warn "in select items. args are : " . Dumper($args); + my $distinct = ''; + if ($args->{'distinct'}) { + $distinct = 'DISTINCT '; + } - $sql .= " WHERE " . $args->{where} if $args->{where}; - $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by}; - $sql .= " LIMIT " . $args->{limit} if $args->{limit}; - #warn "_select_items sql is : $sql"; + my $sql = "SELECT $distinct" . join( ', ', @disp_cols) . + " FROM " . $fclass->table; - my $sth = $fclass->db_Main->prepare($sql); - $sth->execute; - my @data; - while ( my $d = $sth->fetchrow_hashref ) {push @data, $d}; - return \@data; + $sql .= " WHERE " . $args->{where} if $args->{where}; + $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by}; + $sql .= " LIMIT " . $args->{limit} if $args->{limit}; + #warn "_select_items sql is : $sql"; + my $sth = $fclass->db_Main->prepare($sql); + $sth->execute; + my @data; + while ( my $d = $sth->fetchrow_hashref ) { + push @data, $d; + } + return \@data; } # Makes a readonly input box out of column's value # No args makes object to readonly sub _to_readonly { - my ($self, $col, $args) = @_; - my $val = $args->{value}; - if (not defined $val ) { # object to readonly - $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self; - $val = $self->id; - $col = $self->primary_column; - } - my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1', - 'name' => $col, 'value'=>$val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $val = $args->{value}; + if (not defined $val ) { # object to readonly + $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self; + $val = $self->id; + $col = $self->primary_column; + } + my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1', + 'name' => $col, 'value'=>$val); + $OLD_STYLE && return $a->as_HTML; + $a; } @@ -884,26 +834,26 @@ Returns a select box for the an enum column type. =cut sub _to_enum_select { - my ($self, $col, $args) = @_; - my $type = $args->{column_type}; - $type =~ /ENUM\((.*?)\)/i; - (my $enum = $1) =~ s/'//g; - my @enum_vals = split /\s*,\s*/, $enum; - - # determine which is pre selected -- - my $selected = eval { $self->$col }; - $selected = $args->{default} unless defined $selected; - $selected = $enum_vals[0] unless defined $selected; - - my $a = HTML::Element->new("select", name => $col); - for ( @enum_vals ) { - my $sel = HTML::Element->new("option", value => $_); - $sel->attr("selected" => "selected") if $_ eq $selected ; - $sel->push_content($_); - $a->push_content($sel); - } - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $type = $args->{column_type}; + $type =~ /ENUM\((.*?)\)/i; + (my $enum = $1) =~ s/'//g; + my @enum_vals = split /\s*,\s*/, $enum; + + # determine which is pre selected + my $selected = eval { $self->$col }; + $selected = $args->{default} unless defined $selected; + $selected = $enum_vals[0] unless defined $selected; + + my $a = HTML::Element->new("select", name => $col); + for ( @enum_vals ) { + my $sel = HTML::Element->new("option", value => $_); + $sel->attr("selected" => "selected") if $_ eq $selected ; + $sel->push_content($_); + $a->push_content($sel); + } + $OLD_STYLE && return $a->as_HTML; + $a; } @@ -912,43 +862,42 @@ sub _to_enum_select { Returns a "No/Yes" select box for a boolean column type. =cut -# TCODO fix this mess with args + +# TODO fix this mess with args sub _to_bool_select { - my ($self, $col, $args) = @_; - my $type = $args->{column_type}; - my @bool_text = ('No', 'Yes'); - if ($type =~ /BOOL\((.+?)\)/i) { - (my $bool = $1) =~ s/'//g; - @bool_text = split /,/, $bool; - } + my ($self, $col, $args) = @_; + my $type = $args->{column_type}; + my @bool_text = ('No', 'Yes'); + if ($type =~ /BOOL\((.+?)\)/i) { + (my $bool = $1) =~ s/'//g; + @bool_text = split /,/, $bool; + } - # get selected - - my $selected = $args->{value} if defined $args->{value}; - $selected = $args->{selected} unless defined $selected; - $selected = ref $self ? eval {$self->$col;} : $args->{default} - unless (defined $selected); - - my $a = HTML::Element->new("select", name => $col); - if ($args->{column_nullable} || $args->{value} eq '') { - my $null = HTML::Element->new("option"); - $null->attr('selected', 'selected') if $args->{value} eq ''; - $a->push_content( $null ); - } - - my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0), - HTML::Element->new("option", value => 1) ); - $opt0->push_content($bool_text[0]); - $opt1->push_content($bool_text[1]); - unless ($selected eq '') { - $opt0->attr("selected" => "selected") if not $selected; - $opt1->attr("selected" => "selected") if $selected; - } - $a->push_content($opt0, $opt1); - $OLD_STYLE && return $a->as_HTML; - $a; -} + # get selected + my $selected = $args->{value} if defined $args->{value}; + $selected = $args->{selected} unless defined $selected; + $selected = ref $self ? eval {$self->$col;} : $args->{default} + unless (defined $selected); + + my $a = HTML::Element->new("select", name => $col); + if ($args->{column_nullable} || $args->{value} eq '') { + my $null = HTML::Element->new("option"); + $null->attr('selected', 'selected') if $args->{value} eq ''; + $a->push_content( $null ); + } + my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0), + HTML::Element->new("option", value => 1) ); + $opt0->push_content($bool_text[0]); + $opt1->push_content($bool_text[1]); + unless ($selected eq '') { + $opt0->attr("selected" => "selected") if not $selected; + $opt1->attr("selected" => "selected") if $selected; + } + $a->push_content($opt0, $opt1); + $OLD_STYLE && return $a->as_HTML; + $a; +} =head2 _to_hidden($field, $args) @@ -960,20 +909,21 @@ name and the value of the column by the derived name. =cut sub _to_hidden { - my ($self, $field, $args) = @_; - $args ||= {}; - my ($name, $value) = ($args->{'name'}, $args->{value}); - $name = $field unless defined $name; - if (! defined $name and !defined $value) { # check for objects - my $obj = $args->{items}->[0] || $self; - unless (ref $obj) { die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; } - $name = $obj->primary_column->name unless $name; - $value = $obj->$name unless $value; - } + my ($self, $field, $args) = @_; + $args ||= {}; + my ($name, $value) = ($args->{'name'}, $args->{value}); + $name = $field unless defined $name; + if (! defined $name and !defined $value) { # check for objects + my $obj = $args->{items}->[0] || $self; + unless (ref $obj) { + die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; + } + $name = $obj->primary_column->name unless $name; + $value = $obj->$name unless $value; + } - return HTML::Element->new('input', 'type' => 'hidden', - 'name' => $name, 'value'=>$value); - + return HTML::Element->new('input', 'type' => 'hidden', + 'name' => $name, 'value'=>$value); } =head2 _to_link_hidden($col, $args) @@ -984,34 +934,31 @@ Name defaults to the objects primary key. The object defaults to self. =cut sub _to_link_hidden { - my ($self, $accessor, $args) = @_; - my $r = eval {$self->controller} || $args->{r} || ''; - my $uri = $args->{uri} || ''; - use Data::Dumper; - $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.") - unless $r; - my ($obj, $name); - if (ref $self) { # hidding linking self - $obj = $self; - $name = $args->{name} || $obj->primary_column->name; - } - elsif ($obj = $args->{items}->[0]) { - $name = $args->{name} || $accessor || $obj->primary_column->name; - # TODO use meta data above maybe - } - else { # hiding linking related object with id in args - $obj = $self->related_class($r, $accessor)->retrieve($args->{id}); - $name = $args->{name} || $accessor ; #$obj->primary_column->name; - # TODO use meta data above maybe - } - $self->_croak("_to_link_hidden has no object") unless ref $obj; - my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id; - my $a = HTML::Element->new('a', 'href' => $href); - $a->push_content("$obj"); - $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} )); - - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $accessor, $args) = @_; + my $r = eval {$self->controller} || $args->{r} || ''; + my $uri = $args->{uri} || ''; + $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.") + unless $r; + my ($obj, $name); + if (ref $self) { # hidding linking self + $obj = $self; + $name = $args->{name} || $obj->primary_column->name; + } elsif ($obj = $args->{items}->[0]) { + $name = $args->{name} || $accessor || $obj->primary_column->name; + # TODO use meta data above maybe + } else { # hiding linking related object with id in args + $obj = $self->related_class($r, $accessor)->retrieve($args->{id}); + $name = $args->{name} || $accessor ; #$obj->primary_column->name; + # TODO use meta data above maybe + } + $self->_croak("_to_link_hidden has no object") unless ref $obj; + my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id; + my $a = HTML::Element->new('a', 'href' => $href); + $a->push_content("$obj"); + $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} )); + + $OLD_STYLE && return $a->as_HTML; + return $a; } =head2 _to_foreign_inputs @@ -1030,41 +977,43 @@ Arguments this recognizes are : =cut sub _to_foreign_inputs { - my ($self, $accssr, $args) = @_; - my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr); - my $fields = $args->{columns}; - if (!$rel_meta) { - $self->_croak( "No relationship for accessor $accssr"); - } + my ($self, $accssr, $args) = @_; + my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr); + my $fields = $args->{columns}; + if (!$rel_meta) { + $self->_carp( "[_to_foreign_inputs] No relationship for accessor $accssr"); + return; + } - my $rel_type = $rel_meta->{name}; - my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class}; + my $rel_type = $rel_meta->{name}; + my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class}; - unless ($fields) { - $fields = $classORobj->can('display_columns') ? - [$classORobj->display_columns] : [$classORobj->columns]; - } + unless ($fields) { + $fields = $classORobj->can('display_columns') ? + [$classORobj->display_columns] : [$classORobj->columns]; + } - # Ignore our fkey in them to prevent infinite recursion - my $me = eval {$rel_meta->{args}{foreign_key}} || - eval {$rel_meta->{args}{foreign_column}} - || ''; # what uses foreign_column has_many or might_have - my $constrained = $rel_meta->{args}{constraint}; - my %inputs; - foreach ( @$fields ) { - next if $constrained->{$_} || ($_ eq $me); # don't display constrained - $inputs{$_} = $classORobj->to_field($_); - } + # Ignore our fkey in them to prevent infinite recursion + my $me = eval {$rel_meta->{args}{foreign_key}} || + eval {$rel_meta->{args}{foreign_column}} + || ''; # what uses foreign_column has_many or might_have + my $constrained = $rel_meta->{args}{constraint}; + my %inputs; + foreach ( @$fields ) { + next if $constrained->{$_} || ($_ eq $me); # don't display constrained + $inputs{$_} = $classORobj->to_field($_); + } - # Make hidden inputs for constrained columns unless we are editing object - # TODO -- is this right thing to do? - unless (ref $classORobj || $args->{no_hidden_constraints}) { - $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden', - {name => $_, value => $constrained->{$_}} ) - foreach ( keys %$constrained ); - } - $self->_rename_foreign_input($accssr, \%inputs); - return \%inputs; + # Make hidden inputs for constrained columns unless we are editing object + # TODO -- is this right thing to do? + unless (ref $classORobj || $args->{no_hidden_constraints}) { + foreach ( keys %$constrained ) { + $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden', + { name => $_, value => $constrained->{$_}} ); + } + } + $self->_rename_foreign_input($accssr, \%inputs); + return \%inputs; } @@ -1083,57 +1032,57 @@ and in the following ways Array ref of objects -- same as Object Arrays of data -- uses the 0th element in each Hashes of data -- uses key named 'id' - -=cut - + +=cut + ############ # FUNCTION # ############ + sub _hash_selected { - my ($args) = shift; - my $selected = $args->{value} || $args->{selected}; - #warn "**** SELECTED is $selected ****"; - my $type = ref $selected; - return $selected unless $selected and $type ne 'HASH'; - #warn "Selected dump : " . Dumper($selected); - # Single Object - if ($type and $type ne 'ARRAY') { - my $id = $selected->id; - $id =~ s/^0*//; - return {$id => 1}; - } - # Single Scalar id - elsif (not $type) { - return { $selected => 1}; - } - + my ($args) = shift; + my $selected = $args->{value} || $args->{selected}; + my $type = ref $selected; + return $selected unless $selected and $type ne 'HASH'; + + # Single Object + if ($type and $type ne 'ARRAY') { + my $id = $selected->id; + $id =~ s/^0*//; + return {$id => 1}; + } + # Single Scalar id + elsif (not $type) { + return { $selected => 1}; + } - # Array of objs, arrays, hashes, or just scalalrs. - elsif ($type eq 'ARRAY') { - my %hashed; - my $ltype = ref $selected->[0]; - # Objects - if ($ltype and $ltype ne 'ARRAY') { - %hashed = map { $_->id => 1 } @$selected; - } - # Arrays of data with id first - elsif ($ltype and $ltype eq 'ARRAY') { - %hashed = map { $_->[0] => 1 } @$selected; - } - # Hashes using pk or id key - elsif ($ltype and $ltype eq 'HASH') { - my $pk = $args->{class}->primary_column || 'id'; - %hashed = map { $_->{$pk} => 1 } @$selected; - } - # Just Scalars - else { - %hashed = map { $_ => 1 } @$selected; - } - return \%hashed; - } - else { warn "AsForm Could not hash the selected argument: $selected"; } -} - + # Array of objs, arrays, hashes, or just scalalrs. + elsif ($type eq 'ARRAY') { + my %hashed; + my $ltype = ref $selected->[0]; + # Objects + if ($ltype and $ltype ne 'ARRAY') { + %hashed = map { $_->id => 1 } @$selected; + } + # Arrays of data with id first + elsif ($ltype and $ltype eq 'ARRAY') { + %hashed = map { $_->[0] => 1 } @$selected; + } + # Hashes using pk or id key + elsif ($ltype and $ltype eq 'HASH') { + my $pk = $args->{class}->primary_column || 'id'; + %hashed = map { $_->{$pk} => 1 } @$selected; + } + # Just Scalars + else { + %hashed = map { $_ => 1 } @$selected; + } + return \%hashed; + } else { + warn "AsForm Could not hash the selected argument: $selected"; + } + return; +} @@ -1151,67 +1100,63 @@ Items to make options out of can be =cut - - sub _select_guts { - my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; - - #$args->{stringify} ||= 'stringify_selectbox'; + my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; - $args->{selected} = _hash_selected($args) if defined $args->{selected}; - my $name = $args->{name} || $col; - my $a = HTML::Element->new('select', name => $name); - $a->attr( %{$args->{attr}} ) if $args->{attr}; + $args->{selected} = _hash_selected($args) if defined $args->{selected}; + my $name = $args->{name} || $col; + my $a = HTML::Element->new('select', name => $name); + $a->attr( %{$args->{attr}} ) if $args->{attr}; - if ($args->{column_nullable}) { - my $null_element = HTML::Element->new('option', value => ''); - $null_element->attr(selected => 'selected') - if ($args->{selected}{'null'}); - $a->push_content($null_element); - } + if ($args->{column_nullable}) { + my $null_element = HTML::Element->new('option', value => ''); + $null_element->attr(selected => 'selected') + if ($args->{selected}{'null'}); + $a->push_content($null_element); + } - my $items = $args->{items}; - my $type = ref $items; - my $proto = eval { ref $items->[0]; } || ""; - my $optgroups = $args->{optgroups} || ''; - - # Array of hashes, one for each optgroup - if ($optgroups) { - my $i = 0; - foreach (@$optgroups) { - my $ogrp= HTML::Element->new('optgroup', label => $_); - $ogrp->push_content($self->_options_from_hash($items->[$i], $args)); - $a->push_content($ogrp); - $i++; - } - } - # Single Hash - elsif ($type eq 'HASH') { - $a->push_content($self->_options_from_hash($items, $args)); - } - # Single Array - elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { - $a->push_content($self->_options_from_array($items, $args)); - } - # Array of Objects - elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) { - # make select of objects - $a->push_content($self->_options_from_objects($items, $args)); - } - # Array of Arrays - elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { - $a->push_content($self->_options_from_arrays($items, $args)); - } - # Array of Hashes - elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { - $a->push_content($self->_options_from_hashes($items, $args)); - } - else { - die "You passed a weird type of data structure to me. Here it is: " . - Dumper($items ); + my $items = $args->{items}; + my $type = ref $items; + my $proto = eval { ref $items->[0]; } || ""; + my $optgroups = $args->{optgroups} || ''; + + # Array of hashes, one for each optgroup + if ($optgroups) { + my $i = 0; + foreach (@$optgroups) { + my $ogrp= HTML::Element->new('optgroup', label => $_); + $ogrp->push_content($self->_options_from_hash($items->[$i], $args)); + $a->push_content($ogrp); + $i++; } + } - return $a; + # Single Hash + elsif ($type eq 'HASH') { + $a->push_content($self->_options_from_hash($items, $args)); + } + # Single Array + elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { + $a->push_content($self->_options_from_array($items, $args)); + } + # Array of Objects + elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) { + # make select of objects + $a->push_content($self->_options_from_objects($items, $args)); + } + # Array of Arrays + elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { + $a->push_content($self->_options_from_arrays($items, $args)); + } + # Array of Hashes + elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { + $a->push_content($self->_options_from_hashes($items, $args)); + } else { + die "You passed a weird type of data structure to me. Here it is: " . + Dumper($items ); + } + + return $a; } @@ -1225,113 +1170,111 @@ objects stringify method specified in $args->{stringify} as the content. Otherwi =cut sub _options_from_objects { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my $stringify = $args->{stringify} || ''; - my @res; - for (@$items) { - my $id = $_->id; - my $opt = HTML::Element->new("option", value => $id); - $id =~ s/^0*//; # leading zeros no good in hash key - $opt->attr(selected => "selected") if $selected->{$id}; - my $content = $stringify ? $_->stringify : "$_"; - $opt->push_content($content); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + + my @res; + for my $object (@$items) { + my $stringify = $args->{stringify}; + if ($object->can('stringify_column') ) { + $stringify ||= $object->stringify_column if ($object->stringify_column && $object->can($object->stringify_column)); + } + my $id = $object->id; + my $opt = HTML::Element->new("option", value => $id); + $id =~ s/^0*//; # leading zeros no good in hash key + $opt->attr(selected => "selected") if $selected->{$id}; + my $content = $stringify ? $object->$stringify : "$object"; + $opt->push_content($content); + push @res, $opt; + } + return @res; } sub _options_from_arrays { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - my $class = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; - for my $item (@$items) { - my @pks; # for future multiple key support - push @pks, shift @$item foreach $class->columns('Primary'); - my $id = $pks[0]; - $id =~ s/^0+//; # In case zerofill is on . - my $val = defined $id ? $id : ''; - my $opt = HTML::Element->new("option", value =>$val); - $opt->attr(selected => "selected") if $selected->{$id}; - - my $content = ($class and $stringify and $class->can($stringify)) ? - $class->$stringify($_) : - join( '/', map { $_ if $_; }@{$item} ); - $opt->push_content( $content ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + my $class = $args->{class} || ''; + my $stringify = $args->{stringify}; + $stringify ||= $self->stringify_column if ($self->can('stringify_column')); + for my $item (@$items) { + my @pks; # for future multiple key support + push @pks, shift @$item foreach $class->columns('Primary'); + my $id = $pks[0]; + $id =~ s/^0+//; # In case zerofill is on . + my $val = defined $id ? $id : ''; + my $opt = HTML::Element->new("option", value =>$val); + $opt->attr(selected => "selected") if $selected->{$id}; + my $content = ($class and $stringify and $class->can($stringify)) ? + $class->$stringify($_) : + join( '/', map { $_ if $_; }@{$item} ); + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } sub _options_from_array { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - for (@$items) { - my $val = defined $_ ? $_ : ''; - my $opt = HTML::Element->new("option", value => $val); - #$opt->attr(selected => "selected") if $selected =~/^$id$/; - $opt->attr(selected => "selected") if $selected->{$_}; - $opt->push_content( $_ ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + for (@$items) { + my $val = defined $_ ? $_ : ''; + my $opt = HTML::Element->new("option", value => $val); + #$opt->attr(selected => "selected") if $selected =~/^$id$/; + $opt->attr(selected => "selected") if $selected->{$_}; + $opt->push_content( $_ ); + push @res, $opt; + } + return @res; } sub _options_from_hash { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - - my @values = values %$items; - # hash Key is the option content and the hash value is option value - for (sort keys %$items) { - my $val = defined $items->{$_} ? $items->{$_} : ''; - my $opt = HTML::Element->new("option", value => $val); - #$opt->attr(selected => "selected") if $selected =~/^$id$/; - $opt->attr(selected => "selected") if $selected->{$items->{$_}}; - $opt->push_content( $_ ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + + my @values = values %$items; + # hash Key is the option content and the hash value is option value + for (sort keys %$items) { + my $val = defined $items->{$_} ? $items->{$_} : ''; + my $opt = HTML::Element->new("option", value => $val); + $opt->attr(selected => "selected") if $selected->{$items->{$_}}; + $opt->push_content( $_ ); + push @res, $opt; + } + return @res; } sub _options_from_hashes { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my $pk = eval {$args->{class}->primary_column} || 'id'; - my $fclass = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; - my @res; - for my $item (@$items) { - my $val = defined $item->{$pk} ? $item->{$pk} : ''; - my $opt = HTML::Element->new("option", value => $val); - $opt->attr(selected => "selected") if $selected->{$val}; - my $content = ($fclass and $stringify and $fclass->can($stringify)) ? - $fclass->$stringify($_) : - join(' ', map {$item->{$_} } keys %$item); - $opt->push_content( $content ); - push @res, $opt; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my $pk = eval {$args->{class}->primary_column} || 'id'; + my $fclass = $args->{class} || ''; + my $stringify = $args->{stringify}; + $stringify ||= $self->stringify_column if ( $self->can('stringify_column') ); + my @res; + for my $item (@$items) { + my $val = defined $item->{$pk} ? $item->{$pk} : ''; + my $opt = HTML::Element->new("option", value => $val); + $opt->attr(selected => "selected") if $selected->{$val}; + my $content; + if ($fclass and $stringify and $fclass->can($stringify)) { + $content = bless ($item,$fclass)->$stringify(); + } elsif ( $stringify ) { + $content = $item->{$stringify}; + } else { + $content = join(' ', map {$item->{$_} } keys %$item); } - return @res; + + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } -# TODO -- Maybe -#sub _to_select_or_create { -# my ($self, $col, $args) = @_; -# $args->{name} ||= $col; -# my $select = $self->to_field($col, 'select', $args); -# $args->{name} = "create_" . $args->{name}; -# my $create = $self->to_field($col, 'foreign_inputs', $args); -# $create->{'__select_or_create__'} = -# $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } ); -# return ($select, $create); -#} - =head2 _to_checkbox @@ -1365,21 +1308,25 @@ Makes a radio button element -- TODO # TODO -- make this general radio butons # sub _to_radio { - my ($self, $col) = @_; - my $value = ref $self && $self->$col || ''; - my $nullable = eval {self->column_nullable($col)} || 0; - my $a = HTML::Element->new("span"); - my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' ); - my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' ); - my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable; - $ry->push_content('Yes'); $rn->push_content('No'); - $ru->push_content('n/a') if $nullable; - if ($value eq 'Y') { $ry->attr("checked" => 'true') } - elsif ($value eq 'N') { $rn->attr("checked" => 'true') } - elsif ($nullable) { $ru->attr("checked" => 'true') } - $a->push_content($ry, $rn); - $a->push_content($ru) if $nullable; - return $a; + my ($self, $col) = @_; + my $value = ref $self && $self->$col || ''; + my $nullable = eval {self->column_nullable($col)} || 0; + my $a = HTML::Element->new("span"); + my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' ); + my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' ); + my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable; + $ry->push_content('Yes'); $rn->push_content('No'); + $ru->push_content('n/a') if $nullable; + if ($value eq 'Y') { + $ry->attr("checked" => 'true'); + } elsif ($value eq 'N') { + $rn->attr("checked" => 'true'); + } elsif ($nullable) { + $ru->attr("checked" => 'true'); + } + $a->push_content($ry, $rn); + $a->push_content($ru) if $nullable; + return $a; } @@ -1413,17 +1360,16 @@ person->{address} data slot, insert the person and put the person id in the empl =cut sub _rename_foreign_input { - my ($self, $accssr, $element) = @_; - my $del = $self->foreign_input_delimiter; - - if ( ref $element ne 'HASH' ) { - # my $new_name = $accssr . "__AF__" . $input->attr('name'); - $element->attr( name => $accssr . $del . $element->attr('name')); - } - else { - $self->_rename_foreign_input($accssr, $element->{$_}) - foreach (keys %$element); - } + my ($self, $accssr, $element) = @_; + my $del = $self->foreign_input_delimiter; + + if ( ref $element ne 'HASH' ) { + # my $new_name = $accssr . "__AF__" . $input->attr('name'); + $element->attr( name => $accssr . $del . $element->attr('name')); + } else { + $self->_rename_foreign_input($accssr, $element->{$_}) + foreach (keys %$element); + } } =head2 foreign_input_delimiter @@ -1442,28 +1388,27 @@ or the defaults. =cut -sub _box -{ - - my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100); - my $text = shift; - if ($text) { - my @rows = split /^/, $text; - my $cols = $min_cols; - my $chars = 0; - for (@rows) { - my $len = length $_; - $chars += $len; - $cols = $len if $len > $cols; - $cols = $max_cols if $cols > $max_cols; - } - my $rows = @rows; - $rows = int($chars/$cols) + 1 if $chars/$cols > $rows; - $rows = $min_rows if $rows < $min_rows; - $rows = $max_rows if $rows > $max_rows; - ($rows, $cols) +sub _box { + my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100); + my $text = shift; + if ($text) { + my @rows = split /^/, $text; + my $cols = $min_cols; + my $chars = 0; + for (@rows) { + my $len = length $_; + $chars += $len; + $cols = $len if $len > $cols; + $cols = $max_cols if $cols > $max_cols; } - else { ($min_rows, $min_cols) } + my $rows = @rows; + $rows = int($chars/$cols) + 1 if $chars/$cols > $rows; + $rows = $min_rows if $rows < $min_rows; + $rows = $max_rows if $rows > $max_rows; + ($rows, $cols) + } else { + ($min_rows, $min_cols); + } } @@ -1488,11 +1433,9 @@ Simon Cozens, Tony Bowden =head1 TODO - Documenting Testing - lots - chekbox generalization + checkbox generalization radio generalization - select work Make link_hidden use standard make_url stuff when it gets in Maypole How do you tell AF --" I want a has_many select box for this every time so, when you call "to_field($this_hasmany)" you get a select box @@ -1500,7 +1443,7 @@ Simon Cozens, Tony Bowden =head1 BUGS and QUERIES Please direct all correspondence regarding this module to: - Maypole list. + Maypole list. =head1 COPYRIGHT AND LICENSE diff --git a/lib/Maypole/Model/CDBI/Base.pm b/lib/Maypole/Model/CDBI/Base.pm new file mode 100644 index 0000000..ec88942 --- /dev/null +++ b/lib/Maypole/Model/CDBI/Base.pm @@ -0,0 +1,780 @@ +package Maypole::Model::CDBI::Base; +use strict; + +=head1 NAME + +Maypole::Model::CDBI::Base - Model base class based on Class::DBI + +=head1 DESCRIPTION + +This is a master model class which uses L to do all the hard +work of fetching rows and representing them as objects. It is a good +model to copy if you're replacing it with other database abstraction +modules. + +It implements a base set of methods required for a Maypole Data Model. + +It inherits accessor and helper methods from L. + +=cut + +use base qw(Maypole::Model::Base Class::DBI); +use Class::DBI::AbstractSearch; +use Class::DBI::Plugin::RetrieveAll; +use Class::DBI::Pager; +use Lingua::EN::Inflect::Number qw(to_PL); +use attributes (); +use Data::Dumper; + +__PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/); + +=head2 add_model_superclass + +Adds model as superclass to model classes (if necessary) + +=cut + +sub add_model_superclass { + my ($class,$config) = @_; + foreach my $subclass ( @{ $config->classes } ) { + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + push @{ $subclass . "::ISA" }, $config->model; + } + return; +} + +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=cut + +sub do_edit : Exported { + my ($self, $r, $obj) = @_; + + my $config = $r->config; + my $table = $r->table; + + # handle cancel button hit + if ( $r->{params}->{cancel} ) { + $r->template("list"); + $r->objects( [$self->retrieve_all] ); + return; + } + + my $required_cols = $config->{$table}{required_cols} || $self->required_columns; + my $ignored_cols = $config->{$table}{ignore_cols} || []; + + ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); + + # handle errors, if none, proceed to view the newly created/updated object + my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; + + if (%errors) { + # Set it up as it was: + $r->template_args->{cgi_params} = $r->params; + + # replace user unfriendly error messages with something nicer + + foreach (@{$config->{$table}->{required_cols}}) { + next unless ($errors{$_}); + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value'; + $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value'; + delete $errors{$key}; + } + + foreach (keys %errors) { + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field'; + $r->template_args->{errors}{$key} = 'Please provide a valid value for this field'; + } + + undef $obj if $creating; + + die "do_update failed with error : $fatal" if ($fatal); + $r->template("edit"); + } else { + $r->template("view"); + } + + $r->objects( $obj ? [$obj] : []); +} + +# split out from do_edit to be reported by Mp::P::Trace +sub _do_update_or_create { + my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; + + my $fatal; + my $creating = 0; + + my $h = $self->Untainter->new( %{$r->params} ); + + # update or create + if ($obj) { + # We have something to edit + eval { $obj->update_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + }); + $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit' + }; + $fatal = $@; + } else { + eval { + $obj = $self->create_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + } ); + }; + $fatal = $@; + $creating++; + } + return $obj, $fatal, $creating; +} + +=head2 view + +This command shows the object using the view factory template. + +=cut + +sub view : Exported { + my ($self, $r) = @_; + $r->build_form_elements(0); + return; +} + + +=head2 delete + +Deprecated method that calls do_delete or a given classes delete method, please +use do_delete instead + +=head2 do_delete + +Unsuprisingly, this command causes a database record to be forever lost. + +This method replaces the, now deprecated, delete method provided in prior versions + +=cut + +sub delete : Exported { + my $self = shift; + my ($sub) = (caller(1))[3]; + # So subclasses can still send delete down ... + $sub =~ /^(.+)::([^:]+)$/; + if ($1 ne "Maypole::Model::Base" && $2 ne "delete") { + $self->SUPER::delete(@_); + } else { + warn "Maypole::Model::CDBI::Base delete method is deprecated\n"; + $self->do_delete(@_); + } +} + +sub do_delete : Exported { + my ( $self, $r ) = @_; + # FIXME: handle fatal error with exception + $_->SUPER::delete for @{ $r->objects || [] }; +# $self->dbi_commit; + $r->objects( [ $self->retrieve_all ] ); + $r->{template} = "list"; + $self->list($r); +} + +=head2 search + +Deprecated searching method - use do_search instead. + +=head2 do_search + +This action method searches for database records, it replaces +the, now deprecated, search method previously provided. + +=cut + +sub search : Exported { + my $self = shift; + my ($sub) = (caller(1))[3]; + # So subclasses can still send search down ... + if ($sub =~ /^(.+)::([^:]+)$/) { + return ($1 ne "Maypole::Model::Base" && $2 ne "search") ? + $self->SUPER::search(@_) : $self->do_search(@_); + } else { + $self->SUPER::search(@_); + } +} + +sub do_search : Exported { + my ( $self, $r ) = @_; + my %fields = map { $_ => 1 } $self->columns; + my $oper = "like"; # For now + my %params = %{ $r->{params} }; + my %values = map { $_ => { $oper, $params{$_} } } + grep { defined $params{$_} && length ($params{$_}) && $fields{$_} } + keys %params; + + $r->template("list"); + if ( !%values ) { return $self->list($r) } + my $order = $self->order($r); + $self = $self->do_pager($r); + + # FIXME: use pager info to get slice of iterator instead of all the objects as array + + $r->objects( + [ + $self->search_where( + \%values, ( $order ? { order_by => $order } : () ) + ) + ] + ); + $r->{template_args}{search} = 1; +} + +=head2 list + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=cut + +sub list : Exported { + my ( $self, $r ) = @_; + my $order = $self->order($r); + $self = $self->do_pager($r); + if ($order) { + $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); + } + else { + $r->objects( [ $self->retrieve_all ] ); + } +} + +############################################################################### +# Helper methods + +=head1 Helper Methods + + +=head2 adopt + +This class method is passed the name of a model class that represents a table +and allows the master model class to do any set-up required. + +=cut + +sub adopt { + my ( $self, $child ) = @_; + $child->autoupdate(1); + if ( my $col = $child->stringify_column ) { + $child->columns( Stringify => $col ); + } +} + + +=head2 related + +This method returns a list of has-many accessors. A brewery has many +beers, so C needs to return C. + +=cut + +sub related { + my ( $self, $r ) = @_; + return keys %{ $self->meta_info('has_many') || {} }; +} + + +=head2 related_class + +Given an accessor name as a method, this function returns the class this accessor returns. + +=cut + +sub related_class { + my ( $self, $r, $accessor ) = @_; + my $meta = $self->meta_info; + my @rels = keys %$meta; + my $related; + foreach (@rels) { + $related = $meta->{$_}{$accessor}; + last if $related; + } + return unless $related; + + my $mapping = $related->{args}->{mapping}; + if ( $mapping and @$mapping ) { + return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; + } + else { + return $related->{foreign_class}; + } + } + +=head2 search_columns + + $class->search_columns; + +Returns a list of columns suitable for searching - used in factory templates, over-ridden in +classes. Provides same list as display_columns unless over-ridden. + +=cut + +sub search_columns { + my $class = shift; + return $class->display_columns; +} + + +=head2 related_meta + + $class->related_meta($col); + +Returns the hash ref of relationship meta info for a given column. + +=cut + +sub related_meta { + my ($self,$r, $accssr) = @_; + $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; + my $class_meta = $self->meta_info; + if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } + keys %$class_meta) + { return $class_meta->{$rel_type}->{$accssr} }; +} + + + +=head2 stringify_column + + Returns the name of the column to use when stringifying + and object. + +=cut + +sub stringify_column { + my $class = shift; + return ( + $class->columns("Stringify"), + ( grep { /^(name|title)$/i } $class->columns ), + ( grep { /(name|title)/i } $class->columns ), + ( grep { !/id$/i } $class->primary_columns ), + )[0]; +} + +=head2 do_pager + + Sets the pager template argument ($r->{template_args}{pager}) + to a Class::DBI::Pager object based on the rows_per_page + value set in the configuration of the application. + + This pager is used via the pager macro in TT Templates, and + is also accessible via Mason. + +=cut + +sub do_pager { + my ( $self, $r ) = @_; + if ( my $rows = $r->config->rows_per_page ) { + return $r->{template_args}{pager} = + $self->pager( $rows, $r->query->{page} ); + } + else { return $self } +} + + +=head2 order + + Returns the SQL order syntax based on the order parameter passed + to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'. + + $sql .= $self->order($r); + + If the order column is not a column of this table, + or an order argument is not passed, then the return value is undefined. + + Note: the returned value does not start with a space. + +=cut + +sub order { + my ( $self, $r ) = @_; + my %ok_columns = map { $_ => 1 } $self->columns; + my $q = $r->query; + my $order = $q->{order}; + return unless $order and $ok_columns{$order}; + $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc'; + return $order; +} + + +=head2 fetch_objects + +Returns 1 or more objects of the given class when provided with the request + +=cut + +sub fetch_objects { + my ($class, $r)=@_; + my @pcs = $class->primary_columns; + if ( $#pcs ) { + my %pks; + @pks{@pcs}=(@{$r->{args}}); + return $class->retrieve( %pks ); + } + return $class->retrieve( $r->{args}->[0] ); +} + + +=head2 _isa_class + +Private method to return the class a column +belongs to that was inherited by an is_a relationship. +This should probably be public but need to think of API + +=cut + +sub _isa_class { + my ($class, $col) = @_; + $class->_croak( "Need a column for _isa_class." ) unless $col; + my $isaclass; + my $isa = $class->meta_info("is_a") || {}; + foreach ( keys %$isa ) { + $isaclass = $isa->{$_}->foreign_class; + return $isaclass if ($isaclass->find_column($col)); + } + return; # col not in a is_a class +} + + +# Thanks to dave baird -- form builder for these private functions +# sub _column_info { +sub _column_info { + my $self = shift; + my $dbh = $self->db_Main; + + my $meta; # The info we are after + my ($catalog, $schema) = (undef, undef); + # Dave is suspicious this (above undefs) could + # break things if driver useses this info + + my $original_metadata; + # '%' is a search pattern for columns - matches all columns + if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) { + $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr; + $self->COLUMN_INFO ($self->_hash_type_meta( $sth )); + } else { + $self->COLUMN_INFO ($self->_hash_typeless_meta( )); + } + + return $self->COLUMN_INFO; +} + +sub _hash_type_meta { + my ($self, $sth) = @_; + my $meta; + while ( my $row = $sth->fetchrow_hashref ) { + my $colname = $row->{COLUMN_NAME} || $row->{column_name}; + + # required / nullable + $meta->{$colname}{nullable} = $row->{NULLABLE}; + $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0; + + # default + if (defined $row->{COLUMN_DEF}) { + my $default = $row->{COLUMN_DEF}; + $default =~ s/['"]?(.*?)['"]?::.*$/$1/; + $meta->{$colname}{default} = $default; + }else { + $meta->{$colname}{default} = ''; + } + + # type + my $type = $row->{mysql_type_name} || $row->{type}; + unless ($type) { + $type = $row->{TYPE_NAME}; + if ($row->{COLUMN_SIZE}) { + $type .= "($row->{COLUMN_SIZE})"; + } + } + $type =~ s/['"]?(.*)['"]?::.*$/$1/; + # Bool if tinyint + if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) { + $type = 'BOOL'; + } + $meta->{$colname}{type} = $type; + + # order + $meta->{$colname}{position} = $row->{ORDINAL_POSITION} + } + return $meta; +} + +# typeless db e.g. sqlite +sub _hash_typeless_meta { + my ( $self ) = @_; + + $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' ) + unless $self->can( 'sql_fb_meta_dummy' ); + + my $sth = $self->sql_fb_meta_dummy; + + $sth->execute or die "Error executing column info: " . $sth->errstr;; + + # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes + my $cols = $sth->{NAME}; + my $types = $sth->{TYPE}; + # my $sizes = $sth->{PRECISION}; # empty + # my $nulls = $sth->{NULLABLE}; # empty + + # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to + $sth->finish; + + my $order = 0; + my $meta; + foreach my $col ( @$cols ) { + my $col_meta; + $col_meta->{nullable} = 1; + $col_meta->{required} = 0; + $col_meta->{default} = ''; + $col_meta->{position} = $order++; + # type_name is taken literally from the schema, but is not actually used by sqlite, + # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc. + my $type = shift( @$types ); + $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ; + $meta->{$col} = $col_meta; + } + return $meta; +} + +=head2 column_type + + my $type = $class->column_type('column_name'); + +This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.) +For now, it returns "BOOL" for tinyints. + +TODO :: TEST with enums + +=cut + +sub column_type { + my $class = shift; + my $colname = shift or die "Need a column for column_type"; + $class->_column_info() unless (ref $class->COLUMN_INFO); + + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_type($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{type}; +} + +=head2 required_columns + + Accessor to get/set required columns for forms, validation, etc. + + Returns list of required columns. Accepts an array ref of column names. + + $class->required_columns([qw/foo bar baz/]); + + Allows you to specify the required columns for a class, over-riding any + assumptions and guesses made by Maypole. + + Any columns specified as required will no longer be 'nullable' or optional, and + any columns not specified as 'required' will be 'nullable' or optional. + + The default for a column is nullable, or whatever is discovered from database + schema. + + Use this instead of $config->{$table}{required_cols} + + Note : you need to setup the model class before calling this method. + +=cut + +sub required_columns { + my ($class, $columns) = @_; + $class->_column_info() unless (ref $class->COLUMN_INFO); + my $column_info = $class->COLUMN_INFO; + + if ($columns) { + # get the previously required columns + my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info); + + # update each specified column as required + foreach my $colname ( @$columns ) { + # handle C::DBI::Rel::IsA + if ($class->_isa_class($colname)) { + $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1 + unless ($class->_isa_class($colname)->column_required); + next; + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + next; + } + $column_info->{$colname}{required} = 1; + delete $previously_required{$colname}; + } + + # no longer require any columns not specified + foreach my $colname ( keys %previously_required ) { + $column_info->{$colname}{required} = 0; + $column_info->{$colname}{nullable} = 1; + } + + # update column metadata + $class->COLUMN_INFO($column_info); + } + + return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ; +} + +=head2 column_required + + Returns true if a column is required + + my $required = $class->column_required($column_name); + + Columns can be required by the application but not the database, but not the other way around, + hence there is also a column_nullable method which will tell you if the column is nullable + within the database itself. + +=cut + +sub column_required { + my ($class, $colname) = @_; + $colname or $class->_croak( "Need a column for column_required" ); + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_required($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return 0; +} + +=head2 column_nullable + + Returns true if a column can be NULL within the underlying database and false if not. + + my $nullable = $class->column_nullable($column_name); + + Any columns that are not nullable will automatically be specified as required, you can + also specify nullable columns as required within your application. + + It is recomended you use column_required rather than column_nullable within your + application, this method is more useful if extending the model or handling your own + validation. + +=cut + +sub column_nullable { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_nullable" ); + + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_nullable($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return 0; +} + +=head2 column_default + +Returns default value for column or the empty string. +Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times +have '' returned. + +=cut + +sub column_default { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_default"); + $class->_column_info() unless (ref $class->COLUMN_INFO); + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_default($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + + return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return; +} + +=head2 get_classmetadata + +Gets class meta data *excluding cgi input* for the passed in class or the +calling class. *NOTE* excludes cgi inputs. This method is handy to call from +templates when you need some metadata for a related class. + +=cut + +sub get_classmetadata { + my ($self, $class) = @_; # class is class we want data for + $class ||= $self; + $class = ref $class || $class; + + my %res; + $res{name} = $class; + $res{colnames} = {$class->column_names}; + $res{columns} = [$class->display_columns]; + $res{list_columns} = [$class->list_columns]; + $res{moniker} = $class->moniker; + $res{plural} = $class->plural_moniker; + $res{table} = $class->table; + $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ; + return \%res; +} + + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +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 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Maypole/Model/CDBI/DFV.pm b/lib/Maypole/Model/CDBI/DFV.pm new file mode 100644 index 0000000..5aa0e9a --- /dev/null +++ b/lib/Maypole/Model/CDBI/DFV.pm @@ -0,0 +1,361 @@ +package Maypole::Model::CDBI::DFV; +use strict; + +=head1 NAME + +Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole. + +=head1 SYNOPSIS + + package Foo; + use 'Maypole::Application'; + + Foo->config->model("Maypole::Model::CDBI::DFV"); + Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]); + + # Look ma, no untainting + + sub Foo::SomeTable::SomeAction : Exported { + + . . . + + } + +=head1 DESCRIPTION + +This module allows you to use Maypole with previously set-up +L classes that use Class::DBI::DFV; + +Simply call C with a list reference of the classes you're going to use, +and Maypole will work out the tables and set up the inheritance relationships +as normal. + +Better still, it will also set use your DFV profile to validate input instead +of CGI::Untaint. For teh win!! + +=cut + +use Data::FormValidator; +use Data::Dumper; + +use Maypole::Config; +use Maypole::Model::CDBI::AsForm; + +use base qw(Maypole::Model::CDBI::Base); + +Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO)); + +=head1 METHODS + +=head2 setup + + This method is inherited from Maypole::Model::Base and calls setup_database, + which uses Class::DBI::Loader to create and load Class::DBI classes from + the given database schema. + +=head2 setup_database + + This method loads the model classes for the application + +=cut + +sub setup_database { + my ( $self, $config, $namespace, $classes ) = @_; + $config->{classes} = $classes; + foreach my $class (@$classes) { + $namespace->load_model_subclass($class); + } + $namespace->model_classes_loaded(1); + $config->{table_to_class} = { map { $_->table => $_ } @$classes }; + $config->{tables} = [ keys %{ $config->{table_to_class} } ]; +} + +=head2 class_of + + returns class for given table + +=cut + +sub class_of { + my ( $self, $r, $table ) = @_; + return $r->config->{table_to_class}->{$table}; +} + +=head2 adopt + +This class method is passed the name of a model class that represensts a table +and allows the master model class to do any set-up required. + +=cut + +sub adopt { + my ( $self, $child ) = @_; + if ( my $col = $child->stringify_column ) { + $child->columns( Stringify => $col ); + } +} + +=head2 check_params + + Checks parameters against the DFV profile for the class, returns the results + of DFV's check. + + my $dfv_results = __PACKAGE__->check_params($r->params); + +=cut + +sub check_params { + my ($class,$params) = @_; + return Data::FormValidator->check($params, $class->dfv_profile); +} + + +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +Inherited from L except do_edit (below) + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=cut + +sub do_edit : Exported { + my ($class, $r, $obj) = @_; + + my $config = $r->config; + my $table = $r->table; + + # handle cancel button hit + if ( $r->params->{cancel} ) { + $r->template("list"); + $r->objects( [$class->retrieve_all] ); + return; + } + + + my $errors; + if ($obj) { + ($obj,$errors) = $class->_do_update($r,$obj); + } else { + ($obj,$errors) = $class->_do_create($r); + } + + # handle errors, if none, proceed to view the newly created/updated object + if (ref $errors) { + # pass errors to template + $r->template_args->{errors} = $errors; + # Set it up as it was: + $r->template_args->{cgi_params} = $r->params; + $r->template("edit"); + } else { + $r->template("view"); + } + + $r->objects( $obj ? [$obj] : []); +} + +sub _do_update { + my ($class,$r,$obj) = @_; + my $errors; + my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile); + + # handle dfv errors + if ( $dfv_results->has_missing ) { # missing fields + foreach my $field ( $dfv_results->missing ) { + $errors->{$field} = "$field is required"; + } + } + if ( $dfv_results->has_invalid ) { # Print the name of invalid fields + foreach my $field ( $dfv_results->invalid ) { + $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field ); + } + } + + + my $this_class_params = {}; + + + # NG changes start here. + # Code below fails to handle multi col PKs + my @pks = $class->columns('Primary'); + + foreach my $param ( $class->columns ) { + # next if ($param eq $class->columns('Primary')); + next if grep {/^${param}$/} @pks; + + my $value = $r->params->{$param}; + next unless (defined $value); + $this_class_params->{$param} = ( $value eq '' ) ? undef : $value; + } + + # update or make other related (must_have, might_have, has_many etc ) + unless ($errors) { + foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) { + # get related object if it exists + my $rel_meta = $class->related_meta('r',$accssr); + if (!$rel_meta) { + $r->warn("[_do_update] No relationship for $accssr in " . ref($class)); + next; + } + + my $rel_type = $rel_meta->{name}; + my $fclass = $rel_meta->{foreign_class}; + my ($rel_obj,$errs); + $rel_obj = $fclass->retrieve($r->params->{$accssr}); + # update or create related object + ($rel_obj, $errs) = ($rel_obj) + ? $fclass->_do_update($r, $rel_obj) + : $obj->_create_related($accssr, $r->params); + $errors->{$accssr} = $errs if ($errs); + } + } + + unless ($errors) { + $obj->set( %$this_class_params ); + $obj->update; + } + + return ($obj,$errors); +} + +sub _do_create { + my ($class,$r) = @_; + my $errors; + + my $this_class_params = {}; + foreach my $param ( $class->columns ) { + next if ($param eq $class->columns('Primary')); + my $value = $r->params->{$param}; + next unless (defined $value); + $this_class_params->{$param} = ( $value eq '' ) ? undef : $value; + } + + my $obj; + + my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile); + if ($dfv_results->success) { + $obj = $class->create($this_class_params); + } else { + # handle dfv errors + if ( $dfv_results->has_missing ) { # missing fields + foreach my $field ( $dfv_results->missing ) { + $errors->{$field} = "$field is required"; + } + } + if ( $dfv_results->has_invalid ) { # Print the name of invalid fields + foreach my $field ( $dfv_results->invalid ) { + $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field ); + } + } + } + + # Make other related (must_have, might_have, has_many etc ) + unless ($errors) { + foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) { + my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr}); + $errors->{$accssr} = $errs if ($errs); + } + } + return ($obj,$errors); +} + + +sub _create_related { + # self is object or class, accssr is accssr to relationship, params are + # data for relobject, and created is the array ref to store objs + my ( $self, $accssr, $params ) = @_; + $self->_croak ("Can't make related object without a parent $self object") unless (ref $self); + my $created = []; + my $rel_meta = $self->related_meta('r',$accssr); + if (!$rel_meta) { + $self->_carp("[_create_related] No relationship for $accssr in " . ref($self)); + return; + } + + my $rel_type = $rel_meta->{name}; + my $fclass = $rel_meta->{foreign_class}; + + my ($rel, $errs); + + # Set up params for might_have, has_many, etc + if ($rel_type ne 'has_own' and $rel_type ne 'has_a') { + # Foreign Key meta data not very standardized in CDBI + my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column}; + unless ($fkey) { die " Could not determine foreign key for $fclass"; } + my %data = (%$params, $fkey => $self->id); + %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} ); + ($rel, $errs) = $fclass->_do_create(\%data); + } + else { + ($rel, $errs) = $fclass->_do_create($params); + unless ($errs) { + $self->$accssr($rel->id); + $self->update; + } + } + return ($rel, $errs); +} + + +=head2 do_delete + +Inherited from Maypole::Model::CDBI::Base. + +This action deletes records + +=head2 do_search + +Inherited from Maypole::Model::CDBI::Base. + +This action method searches for database records. + +=head2 list + +Inherited from Maypole::Model::CDBI::Base. + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=cut + +sub _column_info { + my $class = shift; + + # get COLUMN INFO from DB + $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO); + + # update with required columns from DFV Profile + my $profile = $class->dfv_profile; + $class->required_columns($profile->{required}); + + return $class->COLUMN_INFO; +} + + + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Aaron Trevena. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + +1; + + diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm index 6cb95a0..217570a 100644 --- a/lib/Maypole/Model/CDBI/FromCGI.pm +++ b/lib/Maypole/Model/CDBI/FromCGI.pm @@ -101,8 +101,6 @@ Returns errors that ocurred during an operation. sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } } - - =head2 create_from_cgi Based on the same method in Class::DBI::FromCGI. @@ -418,35 +416,17 @@ sub _do_create_all { foreach (keys %$validated) { $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH'; } - # Make has_own/a rel type objects and put id in parent's data hash -# foreach $accssr (keys %related) { -# my $rel_meta = $self->related_meta('r', $accssr); -# $self->_croak("No relationship found for $accssr to $class.") -# unless $rel_meta; -# my $rel_type = $rel_meta->{name}; -# if ($rel_type =~ /(^has_own$|^has_a$)/) { -# my $fclass= $rel_meta->{foreign_class}; -# my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr}); -# # put id in parent's data hash -# if (not keys %$errs) { -# $validated->{$accssr} = $rel_obj->id; -# } else { -# $errors->{$accssr} = $errs; -# } -# delete $related{$accssr}; # done with this -# } -# } # Make main object -- base case #warn "\n*** validated data is " . Dumper($validated). "***\n"; my $me_obj = eval { $self->create($validated) }; if ($@) { - warn "Just failed making a " . $self. " FATAL Error is $@" - if (eval{$self->model_debug}); + warn "Just failed making a " . $self. " FATAL Error is $@" + if (eval{$self->model_debug}); $errors->{FATAL} = $@; return (undef, $errors); } - + if (eval{$self->model_debug}) { if ($me_obj) { warn "Just made a $self : $me_obj ( " . $me_obj->id . ")"; @@ -460,7 +440,7 @@ sub _do_create_all { my ($rel_obj, $errs) = $me_obj->_create_related($accssr, $related{$accssr}); $errors->{$accssr} = $errs if $errs; - + } #warn "Errors are " . Dumper($errors); @@ -524,43 +504,44 @@ sub _do_update_all { # If no errors, then undef in that slot. sub _create_related { - # self is object or class, accssr is accssr to relationship, params are - # data for relobject, and created is the array ref to store objs we - # create (optional). - my ( $self, $accssr, $params, $created ) = @_; - $self->_croak ("Can't make related object without a parent $self object") - unless ref $self; - $created ||= []; - my $rel_meta = $self->related_meta('r',$accssr); + # self is object or class, accssr is accssr to relationship, params are + # data for relobject, and created is the array ref to store objs we + # create (optional). + my ( $self, $accssr, $params, $created ) = @_; + $self->_croak ("Can't make related object without a parent $self object") + unless ref $self; + $created ||= []; + my $rel_meta = $self->related_meta('r',$accssr); if (!$rel_meta) { - $self->_croak("No relationship for $accssr in " . ref($self)); - } - my $rel_type = $rel_meta->{name}; - my $fclass = $rel_meta->{foreign_class}; - #warn " Dumper of meta is " . Dumper($rel_meta); - + $self->_carp("[_create_related] No relationship for $accssr in " . ref($self)); + return; + } + my $rel_type = $rel_meta->{name}; + my $fclass = $rel_meta->{foreign_class}; + #warn " Dumper of meta is " . Dumper($rel_meta); - my ($rel, $errs); - # Set up params for might_have, has_many, etc - if ($rel_type ne 'has_own' and $rel_type ne 'has_a') { + my ($rel, $errs); - # Foreign Key meta data not very standardized in CDBI - my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column}; - unless ($fkey) { die " Could not determine foreign key for $fclass"; } - my %data = (%$params, $fkey => $self->id); - %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} ); - #warn "Data is " . Dumper(\%data); - ($rel, $errs) = $fclass->_do_create_all(\%data, $created); - } - else { - ($rel, $errs) = $fclass->_do_create_all($params, $created); - unless ($errs) { - $self->$accssr($rel->id); - $self->update; - } + # Set up params for might_have, has_many, etc + if ($rel_type ne 'has_own' and $rel_type ne 'has_a') { + + # Foreign Key meta data not very standardized in CDBI + my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column}; + unless ($fkey) { die " Could not determine foreign key for $fclass"; } + my %data = (%$params, $fkey => $self->id); + %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} ); + #warn "Data is " . Dumper(\%data); + ($rel, $errs) = $fclass->_do_create_all(\%data, $created); + } + else { + ($rel, $errs) = $fclass->_do_create_all($params, $created); + unless ($errs) { + $self->$accssr($rel->id); + $self->update; } - return ($rel, $errs); + } + return ($rel, $errs); } diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm index 3c3296a..4398fac 100644 --- a/lib/Maypole/Model/CDBI/Plain.pm +++ b/lib/Maypole/Model/CDBI/Plain.pm @@ -1,10 +1,6 @@ package Maypole::Model::CDBI::Plain; -use Maypole::Config; -use base 'Maypole::Model::CDBI'; use strict; -Maypole::Config->mk_accessors(qw(table_to_class)); - =head1 NAME Maypole::Model::CDBI::Plain - Class::DBI model without ::Loader @@ -36,8 +32,61 @@ L classes; simply call C with a list reference of the classes you're going to use, and Maypole will work out the tables and set up the inheritance relationships as normal. +=cut + +use Maypole::Config; +use base 'Maypole::Model::CDBI::Base'; + +use Maypole::Model::CDBI::AsForm; +use Maypole::Model::CDBI::FromCGI; +use CGI::Untaint::Maypole; + =head1 METHODS +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +Inherited from L + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=head2 do_delete + +Inherited from Maypole::Model::CDBI::Base. + +This action deletes records + +=head2 do_search + +Inherited from Maypole::Model::CDBI::Base. + +This action method searches for database records. + +=head2 list + +Inherited from Maypole::Model::CDBI::Base. + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=head1 Helper Methods + +=head2 Untainter + +Set the class you use to untaint and validate form data +Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint + +=cut + +sub Untainter { 'CGI::Untaint::Maypole' }; + =head2 setup This method is inherited from Maypole::Model::Base and calls setup_database, @@ -50,8 +99,6 @@ tables and set up the inheritance relationships as normal. =cut - - sub setup_database { my ( $self, $config, $namespace, $classes ) = @_; $config->{classes} = $classes; diff --git a/lib/Maypole/View/Base.pm b/lib/Maypole/View/Base.pm index 5a99580..9863e15 100644 --- a/lib/Maypole/View/Base.pm +++ b/lib/Maypole/View/Base.pm @@ -14,24 +14,23 @@ sub paths { $root = [ $root ]; } my @output = (); + my $i = 0; foreach my $path (@$root) { - push(@output, $path); push(@output, ( $r->model_class && File::Spec->catdir( $path, $r->model_class->table ) ) ); - push(@output, File::Spec->catdir( $path, "custom" )); - push(@output, File::Spec->catdir( $path, "factory" )); + push(@output, File::Spec->catdir( $path, "custom" )) unless ($i); + push(@output, $path); + push(@output, File::Spec->catdir( $path, "factory" )) unless ($i); + $i = 1; } - return @output; + return grep( $_, @output); } - - - sub vars { my ( $self, $r ) = @_; my $class = $r->model_class; @@ -50,14 +49,14 @@ sub vars { my $classmeta = $r->template_args->{classmetadata} ||= {}; $classmeta->{name} ||= $class; $classmeta->{table} ||= $class->table; - $classmeta->{columns} ||= [ $class->display_columns ]; - $classmeta->{list_columns} ||= [ $class->list_columns ]; - $classmeta->{colnames} ||= { $class->column_names }; + $classmeta->{columns} ||= [ $class->display_columns ] if ($class->can('display_columns')); + $classmeta->{list_columns} ||= [ $class->list_columns ] if ($class->can('list_columns')); + $classmeta->{colnames} ||= { $class->column_names } if ($class->can('column_names')); $classmeta->{related_accessors} ||= [ $class->related($r) ]; $classmeta->{moniker} ||= $class->moniker; $classmeta->{plural} ||= $class->plural_moniker; - $classmeta->{cgi} ||= { $class->to_cgi }; - $classmeta->{stringify_column} ||= $class->stringify_column; + $classmeta->{cgi} ||= { $class->to_cgi } if ($r->build_form_elements && $class->can('to_cgi')); + $classmeta->{stringify_column} ||= $class->stringify_column if ($class->can('stringify_column')); # User-friendliness facility for custom template writers. if ( @{ $r->objects || [] } > 1 ) { diff --git a/lib/Maypole/View/TT.pm b/lib/Maypole/View/TT.pm index 2d1d60f..c966a7d 100644 --- a/lib/Maypole/View/TT.pm +++ b/lib/Maypole/View/TT.pm @@ -8,7 +8,7 @@ use Template::Constants qw( :all ); our $error_template; { local $/; $error_template = ; } -our $VERSION = '2.111'; +our $VERSION = '2.12'; my $debug_flags = DEBUG_ON; @@ -21,6 +21,8 @@ sub template { if ($r->debug) { $view_options->{DEBUG} = $debug_flags; } + + $view_options->{POST_CHOMP} = 1 unless (exists $view_options->{POST_CHOMP}); $self->{provider} = Template::Provider->new($view_options); $self->{tt} = Template->new({ %$view_options, diff --git a/lib/Maypole/templates/factory/edit b/lib/Maypole/templates/factory/edit index 3b0aca6..bac8c6d 100644 --- a/lib/Maypole/templates/factory/edit +++ b/lib/Maypole/templates/factory/edit @@ -23,12 +23,12 @@ form similar to L but with the current values filled in. Edit [% object.name %] [% FOR col = classmetadata.columns; NEXT IF col == "id" OR col == classmetadata.table _ "_id"; - '"; - IF errors.$col; + SET col_label = classmetadata.colnames.$col; %] + + [% IF errors.$col; ''; errors.$col;''; + ELSIF errors.$col_label; + ''; errors.$col_label;''; END; END %] diff --git a/lib/Maypole/templates/factory/header b/lib/Maypole/templates/factory/header index ba0b190..a537493 100644 --- a/lib/Maypole/templates/factory/header +++ b/lib/Maypole/templates/factory/header @@ -10,7 +10,7 @@ - +
diff --git a/lib/Maypole/templates/factory/list b/lib/Maypole/templates/factory/list index 9abbc01..8b9052e 100644 --- a/lib/Maypole/templates/factory/list +++ b/lib/Maypole/templates/factory/list @@ -24,7 +24,7 @@ SET additional = additional _ "&" _ name _ "=" _ request.params.$name; - SET action = "search"; + SET action = "do_search"; END; END; USE model_obj = Class request.model_class; diff --git a/lib/Maypole/templates/factory/macros b/lib/Maypole/templates/factory/macros index 8267d92..ddaeae1 100644 --- a/lib/Maypole/templates/factory/macros +++ b/lib/Maypole/templates/factory/macros @@ -10,12 +10,20 @@ system. This creates an to a command in the Apache::MVC system by catenating the base URL, table, command, and any arguments. +arguments are table, command, additional, label, target. + +target specifies a target for the link if provided. + #%] [% -MACRO link(table, command, additional, label) BLOCK; +MACRO link(table, command, additional, label, target) BLOCK; SET lnk = base _ "/" _ table _ "/" _ command _ "/" _ additional; lnk = lnk | uri ; - ''; + IF target ; + ''; + ELSE; + ''; + END; label | html; ""; END; @@ -63,8 +71,7 @@ for some. ELSIF col == classmetadata.stringify_column; maybe_link_view(item); ELSIF col_obj; # its a real column - accessor = item.accessor_name_for(col_obj) || - item.accessor_name(col_obj); # deprecated in cdbi + accessor = item.accessor_name_for(col_obj) || item.accessor_name(col_obj); # deprecated in cdbi maybe_link_view(item.$accessor); ELSE; item.$col; diff --git a/lib/Maypole/templates/factory/pager b/lib/Maypole/templates/factory/pager index 78c89fd..cd03a4f 100644 --- a/lib/Maypole/templates/factory/pager +++ b/lib/Maypole/templates/factory/pager @@ -7,42 +7,72 @@ and search views. It expects a C template argument which responds to the L interface. #%] + +[% BLOCK pager_link; %] [% -IF pager AND pager.first_page != pager.last_page; + SET label = page_num; + SET args = "?page=" _ page_num; + SET args = args _ "&order=" _ request.params.order IF request.params.order; + SET args = args _ "&o2=desc" IF request.params.o2 == "desc"; + FOR col = pager_columns; + IF request.params.$col; + SET args = args _ "&" _ col _ "=" _ request.params.$col; + SET action = "search"; + END; + END; + link(classmetadata.table, action, args, label); %] -

Pages: +[% END; %] + + +[% IF pager %] +

+Page +[% IF pager.first_page == pager.last_page; %] +1 of 1 +[% ELSE %] +[% pager.current_page %] of [% pager.last_page %]   |   [% UNLESS pager_action; SET pager_action = request.action; END; - SET begin_page = pager.current_page - 10; + UNLESS pager_columns; + SET pager_columns = classmetadata.columns.list; + END; + + SET end_page = pager.current_page + 5; + SET begin_page = pager.current_page - 5; IF begin_page < 1; - SET begin_page = pager.first_page; + SET begin_page = 1; + SET end_page = 10; END; - SET end_page = pager.current_page + 10; + IF pager.last_page < end_page; SET end_page = pager.last_page; + IF (end_page - 10) > 1; + begin_page = end_page - 10; + END; + END; + + IF begin_page > 1; + PROCESS pager_link page_num = 1, action = pager_action; END; + FOREACH num = [begin_page .. end_page]; IF num == pager.current_page; ""; num; ""; ELSE; - SET label = num; - SET args = "?page=" _ num; - SET args = args _ "&order=" _ request.params.order - IF request.params.order; - SET args = args _ "&o2=desc" - IF request.params.o2 == "desc"; - FOR col = classmetadata.columns.list; - IF request.params.$col; - SET args = args _ "&" _ col _ "=" _ request.params.$col; - SET action = "search"; - END; - END; - link(classmetadata.table, pager_action, args, label); + PROCESS pager_link page_num = num, action = pager_action; END; END; + + IF end_page < pager.last_page; + PROCESS pager_link page_num = pager.last_page, action = pager_action; + END; + +END; %]

[% END %] + diff --git a/lib/Maypole/templates/factory/search_form b/lib/Maypole/templates/factory/search_form index d10101e..5694f7d 100644 --- a/lib/Maypole/templates/factory/search_form +++ b/lib/Maypole/templates/factory/search_form @@ -1,22 +1,20 @@ + + + + + diff --git a/t/00compile.t b/t/00compile.t new file mode 100644 index 0000000..c040443 --- /dev/null +++ b/t/00compile.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 15; + +use_ok('Maypole::Application'); +use_ok('Maypole::Constants'); +use_ok('Maypole::Config'); +use_ok('Maypole::Headers'); +use_ok('Maypole::Session'); +use_ok('Maypole'); +use_ok('Maypole::Model::Base'); +use_ok('Maypole::Model::CDBI::Base'); +use_ok('Maypole::Model::CDBI'); +use_ok('Maypole::Model::CDBI::Plain'); +use_ok('Maypole::Model::CDBI::FromCGI'); +use_ok('Maypole::Model::CDBI::AsForm'); + +SKIP: { + eval { require Data::FormValidator; }; + skip 'Data::FormValidator is not installed or does not work', 1 if ($@); + use_ok('Maypole::Model::CDBI::DFV'); +} + +use_ok('Maypole::View::Base'); +use_ok('Maypole::View::TT'); + diff --git a/t/01basics.t b/t/01basics.t index ba7b834..324bb0b 100644 --- a/t/01basics.t +++ b/t/01basics.t @@ -1,6 +1,7 @@ #!/usr/bin/perl -w use Test::More; -use lib 'ex'; # Where BeerDB should live +use Data::Dumper; +use lib 'examples'; # Where BeerDB should live BEGIN { $ENV{BEERDB_DEBUG} = 0; @@ -32,7 +33,12 @@ like(BeerDB->call_url("http://localhost/beerdb"), qr/frontpage/, "Got frontpage, trailing '/' on uri_base but not request"); like(BeerDB->call_url("http://localhost/beerdb/beer/list"), qr/Organic Best/, "Found a beer in the list"); -my (%classdata)=split /\n/, BeerDB->call_url("http://localhost/beerdb/beer/classdata"); + +my $classdata_page = BeerDB->call_url("http://localhost/beerdb/beer/classdata"); +my (%classdata)=split /\n+/, $classdata_page; +#warn $classdata_page; +#warn Dumper(%classdata); + is ($classdata{plural},'beers','classdata.plural'); is ($classdata{moniker},'beer','classdata.moniker'); like ($classdata{cgi},qr/^HTML::Element/,'classdata.cgi'); @@ -48,4 +54,5 @@ is ($classdata{related_accessors},'pubs','classdata.related_accessors'); # test Maypole::load_custom_class() can_ok(BeerDB::Beer => 'fooey'); # defined in BeerDB::Beer can_ok(BeerDB::Beer => 'floob'); # defined in BeerDB::Base -is_deeply( [@BeerDB::Beer::ISA], [qw/Maypole::Model::CDBI Class::DBI::SQLite BeerDB::Base/] ); + +is_deeply( [@BeerDB::Beer::ISA], [qw/Class::DBI::SQLite Maypole::Model::CDBI BeerDB::Base/] ); diff --git a/t/apache_mvc.t b/t/apache_mvc.t index e6a1100..75e1a0a 100644 --- a/t/apache_mvc.t +++ b/t/apache_mvc.t @@ -1,17 +1,22 @@ #!/usr/bin/perl -w use strict; use Test::More; + BEGIN { - if (eval { require Apache::Request }) { + if (eval { require Apache2::RequestRec }) { + $ENV{MOD_PERL_API_VERSION} = 2; + plan tests => 3; + } elsif (eval { require Apache::Request }) { plan tests => 3; } else { - Test::More->import(skip_all =>"Apache::Request is not installed: $@"); + Test::More->import(skip_all =>"Neither Apache2::RequestRec nor Apache::Request is installed: $@"); } } require_ok('Apache::MVC'); ok($Apache::MVC::VERSION, 'defines $VERSION'); ok(Apache::MVC->can('ar'), 'defines an "ar" accessor'); + # defines $VERSION # uses mod_perl # @ISA = 'Maypole' diff --git a/t/db_colinfo.t b/t/db_colinfo.t index 41c95a6..3b20f8d 100755 --- a/t/db_colinfo.t +++ b/t/db_colinfo.t @@ -10,7 +10,7 @@ BEGIN { die "couldn't connect to mysql" unless (@databases); }; warn "error : $@ \n" if ($@); - my $testcount = ($@) ? 45 : 65 ; + my $testcount = ($@) ? 45 : 64 ; plan tests => $testcount; } diff --git a/t/templates/custom/classdata b/t/templates/custom/classdata index d5f60cc..788e2c7 100644 --- a/t/templates/custom/classdata +++ b/t/templates/custom/classdata @@ -1,18 +1,35 @@ name + [% classmetadata.name %] + table + [% classmetadata.table %] + columns + [% classmetadata.columns.join(' ')%] + list_columns + [% classmetadata.list_columns.join(' ') %] + colnames + [% classmetadata.colnames.abv %] + related_accessors + [% classmetadata.related_accessors.join(' ') %] + moniker + [% classmetadata.moniker %] + plural + [% classmetadata.plural %] + cgi + [% classmetadata.cgi.abv%]