X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=a62c8fcde8d1e11b84213ef3a931a3339c4dfb19;hb=fcef7418a2171a0a7fb8302285f56b0331ba1a4a;hp=dd9af06c71472df111a129e51bda562173becf65;hpb=41a93152a01bdeab5ada42fd423f985554ade78e;p=maypole.git diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index dd9af06..a62c8fc 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -16,12 +16,17 @@ It implements a base set of methods required for a Maypole Data Model. It inherits accessor and helper methods from L. +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 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; @@ -29,7 +34,9 @@ use Class::DBI::Plugin::RetrieveAll; use Class::DBI::Pager; use Lingua::EN::Inflect::Number qw(to_PL); +use attributes (); +use Data::Dumper; ############################################################################### # Helper methods @@ -38,7 +45,7 @@ use Lingua::EN::Inflect::Number qw(to_PL); 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-Eobjects>, then it should be edited with the parameters in C<$r-Eparams>; otherwise, a new object should @@ -72,7 +79,25 @@ sub do_edit : Exported { 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"); @@ -89,7 +114,8 @@ sub _do_update_or_create { 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) { @@ -97,7 +123,9 @@ sub _do_update_or_create { 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 { @@ -117,6 +145,11 @@ sub _do_update_or_create { } +=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. @@ -128,10 +161,14 @@ This method replaces the, now deprecated, delete method provided in prior versio 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 { @@ -142,6 +179,9 @@ sub do_delete { $self->list($r); } +=head2 search + +Deprecated searching method - use do_search instead. =head2 do_search @@ -301,29 +341,6 @@ sub adopt { } } -=head2 is_public - -Should return true if a certain action is supported, or false otherwise. -Defaults to checking if the sub has the C<:Exported> attribute. - -=cut - -sub is_public { - my ( $self, $action, $attrs ) = @_; - my $cv = $self->can($action); - warn "is_public failed . action is $action. self is $self" and return 0 unless $cv; - unless ($attrs) { - my @attrs = attributes::get($cv) || (); - $attrs = join " ", @attrs; - } - do { - warn "is_public failed .$action not exported" if Maypole->debug; - return 0; - } unless $attrs =~ /\bExported\b/i; - return 1; -} - - =head2 is_class Tell if action is a class method (See Maypole::Plugin::Menu) @@ -333,7 +350,7 @@ Tell if action is a class method (See Maypole::Plugin::Menu) sub is_class { my ( $self, $method, $attrs ) = @_; die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); + $attrs = join(' ',$self->method_attrs($method)) unless ($attrs); return 1 if $attrs =~ /\bClass\b/i; return 1 if $method =~ /^list$/; # default class actions return 0; @@ -348,20 +365,12 @@ Tell if action is a object method (See Maypole::Plugin::Menu) sub is_object { my ( $self, $method, $attrs ) = @_; die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); + $attrs = join(' ',$self->method_attrs($method)) unless ($attrs); return 1 if $attrs =~ /\bObject\b/i; return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions return 0; } -# Get string of joined attributes for matching -sub method_attrs { - my ($class, $method) = @_; - my $cv = $class->can($method); - return 0 unless $cv; - my @attrs = attributes::get($cv) || (); - return join " ", @attrs; -} =head2 related @@ -402,17 +411,36 @@ sub related_class { } } +=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; @@ -426,7 +454,8 @@ sub isa_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 @@ -452,6 +481,9 @@ sub accessor_classes { =head2 stringify_column + Returns the name of the column to use when stringifying + and object. + =cut sub stringify_column { @@ -466,6 +498,13 @@ 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 { @@ -480,6 +519,16 @@ 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 { @@ -492,8 +541,27 @@ 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 { @@ -515,15 +583,29 @@ 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;