1 package Maypole::Model::CDBI;
6 Maypole::Model::CDBI - Model class based on Class::DBI
10 This is a master model class which uses L<Class::DBI> to do all the hard
11 work of fetching rows and representing them as objects. It is a good
12 model to copy if you're replacing it with other database abstraction
15 It implements a base set of methods required for a Maypole Data Model.
17 It inherits accessor and helper methods from L<Maypole::Model::Base>.
19 When specified as the application model, it will use Class::DBI::Loader
20 to generate the model classes from the provided database. If you do not
21 wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
22 will instead use Class::DBI classes provided.
26 use base qw(Maypole::Model::Base Class::DBI);
27 use Maypole::Model::CDBI::AsForm;
28 use CGI::Untaint::Maypole;
29 use Class::DBI::Plugin::Type;
30 use Class::DBI::FromCGI;
31 use Class::DBI::Loader;
32 use Class::DBI::AbstractSearch;
33 use Class::DBI::Plugin::RetrieveAll;
34 use Class::DBI::Pager;
36 use Lingua::EN::Inflect::Number qw(to_PL);
39 ###############################################################################
44 Action methods are methods that are accessed through web (or other public) interface.
48 If there is an object in C<$r-E<gt>objects>, then it should be edited
49 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
50 be created with those parameters, and put back into C<$r-E<gt>objects>.
51 The template should be changed to C<view>, or C<edit> if there were any
52 errors. A hash of errors will be passed to the template.
56 sub do_edit : Exported {
57 my ($self, $r, $obj) = @_;
59 my $config = $r->config;
60 my $table = $r->table;
62 # handle cancel button hits
63 if ( $r->{params}->{cancel} ) {
65 $r->objects( [$self->retrieve_all] );
69 my $required_cols = $config->{$table}->{required_cols} || [];
70 my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
72 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
74 # handle errors, if none, proceed to view the newly created/updated object
75 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
78 # Set it up as it was:
79 $r->template_args->{cgi_params} = $r->params;
82 # replace user unfriendly error messages with something nicer
84 foreach (@{$config->{$table}->{required_cols}}) {
85 next unless ($errors{$_});
88 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
89 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
93 foreach (keys %errors) {
96 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
97 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
100 undef $obj if $creating;
101 $r->template("edit");
103 $r->template("view");
106 $r->objects( $obj ? [$obj] : []);
109 # split out from do_edit to be reported by Mp::P::Trace
110 sub _do_update_or_create {
111 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
115 my $h = CGI::Untaint::Maypole->new( %{$r->params} );
119 # We have something to edit
120 eval { $obj->update_from_cgi( $h => {
121 required => $required_cols,
122 ignore => $ignored_cols,
124 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
129 $obj = $self->create_from_cgi( $h => {
130 required => $required_cols,
131 ignore => $ignored_cols,
136 warn "$fatal" if $r->debug;
141 return $obj, $fatal, $creating;
147 Deprecated method that calls do_delete or a given classes delete method, please
148 use do_delete instead
152 Unsuprisingly, this command causes a database record to be forever lost.
154 This method replaces the, now deprecated, delete method provided in prior versions
158 sub delete : Exported {
160 my ($sub) = (caller(1))[3];
161 # So subclasses can still send delete down ...
162 $sub =~ /^(.+)::([^:]+)$/;
163 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
164 $self->SUPER::delete(@_);
166 warn "Maypole::Model::CDBI delete method is deprecated\n";
167 $self->do_delete(@_);
172 my ( $self, $r ) = @_;
173 $_->SUPER::delete for @{ $r->objects || [] };
174 $r->objects( [ $self->retrieve_all ] );
175 $r->{template} = "list";
181 Deprecated searching method - use do_search instead.
185 This action method searches for database records, it replaces
186 the, now deprecated, search method previously provided.
190 sub search : Exported {
192 my ($sub) = (caller(1))[3];
193 $sub =~ /^(.+)::([^:]+)$/;
194 # So subclasses can still send search down ...
195 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
196 $self->SUPER::search(@_) : $self->do_search(@_);
199 sub do_search : Exported {
200 my ( $self, $r ) = @_;
201 my %fields = map { $_ => 1 } $self->columns;
202 my $oper = "like"; # For now
203 my %params = %{ $r->{params} };
204 my %values = map { $_ => { $oper, $params{$_} } }
205 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
208 $r->template("list");
209 if ( !%values ) { return $self->list($r) }
210 my $order = $self->order($r);
211 $self = $self->do_pager($r);
215 \%values, ( $order ? { order_by => $order } : () )
219 $r->{template_args}{search} = 1;
224 The C<list> method fills C<$r-E<gt>objects> with all of the
225 objects in the class. The results are paged using a pager.
229 sub list : Exported {
230 my ( $self, $r ) = @_;
231 my $order = $self->order($r);
232 $self = $self->do_pager($r);
234 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
237 $r->objects( [ $self->retrieve_all ] );
241 #######################
242 # _process_local_srch #
243 #######################
245 # Makes the local part of the db search query
246 # Puts search prams local to this table in where array.
247 # Returns a where array ref and search criteria string.
248 # This is factored out of do_search so sub classes can override this part
249 sub _process_local_srch {
250 my ($self, $hashed) = @_;
251 my %fields = map { $_ => 1 } $self->columns;
252 my $moniker = $self->moniker;
253 my %colnames = $self->column_names;
258 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
259 $oper = $self->sql_search_oper($_);
260 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
261 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
263 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
266 return (\@where, $srch_crit);
269 #########################
270 # _process_foreign_srch #
271 #########################
273 # puts foreign search fields into select statement
274 # changes @where by ref and return sel and srch_criteria string
275 sub _process_foreign_srch {
276 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
277 my %colnames = $self->column_names;
278 my $moniker = $self->moniker;
280 foreach (keys %$hashed) {
281 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
283 my %accssr_class = %{$self->accessor_classes};
284 while (my ( $accssr, $prms) = each %foreign ) {
285 my $fclass = $accssr_class{$accssr};
286 my %fields = map { $_ => 1 } $fclass->columns;
287 my %colnames = $fclass->column_names;
290 # TODO make field name match in all cases in srch crit
293 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
294 $oper = $fclass->sql_search_oper($_);
295 $wc = $oper =~ /LIKE/i ? '%':'';
296 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
298 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
301 next unless @this_where;
302 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
304 # map relationships -- TODO use constraints in has_many and mhaves
306 my $pk = $self->primary_column;
307 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
308 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
309 "$accssr.owner_table = '" . $self->table ."'");
311 # for has_own, has_a where foreign id is in self's table
312 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
313 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
315 push @$where, @this_where;
317 return ($sel, $srch_crit);
320 ###############################################################################
323 =head1 Helper Methods
328 This class method is passed the name of a model class that represensts a table
329 and allows the master model class to do any set-up required.
334 my ( $self, $child ) = @_;
335 $child->autoupdate(1);
336 if ( my $col = $child->stringify_column ) {
337 $child->columns( Stringify => $col );
343 Tell if action is a class method (See Maypole::Plugin::Menu)
348 my ( $self, $method, $attrs ) = @_;
349 die "Usage: method must be passed as first arg" unless $method;
350 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
351 return 1 if $attrs =~ /\bClass\b/i;
352 return 1 if $method =~ /^list$/; # default class actions
358 Tell if action is a object method (See Maypole::Plugin::Menu)
363 my ( $self, $method, $attrs ) = @_;
364 die "Usage: method must be passed as first arg" unless $method;
365 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
366 return 1 if $attrs =~ /\bObject\b/i;
367 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
374 This method returns a list of has-many accessors. A brewery has many
375 beers, so C<BeerDB::Brewery> needs to return C<beers>.
380 my ( $self, $r ) = @_;
381 return keys %{ $self->meta_info('has_many') || {} };
387 Given an accessor name as a method, this function returns the class this accessor returns.
392 my ( $self, $r, $accessor ) = @_;
393 my $meta = $self->meta_info;
394 my @rels = keys %$meta;
397 $related = $meta->{$_}{$accessor};
400 return unless $related;
402 my $mapping = $related->{args}->{mapping};
403 if ( $mapping and @$mapping ) {
404 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
407 return $related->{foreign_class};
413 $class->related_meta($col);
415 Given a column associated with a relationship it will return the relatation
416 ship type and the meta info for the relationship on the column.
421 my ($self,$r, $accssr) = @_;
422 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
423 my $class_meta = $self->meta_info;
424 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
426 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
432 Returns class of a column inherited by is_a.
436 # Maybe put this in IsA?
438 my ($class, $col) = @_;
439 $class->_croak( "Need a column for isa_class." ) unless $col;
441 my $isa = $class->meta_info("is_a") || {};
442 foreach ( keys %$isa ) {
443 $isaclass = $isa->{$_}->foreign_class;
444 return $isaclass if ($isaclass->find_column($col));
446 return 0; # col not in a is_a class
449 =head2 accessor_classes
451 Returns hash ref of classes for accessors.
453 This is an attempt at a more efficient method than calling "related_class()"
454 a bunch of times when you need it for many relations.
455 It may be good to call at startup and store in a global config.
459 sub accessor_classes {
460 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
462 my $meta = $class->meta_info;
464 foreach my $rel (keys %$meta) {
465 my $rel_meta = $meta->{$rel};
466 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
471 # 2 liner to get class of accessor for $name
472 #my $meta = $class->meta_info;
473 #my ($isa) = map $_->foreign_class, grep defined,
474 # map $meta->{$_}->{$name}, keys %$meta;
479 =head2 stringify_column
481 Returns the name of the column to use when stringifying
486 sub stringify_column {
489 $class->columns("Stringify"),
490 ( grep { /^(name|title)$/i } $class->columns ),
491 ( grep { /(name|title)/i } $class->columns ),
492 ( grep { !/id$/i } $class->primary_columns ),
498 Sets the pager template argument ($r->{template_args}{pager})
499 to a Class::DBI::Pager object based on the rows_per_page
500 value set in the configuration of the application.
502 This pager is used via the pager macro in TT Templates, and
503 is also accessible via Mason.
508 my ( $self, $r ) = @_;
509 if ( my $rows = $r->config->rows_per_page ) {
510 return $r->{template_args}{pager} =
511 $self->pager( $rows, $r->query->{page} );
513 else { return $self }
519 Returns the SQL order syntax based on the order parameter passed
520 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
522 $sql .= $self->order($r);
524 If the order column is not a column of this table,
525 or an order argument is not passed, then the return value is undefined.
527 Note: the returned value does not start with a space.
532 my ( $self, $r ) = @_;
533 my %ok_columns = map { $_ => 1 } $self->columns;
535 my $order = $q->{order};
536 return unless $order and $ok_columns{$order};
537 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
543 This method is inherited from Maypole::Model::Base and calls setup_database,
544 which uses Class::DBI::Loader to create and load Class::DBI classes from
545 the given database schema.
549 =head2 setup_database
551 The $opts argument is a hashref of options. The "options" key is a hashref of
552 Database connection options . Other keys may be various Loader arguments or
553 flags. It has this form:
555 # DB connection options
556 options { AutoCommit => 1 , ... },
565 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
566 $dsn ||= $config->dsn;
567 $u ||= $config->user;
568 $p ||= $config->pass;
569 $opts ||= $config->opts;
571 warn "No DSN set in config" unless $dsn;
572 $config->loader || $config->loader(
573 Class::DBI::Loader->new(
574 namespace => $namespace,
581 $config->{classes} = [ $config->{loader}->classes ];
582 $config->{tables} = [ $config->{loader}->tables ];
583 warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
584 if $namespace->debug;
589 returns class for given table
594 my ( $self, $r, $table ) = @_;
595 return $r->config->loader->_table2class($table); # why not find_class ?
600 Returns 1 or more objects of the given class when provided with the request
606 my @pcs = $class->primary_columns;
609 @pks{@pcs}=(@{$r->{args}});
610 return $class->retrieve( %pks );
612 return $class->retrieve( $r->{args}->[0] );
616 ###############################################################################
617 # private / internal functions and classes
621 $class = ref $class || $class;
623 return ${$class . '::COLUMN_INFO'};