From: Aaron Trevena Date: Mon, 9 Oct 2006 11:50:29 +0000 (+0000) Subject: reorganised model inheritance, new test X-Git-Tag: 2.12~47 X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=commitdiff_plain;h=dcc33148f1b562834e16f658e34270f3f581833c reorganised model inheritance, new test git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@527 48953598-375a-da11-a14b-00016c27c3ee --- diff --git a/Changes b/Changes index ae9113a..be240c3 100644 --- a/Changes +++ b/Changes @@ -9,6 +9,8 @@ For information about current developments and future releases, see: Inheritence simpler and nicer and less hacked add_model_superclass method moves @ISA munging into the model new Class::DBI::DFV based model + new test to check everything compiles + Model inheritance re-organised 2.11 Mon 31 July 2006 diff --git a/MANIFEST b/MANIFEST index 8cb44c1..33e8553 100644 --- a/MANIFEST +++ b/MANIFEST @@ -45,6 +45,7 @@ lib/Maypole/Model/CDBI.pm lib/Maypole/Model/CDBI/Plain.pm lib/Maypole/Model/CDBI/AsForm.pm lib/Maypole/Model/CDBI/FromCGI.pm +lib/Maypole/Model/CDBI/Base.pm lib/Maypole/Model/CDBI/DFV.pm lib/Maypole/View/Base.pm lib/Maypole/View/TT.pm diff --git a/lib/CGI/Untaint/Maypole.pm b/lib/CGI/Untaint/Maypole.pm index 38321ef..d5eab49 100644 --- a/lib/CGI/Untaint/Maypole.pm +++ b/lib/CGI/Untaint/Maypole.pm @@ -6,7 +6,7 @@ our $VERSION = '0.01'; use base 'CGI::Untaint'; use Carp; -=head1 NAME +=head1 NAME CGI::Untaint::Maypole - Use instead of CGI::Untaint. Based on CGI::Untaint diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm index 8858c0a..d8592bc 100644 --- a/lib/Maypole/Model/Base.pm +++ b/lib/Maypole/Model/Base.pm @@ -257,3 +257,24 @@ sub related { 1; +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Maypole is currently maintained by Aaron Trevena. + +=head1 AUTHOR EMERITUS + +Simon Cozens, C + +Simon Flack maintained Maypole from 2.05 to 2.09 + +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index ed59356..cc78879 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,8 +1,5 @@ package Maypole::Model::CDBI; use strict; -use Class::C3; - -use Data::Dumper; =head1 NAME @@ -26,12 +23,10 @@ will instead use Class::DBI classes provided. =cut -use base qw(Maypole::Model::Base Class::DBI); +use base qw(Maypole::Model::CDBI::Base); +use Class::C3; +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; @@ -51,25 +46,14 @@ sub Untainter { 'CGI::Untaint::Maypole' }; 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; -} - - -__PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/); +Inherited from Maypole::Model::CDBI::Base =head1 Action Methods Action methods are methods that are accessed through web (or other public) interface. +Inherited from L + =head2 do_edit If there is an object in C<$r-Eobjects>, then it should be edited @@ -78,339 +62,27 @@ be created with those parameters, and put back into C<$r-Eobjects>. The template should be changed to C, or C if there were any errors. A hash of errors will be passed to the template. -=cut - -sub do_edit : Exported { - my ($self, $r, $obj) = @_; - - my $config = $r->config; - my $table = $r->table; - - # handle cancel button hit - if ( $r->{params}->{cancel} ) { - $r->template("list"); - $r->objects( [$self->retrieve_all] ); - return; - } - - my $required_cols = $config->{$table}{required_cols} || $self->required_columns; - my $ignored_cols = $config->{$table}{ignore_cols} || []; - - ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); - - # handle errors, if none, proceed to view the newly created/updated object - my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; - - if (%errors) { - # Set it up as it was: - $r->template_args->{cgi_params} = $r->params; - - # replace user unfriendly error messages with something nicer - - foreach (@{$config->{$table}->{required_cols}}) { - next unless ($errors{$_}); - my $key = $_; - s/_/ /g; - $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value'; - $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value'; - delete $errors{$key}; - } - - foreach (keys %errors) { - my $key = $_; - s/_/ /g; - $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field'; - $r->template_args->{errors}{$key} = 'Please provide a valid value for this field'; - } - - undef $obj if $creating; - - die "do_update failed with error : $fatal" if ($fatal); - $r->template("edit"); - } else { - $r->template("view"); - } - - - - $r->objects( $obj ? [$obj] : []); -} - -# split out from do_edit to be reported by Mp::P::Trace -sub _do_update_or_create { - my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; - - my $fatal; - my $creating = 0; - - my $h = $self->Untainter->new( %{$r->params} ); - - # update or create - if ($obj) { - # We have something to edit - eval { $obj->update_from_cgi( $r => { - 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( $r => { - 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); -} +Inherited from Maypole::Model::CDBI::Base. -=head2 search - -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. - -=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(@_); - } -} +Inherited from Maypole::Model::CDBI::Base. -sub do_search : Exported { - my ( $self, $r ) = @_; - my %fields = map { $_ => 1 } $self->columns; - my $oper = "like"; # For now - my %params = %{ $r->{params} }; - my %values = map { $_ => { $oper, $params{$_} } } - grep { defined $params{$_} && length ($params{$_}) && $fields{$_} } - keys %params; - - $r->template("list"); - if ( !%values ) { return $self->list($r) } - my $order = $self->order($r); - $self = $self->do_pager($r); - $r->objects( - [ - $self->search_where( - \%values, ( $order ? { order_by => $order } : () ) - ) - ] - ); - $r->{template_args}{search} = 1; -} +This action method searches for database records. =head2 list +Inherited from Maypole::Model::CDBI::Base. + The C method fills C<$r-Eobjects> with all of the objects in the class. The results are paged using a pager. -=cut - -sub list : Exported { - my ( $self, $r ) = @_; - my $order = $self->order($r); - $self = $self->do_pager($r); - if ($order) { - $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); - } - else { - $r->objects( [ $self->retrieve_all ] ); - } -} - -############################################################################### -# Helper methods - =head1 Helper Methods - -=head2 adopt - -This class method is passed the name of a model class that represensts a table -and allows the master model class to do any set-up required. - -=cut - -sub adopt { - my ( $self, $child ) = @_; - $child->autoupdate(1); - if ( my $col = $child->stringify_column ) { - $child->columns( Stringify => $col ); - } -} - - -=head2 related - -This method returns a list of has-many accessors. A brewery has many -beers, so C needs to return C. - -=cut - -sub related { - my ( $self, $r ) = @_; - return keys %{ $self->meta_info('has_many') || {} }; -} - - -=head2 related_class - -Given an accessor name as a method, this function returns the class this accessor returns. - -=cut - -sub related_class { - my ( $self, $r, $accessor ) = @_; - my $meta = $self->meta_info; - my @rels = keys %$meta; - my $related; - foreach (@rels) { - $related = $meta->{$_}{$accessor}; - last if $related; - } - return unless $related; - - my $mapping = $related->{args}->{mapping}; - if ( $mapping and @$mapping ) { - return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; - } - else { - return $related->{foreign_class}; - } - } - -=head2 related_meta - - $class->related_meta($col); - -Returns the hash ref of relationship meta info for a given column. - -=cut - -sub related_meta { - my ($self,$r, $accssr) = @_; - $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; - my $class_meta = $self->meta_info; - if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } - keys %$class_meta) - { return $class_meta->{$rel_type}->{$accssr} }; -} - - - -=head2 stringify_column - - Returns the name of the column to use when stringifying - and object. - -=cut - -sub stringify_column { - my $class = shift; - return ( - $class->columns("Stringify"), - ( grep { /^(name|title)$/i } $class->columns ), - ( grep { /(name|title)/i } $class->columns ), - ( grep { !/id$/i } $class->primary_columns ), - )[0]; -} - -=head2 do_pager - - Sets the pager template argument ($r->{template_args}{pager}) - to a Class::DBI::Pager object based on the rows_per_page - value set in the configuration of the application. - - This pager is used via the pager macro in TT Templates, and - is also accessible via Mason. - -=cut - -sub do_pager { - my ( $self, $r ) = @_; - if ( my $rows = $r->config->rows_per_page ) { - return $r->{template_args}{pager} = - $self->pager( $rows, $r->query->{page} ); - } - else { return $self } -} - - -=head2 order - - Returns the SQL order syntax based on the order parameter passed - to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'. - - $sql .= $self->order($r); - - If the order column is not a column of this table, - or an order argument is not passed, then the return value is undefined. - - Note: the returned value does not start with a space. - -=cut - -sub order { - my ( $self, $r ) = @_; - my %ok_columns = map { $_ => 1 } $self->columns; - my $q = $r->query; - my $order = $q->{order}; - return unless $order and $ok_columns{$order}; - $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc'; - return $order; -} - =head2 setup This method is inherited from Maypole::Model::Base and calls setup_database, @@ -470,323 +142,27 @@ sub class_of { return $r->config->loader->_table2class($table); # why not find_class ? } -=head2 fetch_objects - -Returns 1 or more objects of the given class when provided with the request - -=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. - - 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 +=head1 SEE ALSO - my $required = $class->column_required($column_name); +L, L. - 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. +=head1 AUTHOR -=cut +Maypole is currently maintained by Aaron Trevena. -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; -} +=head1 AUTHOR EMERITUS -=head2 column_nullable +Simon Cozens, C - Returns true if a column can be NULL within the underlying database and false if not. +Simon Flack maintained Maypole from 2.05 to 2.09 - my $nullable = $class->column_nullable($column_name); +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 - Any columns that are not nullable will automatically be specified as required, you can - also specify nullable columns as required within your application. +=head1 LICENSE - 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. +You may distribute this code under the same terms as Perl itself. =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; -} - - 1; diff --git a/lib/Maypole/Model/CDBI/Base.pm b/lib/Maypole/Model/CDBI/Base.pm new file mode 100644 index 0000000..a7e7d97 --- /dev/null +++ b/lib/Maypole/Model/CDBI/Base.pm @@ -0,0 +1,750 @@ +package Maypole::Model::CDBI::Base; +use strict; +use Class::C3; + +=head1 NAME + +Maypole::Model::CDBI::Base - Model base class based on Class::DBI + +=head1 DESCRIPTION + +This is a master model class which uses L to do all the hard +work of fetching rows and representing them as objects. It is a good +model to copy if you're replacing it with other database abstraction +modules. + +It implements a base set of methods required for a Maypole Data Model. + +It inherits accessor and helper methods from L. + +=cut + +use base qw(Maypole::Model::Base Class::DBI); +use Class::DBI::AbstractSearch; +use Class::DBI::Plugin::RetrieveAll; +use Class::DBI::Pager; +use Lingua::EN::Inflect::Number qw(to_PL); +use attributes (); +use Data::Dumper; + +__PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/); + +=head2 add_model_superclass + +Adds model as superclass to model classes (if necessary) + +=cut + +sub add_model_superclass { + my ($class,$config) = @_; + foreach my $subclass ( @{ $config->classes } ) { + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + push @{ $subclass . "::ISA" }, $config->model; + } + return; +} + +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=cut + +sub do_edit : Exported { + my ($self, $r, $obj) = @_; + + my $config = $r->config; + my $table = $r->table; + + # handle cancel button hit + if ( $r->{params}->{cancel} ) { + $r->template("list"); + $r->objects( [$self->retrieve_all] ); + return; + } + + my $required_cols = $config->{$table}{required_cols} || $self->required_columns; + my $ignored_cols = $config->{$table}{ignore_cols} || []; + + ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); + + # handle errors, if none, proceed to view the newly created/updated object + my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; + + if (%errors) { + # Set it up as it was: + $r->template_args->{cgi_params} = $r->params; + + # replace user unfriendly error messages with something nicer + + foreach (@{$config->{$table}->{required_cols}}) { + next unless ($errors{$_}); + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value'; + $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value'; + delete $errors{$key}; + } + + foreach (keys %errors) { + my $key = $_; + s/_/ /g; + $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field'; + $r->template_args->{errors}{$key} = 'Please provide a valid value for this field'; + } + + undef $obj if $creating; + + die "do_update failed with error : $fatal" if ($fatal); + $r->template("edit"); + } else { + $r->template("view"); + } + + $r->objects( $obj ? [$obj] : []); +} + +# split out from do_edit to be reported by Mp::P::Trace +sub _do_update_or_create { + my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; + + my $fatal; + my $creating = 0; + + my $h = $self->Untainter->new( %{$r->params} ); + + # update or create + if ($obj) { + # We have something to edit + eval { $obj->update_from_cgi( $r => { + 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( $r => { + 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 + +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); + $r->objects( + [ + $self->search_where( + \%values, ( $order ? { order_by => $order } : () ) + ) + ] + ); + $r->{template_args}{search} = 1; +} + +=head2 list + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=cut + +sub list : Exported { + my ( $self, $r ) = @_; + my $order = $self->order($r); + $self = $self->do_pager($r); + if ($order) { + $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); + } + else { + $r->objects( [ $self->retrieve_all ] ); + } +} + +############################################################################### +# Helper methods + +=head1 Helper Methods + + +=head2 adopt + +This class method is passed the name of a model class that represents a table +and allows the master model class to do any set-up required. + +=cut + +sub adopt { + my ( $self, $child ) = @_; + $child->autoupdate(1); + if ( my $col = $child->stringify_column ) { + $child->columns( Stringify => $col ); + } +} + + +=head2 related + +This method returns a list of has-many accessors. A brewery has many +beers, so C needs to return C. + +=cut + +sub related { + my ( $self, $r ) = @_; + return keys %{ $self->meta_info('has_many') || {} }; +} + + +=head2 related_class + +Given an accessor name as a method, this function returns the class this accessor returns. + +=cut + +sub related_class { + my ( $self, $r, $accessor ) = @_; + my $meta = $self->meta_info; + my @rels = keys %$meta; + my $related; + foreach (@rels) { + $related = $meta->{$_}{$accessor}; + last if $related; + } + return unless $related; + + my $mapping = $related->{args}->{mapping}; + if ( $mapping and @$mapping ) { + return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; + } + else { + return $related->{foreign_class}; + } + } + +=head2 related_meta + + $class->related_meta($col); + +Returns the hash ref of relationship meta info for a given column. + +=cut + +sub related_meta { + my ($self,$r, $accssr) = @_; + $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; + my $class_meta = $self->meta_info; + if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } + keys %$class_meta) + { return $class_meta->{$rel_type}->{$accssr} }; +} + + + +=head2 stringify_column + + Returns the name of the column to use when stringifying + and object. + +=cut + +sub stringify_column { + my $class = shift; + return ( + $class->columns("Stringify"), + ( grep { /^(name|title)$/i } $class->columns ), + ( grep { /(name|title)/i } $class->columns ), + ( grep { !/id$/i } $class->primary_columns ), + )[0]; +} + +=head2 do_pager + + Sets the pager template argument ($r->{template_args}{pager}) + to a Class::DBI::Pager object based on the rows_per_page + value set in the configuration of the application. + + This pager is used via the pager macro in TT Templates, and + is also accessible via Mason. + +=cut + +sub do_pager { + my ( $self, $r ) = @_; + if ( my $rows = $r->config->rows_per_page ) { + return $r->{template_args}{pager} = + $self->pager( $rows, $r->query->{page} ); + } + else { return $self } +} + + +=head2 order + + Returns the SQL order syntax based on the order parameter passed + to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'. + + $sql .= $self->order($r); + + If the order column is not a column of this table, + or an order argument is not passed, then the return value is undefined. + + Note: the returned value does not start with a space. + +=cut + +sub order { + my ( $self, $r ) = @_; + my %ok_columns = map { $_ => 1 } $self->columns; + my $q = $r->query; + my $order = $q->{order}; + return unless $order and $ok_columns{$order}; + $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc'; + return $order; +} + + +=head2 fetch_objects + +Returns 1 or more objects of the given class when provided with the request + +=cut + +sub fetch_objects { + my ($class, $r)=@_; + my @pcs = $class->primary_columns; + if ( $#pcs ) { + my %pks; + @pks{@pcs}=(@{$r->{args}}); + return $class->retrieve( %pks ); + } + return $class->retrieve( $r->{args}->[0] ); +} + + +=head2 _isa_class + +Private method to return the class a column +belongs to that was inherited by an is_a relationship. +This should probably be public but need to think of API + +=cut + +sub _isa_class { + my ($class, $col) = @_; + $class->_croak( "Need a column for _isa_class." ) unless $col; + my $isaclass; + my $isa = $class->meta_info("is_a") || {}; + foreach ( keys %$isa ) { + $isaclass = $isa->{$_}->foreign_class; + return $isaclass if ($isaclass->find_column($col)); + } + return; # col not in a is_a class +} + + +# Thanks to dave baird -- form builder for these private functions +# sub _column_info { +sub _column_info { + my $self = shift; + my $dbh = $self->db_Main; + + my $meta; # The info we are after + my ($catalog, $schema) = (undef, undef); + # Dave is suspicious this (above undefs) could + # break things if driver useses this info + + my $original_metadata; + # '%' is a search pattern for columns - matches all columns + if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) { + $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr; + $self->COLUMN_INFO ($self->_hash_type_meta( $sth )); + } else { + $self->COLUMN_INFO ($self->_hash_typeless_meta( )); + } + + return $self->COLUMN_INFO; +} + +sub _hash_type_meta { + my ($self, $sth) = @_; + my $meta; + while ( my $row = $sth->fetchrow_hashref ) { + my $colname = $row->{COLUMN_NAME} || $row->{column_name}; + + # required / nullable + $meta->{$colname}{nullable} = $row->{NULLABLE}; + $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0; + + # default + if (defined $row->{COLUMN_DEF}) { + my $default = $row->{COLUMN_DEF}; + $default =~ s/['"]?(.*?)['"]?::.*$/$1/; + $meta->{$colname}{default} = $default; + }else { + $meta->{$colname}{default} = ''; + } + + # type + my $type = $row->{mysql_type_name} || $row->{type}; + unless ($type) { + $type = $row->{TYPE_NAME}; + if ($row->{COLUMN_SIZE}) { + $type .= "($row->{COLUMN_SIZE})"; + } + } + $type =~ s/['"]?(.*)['"]?::.*$/$1/; + # Bool if tinyint + if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) { + $type = 'BOOL'; + } + $meta->{$colname}{type} = $type; + + # order + $meta->{$colname}{position} = $row->{ORDINAL_POSITION} + } + return $meta; +} + +# typeless db e.g. sqlite +sub _hash_typeless_meta { + my ( $self ) = @_; + + $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' ) + unless $self->can( 'sql_fb_meta_dummy' ); + + my $sth = $self->sql_fb_meta_dummy; + + $sth->execute or die "Error executing column info: " . $sth->errstr;; + + # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes + my $cols = $sth->{NAME}; + my $types = $sth->{TYPE}; + # my $sizes = $sth->{PRECISION}; # empty + # my $nulls = $sth->{NULLABLE}; # empty + + # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to + $sth->finish; + + my $order = 0; + my $meta; + foreach my $col ( @$cols ) { + my $col_meta; + $col_meta->{nullable} = 1; + $col_meta->{required} = 0; + $col_meta->{default} = ''; + $col_meta->{position} = $order++; + # type_name is taken literally from the schema, but is not actually used by sqlite, + # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc. + my $type = shift( @$types ); + $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ; + $meta->{$col} = $col_meta; + } + return $meta; +} + +=head2 column_type + + my $type = $class->column_type('column_name'); + +This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.) +For now, it returns "BOOL" for tinyints. + +TODO :: TEST with enums + +=cut + +sub column_type { + my $class = shift; + my $colname = shift or die "Need a column for column_type"; + $class->_column_info() unless (ref $class->COLUMN_INFO); + + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_type($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{type}; +} + +=head2 required_columns + + Accessor to get/set required columns for forms, validation, etc. + + Returns list of required columns. Accepts an array ref of column names. + + $class->required_columns([qw/foo bar baz/]); + + Allows you to specify the required columns for a class, over-riding any + assumptions and guesses made by Maypole. + + Any columns specified as required will no longer be 'nullable' or optional, and + any columns not specified as 'required' will be 'nullable' or optional. + + The default for a column is nullable, or whatever is discovered from database + schema. + + Use this instead of $config->{$table}{required_cols} + + Note : you need to setup the model class before calling this method. + +=cut + +sub required_columns { + my ($class, $columns) = @_; + $class->_column_info() unless (ref $class->COLUMN_INFO); + my $column_info = $class->COLUMN_INFO; + + if ($columns) { + # get the previously required columns + my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info); + + # update each specified column as required + foreach my $colname ( @$columns ) { + # handle C::DBI::Rel::IsA + if ($class->_isa_class($colname)) { + $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1 + unless ($class->_isa_class($colname)->column_required); + next; + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + next; + } + $column_info->{$colname}{required} = 1; + delete $previously_required{$colname}; + } + + # no longer require any columns not specified + foreach my $colname ( keys %previously_required ) { + $column_info->{$colname}{required} = 0; + $column_info->{$colname}{nullable} = 1; + } + + # update column metadata + $class->COLUMN_INFO($column_info); + } + + return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ; +} + +=head2 column_required + + Returns true if a column is required + + my $required = $class->column_required($column_name); + + Columns can be required by the application but not the database, but not the other way around, + hence there is also a column_nullable method which will tell you if the column is nullable + within the database itself. + +=cut + +sub column_required { + my ($class, $colname) = @_; + $colname or $class->_croak( "Need a column for column_required" ); + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_required($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return 0; +} + +=head2 column_nullable + + Returns true if a column can be NULL within the underlying database and false if not. + + my $nullable = $class->column_nullable($column_name); + + Any columns that are not nullable will automatically be specified as required, you can + also specify nullable columns as required within your application. + + It is recomended you use column_required rather than column_nullable within your + application, this method is more useful if extending the model or handling your own + validation. + +=cut + +sub column_nullable { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_nullable" ); + + $class->_column_info() unless ref $class->COLUMN_INFO; + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_nullable($colname); + } + unless ( $class->find_column($colname) ) { + # handle non-existant columns + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return 0; +} + +=head2 column_default + +Returns default value for column or the empty string. +Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times +have '' returned. + +=cut + +sub column_default { + my $class = shift; + my $colname = shift or $class->_croak( "Need a column for column_default"); + $class->_column_info() unless (ref $class->COLUMN_INFO); + if ($class->_isa_class($colname)) { + return $class->_isa_class($colname)->column_default($colname); + } + unless ( $class->find_column($colname) ) { + warn "$colname is not a recognised column in this class ", ref $class || $class, "\n"; + return undef; + } + + return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname}); + return; +} + +=head2 get_classmetadata + +Gets class meta data *excluding cgi input* for the passed in class or the +calling class. *NOTE* excludes cgi inputs. This method is handy to call from +templates when you need some metadata for a related class. + +=cut + +sub get_classmetadata { + my ($self, $class) = @_; # class is class we want data for + $class ||= $self; + $class = ref $class || $class; + + my %res; + $res{name} = $class; + $res{colnames} = {$class->column_names}; + $res{columns} = [$class->display_columns]; + $res{list_columns} = [$class->list_columns]; + $res{moniker} = $class->moniker; + $res{plural} = $class->plural_moniker; + $res{table} = $class->table; + $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ; + return \%res; +} + + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Maypole is currently maintained by Aaron Trevena. + +=head1 AUTHOR EMERITUS + +Simon Cozens, C + +Simon Flack maintained Maypole from 2.05 to 2.09 + +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Maypole/Model/CDBI/DFV.pm b/lib/Maypole/Model/CDBI/DFV.pm index 1a90bce..fcf80fb 100644 --- a/lib/Maypole/Model/CDBI/DFV.pm +++ b/lib/Maypole/Model/CDBI/DFV.pm @@ -1,14 +1,9 @@ package Maypole::Model::CDBI::DFV; -use Class::C3; -use Maypole::Config; -use base qw(Maypole::Model::Base); use strict; -Maypole::Config->mk_accessors(qw(table_to_class)); - =head1 NAME -Maypole::Model::CDBI::Plain - Class::DBI model without ::Loader +Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole. =head1 SYNOPSIS @@ -38,6 +33,17 @@ as normal. Better still, it will also set use your DFV profile to validate input instead of CGI::Untaint. For teh win!! +=cut + +use Class::C3; +use Maypole::Config; +use Data::FormValidator; +use Maypole::Model::CDBI::AsForm; + +use base qw(Maypole::Model::Base); + +Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO)); + =head1 METHODS =head2 setup @@ -72,22 +78,6 @@ sub class_of { return $r->config->{table_to_class}->{$table}; } -=head2 add_model_superclass - -Adds model as superclass to model classes - -=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; -} - =head2 adopt This class method is passed the name of a model class that represensts a table @@ -102,14 +92,228 @@ sub adopt { } } +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +Inherited from L except do_edit (below) + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=cut + +sub do_edit : Exported { + my ($class, $r, $obj) = @_; + + my $config = $r->config; + my $table = $r->table; + + # handle cancel button hit + if ( $r->params->{cancel} ) { + $r->template("list"); + $r->objects( [$class->retrieve_all] ); + return; + } + + my $required_cols = $class->required_columns; + 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; + foreach my $error (keys %$errors) { + $r->template_args->{errors}{ucfirst($error)} = $errors->{$error} + } + + # 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 = { map { $_ => $r->{params}{$_} } $class->columns }; + + # 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) { + $class->_croak("No relationship for $accssr in " . ref($class)); + } + + 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 = { map { $_ => $r->{params}{$_} } $class->columns }; + my $obj = eval { My::DBI->create( $this_class_params ) }; + + my $dfv_results = ($obj) ? undef : $class->dfv_results->msgs ; + + # 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->_croak("No relationship for $accssr in " . ref($self)); + } + + my $rel_type = $rel_meta->{name}; + my $fclass = $rel_meta->{foreign_class}; + + my ($rel, $errs); + + # Set up params for might_have, has_many, etc + if ($rel_type ne 'has_own' and $rel_type ne 'has_a') { + # Foreign Key meta data not very standardized in CDBI + my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column}; + unless ($fkey) { die " Could not determine foreign key for $fclass"; } + my %data = (%$params, $fkey => $self->id); + %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} ); + ($rel, $errs) = $fclass->_do_create(\%data); + } + else { + ($rel, $errs) = $fclass->_do_create($params); + unless ($errs) { + $self->$accssr($rel->id); + $self->update; + } + } + return ($rel, $errs); +} + + +=head2 do_delete + +Inherited from Maypole::Model::CDBI::Base. + +This action deletes records + +=head2 do_search + +Inherited from Maypole::Model::CDBI::Base. + +This action method searches for database records. + +=head2 list + +Inherited from Maypole::Model::CDBI::Base. + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=cut + +sub _column_info { + my $class = shift; + + # get COLUMN INFO from DB + $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO); + + # update with required columns from DFV Profile + my $profile = $class->dfv_profile; + $class->required_columns(@{$profile->{required}}); + + return $class->COLUMN_INFO; +} + + + =head1 SEE ALSO L -L +L -=cut +=head1 AUTHOR + +Aaron Trevena. +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut 1; diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm index 30ef4d4..e01fb9e 100644 --- a/lib/Maypole/Model/CDBI/FromCGI.pm +++ b/lib/Maypole/Model/CDBI/FromCGI.pm @@ -102,8 +102,6 @@ Returns errors that ocurred during an operation. sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } } - - =head2 create_from_cgi Based on the same method in Class::DBI::FromCGI. diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm index c95bead..0ca9bc9 100644 --- a/lib/Maypole/Model/CDBI/Plain.pm +++ b/lib/Maypole/Model/CDBI/Plain.pm @@ -1,11 +1,6 @@ package Maypole::Model::CDBI::Plain; -use Class::C3; -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 @@ -37,8 +32,62 @@ L classes; simply call C with a list reference of the classes you're going to use, and Maypole will work out the tables and set up the inheritance relationships as normal. +=cut + +use Class::C3; +use Maypole::Config; +use base 'Maypole::Model::CDBI::Base'; + +use Maypole::Model::CDBI::AsForm; +use Maypole::Model::CDBI::FromCGI; +use CGI::Untaint::Maypole; + =head1 METHODS +=head1 Action Methods + +Action methods are methods that are accessed through web (or other public) interface. + +Inherited from L + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=head2 do_delete + +Inherited from Maypole::Model::CDBI::Base. + +This action deletes records + +=head2 do_search + +Inherited from Maypole::Model::CDBI::Base. + +This action method searches for database records. + +=head2 list + +Inherited from Maypole::Model::CDBI::Base. + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=head1 Helper Methods + +=head2 Untainter + +Set the class you use to untaint and validate form data +Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint + +=cut + +sub Untainter { 'CGI::Untaint::Maypole' }; + =head2 setup This method is inherited from Maypole::Model::Base and calls setup_database, @@ -51,8 +100,6 @@ tables and set up the inheritance relationships as normal. =cut - - sub setup_database { my ( $self, $config, $namespace, $classes ) = @_; $config->{classes} = $classes;