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
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
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
META.yml
README
AUTHORS
+t/00compile.t
t/01basics.t
t/01.httpd-basic.t
t/02pod.t
# 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:
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
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,
+++ /dev/null
-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;
+++ /dev/null
-package BeerDB::Base;
-use strict;
-use warnings;
-
-sub floob {}
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-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
-);
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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)
-);
-
-
+++ /dev/null
-[%#
-
-=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; %]
-
-<div id="addnew">
-<form method="post" action="[% base %]/[% classmetadata.table %]/do_edit/">
-<fieldset>
-<legend>Add a new [% config.TABLES.$tbl.singular || tbl | ucfirst | replace('_',' '); %] </legend>
- [% INCLUDE display_inputs; %]
- <input type="submit" name="create" value="create" />
- <input type="hidden" name="__form_id" value="[% request.make_random_id %]" />
-</fieldset>
-</form>
-</div>
+++ /dev/null
-[%#
-
-=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;
- "<h4> $heading </h4>";
- 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;
-%]
-
- <label>
- [% indicator = '';
- SET indicator = '*' IF (required.$col);
- %]
- <span class="field">
- [% indicator _ classmetadata.colnames.$col ||
- col | replace('_',' ') | ucfirst %]
- </span>
- [% elem.as_XML; %]
- </label>
-
- [% IF errors.$col %]
- <span class="error">[% errors.$col | html %]</span>
- [% END %]
-[% END; %]
-
-<!-- Display the differnt component inputs -->
-
-[% 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;
-%]
-
+++ /dev/null
-[%#
-
-=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; "<br>"; 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;
-%]
-
-<label>
- <span class="field">
- [%
- classmetadata.colnames.$field || field | ucfirst | replace('_',' '); %]
- </span>
- [% IF element.tag == "select";
- # set the previous value
- IF cgi_params.exists(field);
- set_selected(element, cgi_params.$field);
- END;
-
- END;
- IF element.tag == "input"; # wipe out any default value
- old_val = element.attr('value', '');
- END;
-
-
- element.as_XML;
- %]
-</label>
-[% END; %]
-
-
+++ /dev/null
-[%#
-
-=head1 edit
-
-This is the edit page. It edits the passed-in object, by displaying a
-form similar to L<addnew> but with the current values filled in.
-
-=cut
-
-#%]
-[% PROCESS macros %]
-[% INCLUDE header %]
-[% INCLUDE title %]
-
-[% IF request.action == 'edit' %]
-[% INCLUDE navbar %]
-[% END %]
-
-[% IF objects.size %]
-<div id="title">Edit a [% classmetadata.moniker %]</div>
-[% FOR item = objects; %]
-<form action="[% base %]/[% item.table %]/do_edit/[% item.id %]" method="post">
-<fieldset>
-<legend>Edit [% item.name %]</legend>
-[% FOR col = classmetadata.columns;
- NEXT IF col == "id" OR col == classmetadata.table _ "_id";
- '<label><span class="field">';
- classmetadata.colnames.$col || col | ucfirst | replace('_',' '); ":</span>";
- item.to_field(col).as_XML;
- "</label>";
- IF errors.$col;
- '<span class="error">'; errors.$col;'</span>';
- END;
- END %]
- <input type="submit" name="edit" value="edit"/>
- <input type="hidden" name="__form_id" value="[% request.make_random_id %]">
- </fieldset></form>
-
- [% END %]
-[% ELSE %]
-
-<div id="addnew">
-<form method="post" action="[% base %]/[% classmetadata.table %]/do_edit/">
-<fieldset>
-<legend>Add a new [% classmetadata.moniker %]</legend>
- [% FOR col = classmetadata.columns %]
- [% NEXT IF col == "id" %]
- <label><span class="field">[% classmetadata.colnames.$col %]</span>
- [%
- SET elem = classmetadata.cgi.$col.clone;
- IF request.action == 'do_edit';
- IF elem.tag == "textarea";
- elem = elem.push_content(request.param(col));
- ELSE;
- elem.attr("value", request.param(col));
- END;
- END;
- elem.as_XML; %]
- </label>
- [% IF errors.$col %]
- <span class="error">[% errors.$col | html %]</span>
- [% END %]
-
- [% END; %]
- <input type="submit" name="create" value="create" />
- <input type="hidden" name="__form_id" value="[% request.make_random_id %]" />
-</fieldset>
-</form>
-</div>
-
-[% END %]
-[% INCLUDE footer %]
+++ /dev/null
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml11.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <title>
- [%
- title || config.application_name ||
- "A poorly configured Maypole application"
- %]
- </title>
- <meta http-equiv="Content-Type" content="text/html; charset=[% request.document_encoding %]" />
- <base href="[% config.uri_base%]"/>
- <link title="Maypole" href="maypole.css" type="text/css" rel="stylesheet" />
- </head>
- <body>
- <div class="content">
+++ /dev/null
-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;
-}
-
+++ /dev/null
-<h3> Class::DBI meta info for [% classmetadata.name %] </h3>
-[%
- USE this = Class(classmetadata.name);
- USE Dumper; Dumper.dump(this.meta_info);
-%]
+++ /dev/null
-<div id="search">
-<form method="get" action="[% base %]/[% classmetadata.table %]/search/">
-<fieldset>
-<legend>Search</legend>
- [% INCLUDE display_search_inputs; %]
- <input type="submit" name="search" value="search"/>
-</fieldset>
-</form>
-</div>
--- /dev/null
+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;
--- /dev/null
+package BeerDB::Base;
+use strict;
+use warnings;
+
+sub floob {}
+
+1;
--- /dev/null
+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;
--- /dev/null
+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
+);
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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)
+);
+
+
--- /dev/null
+[%#
+
+=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; %]
+
+<div id="addnew">
+<form method="post" action="[% base %]/[% classmetadata.table %]/do_edit/">
+<fieldset>
+<legend>Add a new [% config.TABLES.$tbl.singular || tbl | ucfirst | replace('_',' '); %] </legend>
+ [% INCLUDE display_inputs; %]
+ <input type="submit" name="create" value="create" />
+ <input type="hidden" name="__form_id" value="[% request.make_random_id %]" />
+</fieldset>
+</form>
+</div>
--- /dev/null
+[%#
+
+=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;
+ "<h4> $heading </h4>";
+ 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;
+%]
+
+ <label>
+ [% indicator = '';
+ SET indicator = '*' IF (required.$col);
+ %]
+ <span class="field">
+ [% indicator _ classmetadata.colnames.$col ||
+ col | replace('_',' ') | ucfirst %]
+ </span>
+ [% elem.as_XML; %]
+ </label>
+
+ [% IF errors.$col %]
+ <span class="error">[% errors.$col | html %]</span>
+ [% END %]
+[% END; %]
+
+<!-- Display the differnt component inputs -->
+
+[% 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;
+%]
+
--- /dev/null
+[%#
+
+=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; "<br>"; 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;
+%]
+
+<label>
+ <span class="field">
+ [%
+ classmetadata.colnames.$field || field | ucfirst | replace('_',' '); %]
+ </span>
+ [% IF element.tag == "select";
+ # set the previous value
+ IF cgi_params.exists(field);
+ set_selected(element, cgi_params.$field);
+ END;
+
+ END;
+ IF element.tag == "input"; # wipe out any default value
+ old_val = element.attr('value', '');
+ END;
+
+
+ element.as_XML;
+ %]
+</label>
+[% END; %]
+
+
--- /dev/null
+[%#
+
+=head1 edit
+
+This is the edit page. It edits the passed-in object, by displaying a
+form similar to L<addnew> but with the current values filled in.
+
+=cut
+
+#%]
+[% PROCESS macros %]
+[% INCLUDE header %]
+[% INCLUDE title %]
+
+[% IF request.action == 'edit' %]
+[% INCLUDE navbar %]
+[% END %]
+
+[% IF objects.size %]
+<div id="title">Edit a [% classmetadata.moniker %]</div>
+[% FOR item = objects; %]
+<form action="[% base %]/[% item.table %]/do_edit/[% item.id %]" method="post">
+<fieldset>
+<legend>Edit [% item.name %]</legend>
+[% FOR col = classmetadata.columns;
+ NEXT IF col == "id" OR col == classmetadata.table _ "_id";
+ '<label><span class="field">';
+ classmetadata.colnames.$col || col | ucfirst | replace('_',' '); ":</span>";
+ item.to_field(col).as_XML;
+ "</label>";
+ IF errors.$col;
+ '<span class="error">'; errors.$col;'</span>';
+ END;
+ END %]
+ <input type="submit" name="edit" value="edit"/>
+ <input type="hidden" name="__form_id" value="[% request.make_random_id %]">
+ </fieldset></form>
+
+ [% END %]
+[% ELSE %]
+
+<div id="addnew">
+<form method="post" action="[% base %]/[% classmetadata.table %]/do_edit/">
+<fieldset>
+<legend>Add a new [% classmetadata.moniker %]</legend>
+ [% FOR col = classmetadata.columns %]
+ [% NEXT IF col == "id" %]
+ <label><span class="field">[% classmetadata.colnames.$col %]</span>
+ [%
+ SET elem = classmetadata.cgi.$col.clone;
+ IF request.action == 'do_edit';
+ IF elem.tag == "textarea";
+ elem = elem.push_content(request.param(col));
+ ELSE;
+ elem.attr("value", request.param(col));
+ END;
+ END;
+ elem.as_XML; %]
+ </label>
+ [% IF errors.$col %]
+ <span class="error">[% errors.$col | html %]</span>
+ [% END %]
+
+ [% END; %]
+ <input type="submit" name="create" value="create" />
+ <input type="hidden" name="__form_id" value="[% request.make_random_id %]" />
+</fieldset>
+</form>
+</div>
+
+[% END %]
+[% INCLUDE footer %]
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+ [%
+ title || config.application_name ||
+ "A poorly configured Maypole application"
+ %]
+ </title>
+ <meta http-equiv="Content-Type" content="text/html; charset=[% request.document_encoding %]" />
+ <base href="[% config.uri_base%]"/>
+ <link title="Maypole" href="maypole.css" type="text/css" rel="stylesheet" />
+ </head>
+ <body>
+ <div class="content">
--- /dev/null
+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;
+}
+
--- /dev/null
+<h3> Class::DBI meta info for [% classmetadata.name %] </h3>
+[%
+ USE this = Class(classmetadata.name);
+ USE Dumper; Dumper.dump(this.meta_info);
+%]
--- /dev/null
+<div id="search">
+<form method="get" action="[% base %]/[% classmetadata.table %]/search/">
+<fieldset>
+<legend>Search</legend>
+ [% INCLUDE display_search_inputs; %]
+ <input type="submit" name="search" value="search"/>
+</fieldset>
+</form>
+</div>
package Apache::MVC;
-our $VERSION = '2.11';
+our $VERSION = '2.121';
use strict;
use warnings;
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
# 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;
=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}) {
$r->ar->status($status);
$r->ar->headers_out->set('Location' => $redirect_url);
+ $r->output('<html><head><title>redirecting...</title></head><body><h2>redirecting..</h2></body></html>') unless ($r->output);
return OK;
}
+
=item get_protocol
=cut
use Maypole::Headers;
use Maypole::Constants;
-our $VERSION = '2.11';
+our $VERSION = '2.13';
__PACKAGE__->mk_accessors( qw/cgi/ );
=cut
-sub run
-{
- my $self = shift;
- return $self->handler;
+sub run {
+ my $self = shift;
+ my $status = $self->handler;
+ if ($status != OK) {
+ print <<EOT;
+Status: 500 Maypole application error
+Content-Type: text/html
+
+<title>Maypole application error</h1>
+<h1>Maypole application error</h1>
+EOT
+ }
+ return $status;
}
=head1 Implementation
=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
$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);
$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
use base 'CGI::Untaint';
use Carp;
-=head1 NAME
+=head1 NAME
CGI::Untaint::Maypole - Use instead of CGI::Untaint. Based on CGI::Untaint
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:
__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);
# 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());
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;
}
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
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
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 );
This is the main request handling method and calls various methods to handle the
request/response and defines the workflow within Maypole.
-B<Currently undocumented and liable to be refactored without warning>.
-
=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 = (
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;
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. @_");
}
}
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),
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
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;
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;
=cut
-sub parse_path
-{
+sub parse_path {
my ($self) = @_;
# Previous versions unconditionally set table, action and args to whatever
# 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' );
=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<parse_path>. It generates a path to use
=cut
+
sub make_path
{
my $r = shift;
$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;
}
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
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;
=item send_output
+=item warn
+
=back
=cut
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));
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
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:
--- /dev/null
+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<Maypole>
+
+=head1 AUTHOR
+
+Marcus Ramberg, E<lt>marcus@thefeed.no<gt>
+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
--- /dev/null
+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<Maypole::HTTPD>. It's used
+automatically as the frontend by L<Maypole::Application>.
+
+It overrides the following functions in L<CGI::Maypole>:
+
+=over 4
+
+=item get_request
+
+Instantiates a L<CGI> 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<Maypole::HTTPD>
+
+=head1 SEE ALSO
+
+L<Maypole>, L<Maypole::HTTPD>
+
+=cut
variety of customized techniques that make such a system
work.
-=item L<Maypole::Manual::IBuySpy> - Case Study: iBuySpy *
+=item L<Maypole::Manual::BuySpy> - Case Study: iBuySpy *
This is an example of the C<ASP.NET> sample portal application
ported to Maypole. L<http://www.ibuyspy.com> is a fictional
"a pub has beers on handpumps");
1;
-There's a version of this program in the F<ex/> directory in the Maypole
+There's a version of this program in the F<examples/> directory in the Maypole
files that you downloaded in the F<~root/.cpan/> build area.
This defines the C<BeerDB> application.
To set it up as a mod_perl handler, just tell the Apache configuration
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<Request Cookbook|Maypole::Manual::Request> can help to
+L<Request Cookbook|Maypole::Manual::Cookbook> 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...
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<Request Cookbook|Maypole::Manual::Request>,
+briefly in the L<Request Cookbook|Maypole::Manual::Cookbook>,
but now it's time to go into a little more detail about how user
handling is done.
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<Request Cookbook|Maypole::Manual::Request>:
+L<Request Cookbook|Maypole::Manual::Cookbook>:
sub view_picture :Exported {
my ($self, $r) = @_;
<TABLE>
Now we use the "Catching errors in a form" recipe from the
-L<Request Cookbook|Maypole::Manual::Request> and
+L<Request Cookbook|Maypole::Manual::Cookbook> and
write our form template:
<TR><TD>
L<Contents|Maypole::Manual>,
Next L<The Maypole iBuySpy Portal|Maypole::Manual::BuySpy>,
-Previous L<Maypole Request Hacking Cookbook|Maypole::Manual::Request>
+Previous L<Maypole Request Hacking Cookbook|Maypole::Manual::Cookbook>
=head1 Structure of a standard Maypole application\r
\r
A minimal Maypole application (such as the Beer database example from the\r
-L<Maypole> synopsis) consists of a custom driver class (BeerDB.pm), a set of\r
-auto-generated model classes, and a view class:\r
+L<Maypole> synopsis) consists of a custom driver (or controller) class (BeerDB.pm),\r
+a set of auto-generated model classes, and a view class:\r
\r
\r
THE DRIVER\r
pub(); BeerDB::Style\r
beer(); beers();\r
\r
+=head2 Ouch, that's a lot of inheritence!\r
+\r
+Yes, that's a lot of inheritence, at some point in the future - probably Maypole 3.x we\r
+will move to Class::C3\r
+\r
=head2 What about Maypole::Application - loading plugins\r
\r
The main job of L<Maypole::Application> is to insert the plugins into the\r
inserts it into each of these table classes' C<@ISA> ( C<<\r
Class::DBI::<db_driver> >> in the diagrams)..\r
\r
-Next, C<Maypole::setup> B<unshifts> L<Maypole::Model::CDBI> onto the C<@ISA> \r
+Next, C<Maypole::setup> B<pushes> L<Maypole::Model::CDBI> onto the C<@ISA> \r
array of each of these classes. \r
\r
Finally, the relationships among these tables are set up. Either do this\r
1;\r
\r
From Maypole 2.11, this package will be loaded automatically during C<setup()>,\r
-and C<BeerDB2::Maypole::Model> is B<unshifted> onto it's C<@ISA>.\r
+and C<BeerDB2::Maypole::Model> is B<pushed> onto it's C<@ISA>.\r
\r
Configure relationships either in the individual C<OfflineBeer::*> classes, or\r
else all together in C<OfflineBeer> itself i.e. not in the Maypole model. This \r
the Maypole application, and need not know it exists at all.\r
\r
2. Methods defined in the Maypole table classes, override methods defined in the\r
-Offline table classes, because C<BeerDB2::Maypole::Model> was unshifted onto the\r
-beginning of each Maypole table class's C<@ISA>. Perl's depth first,\r
+Offline table classes, because C<BeerDB2::Maypole::Model> was pushed onto the\r
+end of each Maypole table class's C<@ISA>. Perl's depth first,\r
left-to-right method lookup from e.g. C<BeerDB2::Beer> starts in\r
C<BeerDB2::Beer>, then C<BeerDB2::Maypole::Model>, C<Maypole::Model::CDBI>,\r
C<Maypole::Model::Base>, and C<Class::DBI>, before moving on to\r
C<Maypole::Model::CDBI> 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<Maypole::Model::CDBI> 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
L<Contents|Maypole::Manual>,
Next L<Maypole View Classes|Maypole::Manual::View>,
Previous L<Introduction to Maypole|Maypole::Manual::About>
+
+=cut
This provides a paged list of the table suitable for browsing.
-=item C</[table]/search/>
+=item C</[table]/do_search/>
This handles a search query and presents the search results back to the
-F<list> template.
+F<list> template. Previously this was called search, but obviously that
+clashes with a lot of stuff, and that usage is now deprecated.
=back
key. If not, you probably want C<printable>, 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<list> 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
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);
}
+=head2 add_model_superclass
+
+Adds model as superclass to model classes (if necessary)
+
+=cut
+
+sub add_model_superclass { return; }
=head2 method_attrs
1;
+=head1 SEE ALSO
+
+L<Maypole>, L<Maypole::Model::CDBI>.
+
+=head1 AUTHOR
+
+Maypole is currently maintained by Aaron Trevena.
+
+=head1 AUTHOR EMERITUS
+
+Simon Cozens, C<simon#cpan.org>
+
+Simon Flack maintained Maypole from 2.05 to 2.09
+
+Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
package Maypole::Model::CDBI;
use strict;
-use Data::Dumper;
-
=head1 NAME
Maypole::Model::CDBI - Model class based on Class::DBI
=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
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<Maypole::Model::CDBI::Base>
+
=head2 do_edit
If there is an object in C<$r-E<gt>objects>, then it should be edited
The template should be changed to C<view>, or C<edit> 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<list> method fills C<$r-E<gt>objects> 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<BeerDB::Brewery> needs to return C<beers>.
-
-=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,
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<Maypole>, L<Maypole::Model::CDBI::Base>.
-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#cpan.org>
+Simon Flack maintained Maypole from 2.05 to 2.09
-=head2 _isa_class
+Sebastian Riedel, C<sri#oook.de> 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;
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';
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
_options_from_array _options_from_hash
);
-our $VERSION = '.95';
+our $VERSION = '.97';
=head1 NAME
=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])
$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,
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'));
}
=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)
=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)
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
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.
=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;
}
# #############
# 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;
}
=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;
}
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)
=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)
=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
=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;
}
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;
+}
=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;
}
=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
# 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;
}
=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
=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);
+ }
}
=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
=head1 BUGS and QUERIES
Please direct all correspondence regarding this module to:
- Maypole list.
+ Maypole list.
=head1 COPYRIGHT AND LICENSE
--- /dev/null
+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<Class::DBI> 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<Maypole::Model::Base>.
+
+=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-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> 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<list> method fills C<$r-E<gt>objects> 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<BeerDB::Brewery> needs to return C<beers>.
+
+=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<Maypole>, L<Maypole::Model::Base>.
+
+=head1 AUTHOR
+
+Maypole is currently maintained by Aaron Trevena.
+
+=head1 AUTHOR EMERITUS
+
+Simon Cozens, C<simon#cpan.org>
+
+Simon Flack maintained Maypole from 2.05 to 2.09
+
+Sebastian Riedel, C<sri#oook.de> 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;
--- /dev/null
+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<Class::DBI> classes that use Class::DBI::DFV;
+
+Simply call C<setup> 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<Maypole::Model::CDBI::Base> except do_edit (below)
+
+=head2 do_edit
+
+If there is an object in C<$r-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> 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<list> method fills C<$r-E<gt>objects> 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<Maypole::Model::Base>
+
+L<Maypole::Model::CDBI::Base>
+
+=head1 AUTHOR
+
+Aaron Trevena.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
+
+
sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
-
-
=head2 create_from_cgi
Based on the same method in Class::DBI::FromCGI.
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 . ")";
my ($rel_obj, $errs) =
$me_obj->_create_related($accssr, $related{$accssr});
$errors->{$accssr} = $errs if $errs;
-
+
}
#warn "Errors are " . Dumper($errors);
# 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);
}
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
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<Maypole::Model::CDBI::Base>
+
+=head2 do_edit
+
+If there is an object in C<$r-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> 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<list> method fills C<$r-E<gt>objects> 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,
=cut
-
-
sub setup_database {
my ( $self, $config, $namespace, $classes ) = @_;
$config->{classes} = $classes;
$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;
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 ) {
our $error_template;
{ local $/; $error_template = <DATA>; }
-our $VERSION = '2.111';
+our $VERSION = '2.12';
my $debug_flags = DEBUG_ON;
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,
<legend>Edit [% object.name %]</legend>
[% FOR col = classmetadata.columns;
NEXT IF col == "id" OR col == classmetadata.table _ "_id";
- '<label><span class="field">';
- classmetadata.colnames.$col; ":</span>";
- object.to_field(col).as_XML;
- "</label>";
- IF errors.$col;
+ SET col_label = classmetadata.colnames.$col; %]
+ <label><span class="field"> [% col_label %] </span> [% object.to_field(col).as_XML %]</label>
+ [% IF errors.$col;
'<span class="error">'; errors.$col;'</span>';
+ ELSIF errors.$col_label;
+ '<span class="error">'; errors.$col_label;'</span>';
END;
END %]
<input type="submit" name="edit" value="edit"/>
</title>
<meta http-equiv="Content-Type" content="text/html; charset=[% request.document_encoding %]" />
<base href="[% config.uri_base%]"/>
- <link title="Maypole" href="[% config.uri_base %]/maypole.css" type="text/css" rel="stylesheet" />
+ <link title="Maypole" href="[% base %]/maypole.css" type="text/css" rel="stylesheet" />
</head>
<body>
<div class="content">
SET additional =
additional _ "&" _ name _ "=" _
request.params.$name;
- SET action = "search";
+ SET action = "do_search";
END;
END;
USE model_obj = Class request.model_class;
This creates an <A HREF="..."> 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 ;
- '<a href="' _ lnk _ '">';
+ IF target ;
+ '<a href="' _ lnk _ '" target="' _ target _'">';
+ ELSE;
+ '<a href="' _ lnk _ '">';
+ END;
label | html;
"</a>";
END;
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;
to the L<Data::Page> 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);
%]
-<p class="pager">Pages:
+[% END; %]
+
+
+[% IF pager %]
+<p class="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;
"<span class='current-page'>"; num; "</span>";
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;
%]
</p>
[% END %]
+
+
+<!-- ### Search component ### -->
+
<div id="search">
-<form method="get" action="[% base %]/[% classmetadata.moniker %]/search/">
+<form method="get" action="[% base %]/[% classmetadata.moniker %]/do_search/">
<fieldset>
<legend>Search</legend>
- [% FOR col = classmetadata.columns;
- NEXT IF col == "id" OR col == classmetadata.table _ "_id";
- %]
- <label>
- <span class="field">[% classmetadata.colnames.$col; %]</span>
- [% SET element = classmetadata.cgi.$col;
- IF element.tag == "select";
- USE element_maker = Class("HTML::Element");
- SET element = element.unshift_content(
- element_maker.new("option", value," "));
- END;
- element.as_XML; %]
- </label>
- [% END; %]
- <input type="submit" name="search" value="search"/>
- </fieldset>
+[% USE search_class = Class request.model_class; %]
+[% FOR col = search_class.search_columns() %]
+ <label>
+ <span class="field">[% classmetadata.colnames.$col; %]</span>
+ [% SET element = classmetadata.cgi.$col; element.as_XML; %]
+ </label>
+[% END; %]
+<input type="submit" name="search" value="search"/>
+</fieldset>
</form>
</div>
+
+<!-- # Search end -->
--- /dev/null
+#!/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');
+
#!/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;
"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');
# 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/] );
#!/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'
die "couldn't connect to mysql" unless (@databases);
};
warn "error : $@ \n" if ($@);
- my $testcount = ($@) ? 45 : 65 ;
+ my $testcount = ($@) ? 45 : 64 ;
plan tests => $testcount;
}
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%]
projects / maypole.git / commitdiff