It inherits accessor and helper methods from L<Maypole::Model::Base>.
+When specified as the application model, it will use Class::DBI::Loader
+to generate the model classes from the provided database. If you do not
+wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
+will instead use Class::DBI classes provided.
+
=cut
use base qw(Maypole::Model::Base Class::DBI);
use Maypole::Model::CDBI::AsForm;
use CGI::Untaint::Maypole;
-
+use Class::DBI::Plugin::Type;
use Class::DBI::FromCGI;
use Class::DBI::Loader;
use Class::DBI::AbstractSearch;
use Lingua::EN::Inflect::Number qw(to_PL);
use attributes ();
+use Data::Dumper;
+
###############################################################################
# Helper methods
Action methods are methods that are accessed through web (or other public) interface.
-=item do_edit
+=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
if (%errors) {
# Set it up as it was:
$r->template_args->{cgi_params} = $r->params;
- $r->template_args->{errors} = \%errors;
+
+ #
+ # 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;
$r->template("edit");
my $fatal;
my $creating = 0;
- my $h = CGI::Untaint::Maypole->new( %{$r->params} );
+
+ my $h = CGI::Untaint->new( %{$r->params} );
# update or create
if ($obj) {
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 {
}
+=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.
sub delete : Exported {
my $self = shift;
my ($sub) = (caller(1))[3];
+ # So subclasses can still send delete down ...
$sub =~ /^(.+)::([^:]+)$/;
- # So subclasses can still send search down ...
- return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
- $self->SUPER::search(@_) : $self->do_delete(@_);
+ 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 {
$self->list($r);
}
+=head2 search
+
+Deprecated searching method - use do_search instead.
=head2 do_search
}
}
+=head2 related_meta
+
+ $class->related_meta($col);
+
+Given a column associated with a relationship it will return the relatation
+ship type and the meta info for the relationship on the 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 $rel_type, $class_meta->{$rel_type}->{$accssr} };
+}
+
+
=head2 isa_class
-Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels)
+Returns class of a column inherited by is_a.
=cut
+# Maybe put this in IsA?
sub isa_class {
my ($class, $col) = @_;
$class->_croak( "Need a column for isa_class." ) unless $col;
my $isaclass;
- # class col is first found in is returned
my $isa = $class->meta_info("is_a") || {};
foreach ( keys %$isa ) {
$isaclass = $isa->{$_}->foreign_class;
Returns hash ref of classes for accessors.
This is an attempt at a more efficient method than calling "related_class()"
-a bunch of times when you need it for many relations.
+a bunch of times when you need it for many relations.
+It may be good to call at startup and store in a global config.
=cut
=head2 stringify_column
+ Returns the name of the column to use when stringifying
+ and object.
+
=cut
sub stringify_column {
=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 {
=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 {
return $order;
}
+=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.
+
+=cut
+
=head2 setup_database
+The $opts argument is a hashref of options. The "options" key is a hashref of
+Database connection options . Other keys may be various Loader arguments or
+flags. It has this form:
+ {
+ # DB connection options
+ options { AutoCommit => 1 , ... },
+ # Loader args
+ relationships => 1,
+ ...
+ }
+
=cut
sub setup_database {
);
$config->{classes} = [ $config->{loader}->classes ];
$config->{tables} = [ $config->{loader}->tables ];
- warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
+
+ my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
+ warn( 'Loaded tables to classes: ' . join ', ', @table_class )
if $namespace->debug;
}
+=head2 class_of
+
+ returns class for given table
+
+=cut
+
sub class_of {
my ( $self, $r, $table ) = @_;
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;
projects / maypole.git / blobdiff