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);
41 ###############################################################################
46 Action methods are methods that are accessed through web (or other public) interface.
50 If there is an object in C<$r-E<gt>objects>, then it should be edited
51 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
52 be created with those parameters, and put back into C<$r-E<gt>objects>.
53 The template should be changed to C<view>, or C<edit> if there were any
54 errors. A hash of errors will be passed to the template.
58 sub do_edit : Exported {
59 my ($self, $r, $obj) = @_;
61 my $config = $r->config;
62 my $table = $r->table;
64 # handle cancel button hits
65 if ( $r->{params}->{cancel} ) {
67 $r->objects( [$self->retrieve_all] );
71 my $required_cols = $config->{$table}->{required_cols} || [];
72 my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
74 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
76 # handle errors, if none, proceed to view the newly created/updated object
77 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
80 # Set it up as it was:
81 $r->template_args->{cgi_params} = $r->params;
84 # replace user unfriendly error messages with something nicer
86 foreach (@{$config->{$table}->{required_cols}}) {
87 next unless ($errors{$_});
90 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
91 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
95 foreach (keys %errors) {
98 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
99 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
102 undef $obj if $creating;
103 $r->template("edit");
105 $r->template("view");
108 $r->objects( $obj ? [$obj] : []);
111 # split out from do_edit to be reported by Mp::P::Trace
112 sub _do_update_or_create {
113 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
118 my $h = CGI::Untaint->new( %{$r->params} );
122 # We have something to edit
123 eval { $obj->update_from_cgi( $h => {
124 required => $required_cols,
125 ignore => $ignored_cols,
127 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
132 $obj = $self->create_from_cgi( $h => {
133 required => $required_cols,
134 ignore => $ignored_cols,
139 warn "$fatal" if $r->debug;
144 return $obj, $fatal, $creating;
150 Deprecated method that calls do_delete or a given classes delete method, please
151 use do_delete instead
155 Unsuprisingly, this command causes a database record to be forever lost.
157 This method replaces the, now deprecated, delete method provided in prior versions
161 sub delete : Exported {
163 my ($sub) = (caller(1))[3];
164 # So subclasses can still send delete down ...
165 $sub =~ /^(.+)::([^:]+)$/;
166 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
167 $self->SUPER::delete(@_);
169 warn "Maypole::Model::CDBI delete method is deprecated\n";
170 $self->do_delete(@_);
175 my ( $self, $r ) = @_;
176 $_->SUPER::delete for @{ $r->objects || [] };
177 $r->objects( [ $self->retrieve_all ] );
178 $r->{template} = "list";
184 Deprecated searching method - use do_search instead.
188 This action method searches for database records, it replaces
189 the, now deprecated, search method previously provided.
193 sub search : Exported {
195 my ($sub) = (caller(1))[3];
196 $sub =~ /^(.+)::([^:]+)$/;
197 # So subclasses can still send search down ...
198 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
199 $self->SUPER::search(@_) : $self->do_search(@_);
202 sub do_search : Exported {
203 my ( $self, $r ) = @_;
204 my %fields = map { $_ => 1 } $self->columns;
205 my $oper = "like"; # For now
206 my %params = %{ $r->{params} };
207 my %values = map { $_ => { $oper, $params{$_} } }
208 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
211 $r->template("list");
212 if ( !%values ) { return $self->list($r) }
213 my $order = $self->order($r);
214 $self = $self->do_pager($r);
218 \%values, ( $order ? { order_by => $order } : () )
222 $r->{template_args}{search} = 1;
227 The C<list> method fills C<$r-E<gt>objects> with all of the
228 objects in the class. The results are paged using a pager.
232 sub list : Exported {
233 my ( $self, $r ) = @_;
234 my $order = $self->order($r);
235 $self = $self->do_pager($r);
237 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
240 $r->objects( [ $self->retrieve_all ] );
244 #######################
245 # _process_local_srch #
246 #######################
248 # Makes the local part of the db search query
249 # Puts search prams local to this table in where array.
250 # Returns a where array ref and search criteria string.
251 # This is factored out of do_search so sub classes can override this part
252 sub _process_local_srch {
253 my ($self, $hashed) = @_;
254 my %fields = map { $_ => 1 } $self->columns;
255 my $moniker = $self->moniker;
256 my %colnames = $self->column_names;
261 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
262 $oper = $self->sql_search_oper($_);
263 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
264 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
266 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
269 return (\@where, $srch_crit);
272 #########################
273 # _process_foreign_srch #
274 #########################
276 # puts foreign search fields into select statement
277 # changes @where by ref and return sel and srch_criteria string
278 sub _process_foreign_srch {
279 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
280 my %colnames = $self->column_names;
281 my $moniker = $self->moniker;
283 foreach (keys %$hashed) {
284 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
286 my %accssr_class = %{$self->accessor_classes};
287 while (my ( $accssr, $prms) = each %foreign ) {
288 my $fclass = $accssr_class{$accssr};
289 my %fields = map { $_ => 1 } $fclass->columns;
290 my %colnames = $fclass->column_names;
293 # TODO make field name match in all cases in srch crit
296 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
297 $oper = $fclass->sql_search_oper($_);
298 $wc = $oper =~ /LIKE/i ? '%':'';
299 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
301 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
304 next unless @this_where;
305 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
307 # map relationships -- TODO use constraints in has_many and mhaves
309 my $pk = $self->primary_column;
310 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
311 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
312 "$accssr.owner_table = '" . $self->table ."'");
314 # for has_own, has_a where foreign id is in self's table
315 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
316 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
318 push @$where, @this_where;
320 return ($sel, $srch_crit);
323 ###############################################################################
326 =head1 Helper Methods
331 This class method is passed the name of a model class that represensts a table
332 and allows the master model class to do any set-up required.
337 my ( $self, $child ) = @_;
338 $child->autoupdate(1);
339 if ( my $col = $child->stringify_column ) {
340 $child->columns( Stringify => $col );
346 Tell if action is a class method (See Maypole::Plugin::Menu)
351 my ( $self, $method, $attrs ) = @_;
352 die "Usage: method must be passed as first arg" unless $method;
353 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
354 return 1 if $attrs =~ /\bClass\b/i;
355 return 1 if $method =~ /^list$/; # default class actions
361 Tell if action is a object method (See Maypole::Plugin::Menu)
366 my ( $self, $method, $attrs ) = @_;
367 die "Usage: method must be passed as first arg" unless $method;
368 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
369 return 1 if $attrs =~ /\bObject\b/i;
370 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
377 This method returns a list of has-many accessors. A brewery has many
378 beers, so C<BeerDB::Brewery> needs to return C<beers>.
383 my ( $self, $r ) = @_;
384 return keys %{ $self->meta_info('has_many') || {} };
390 Given an accessor name as a method, this function returns the class this accessor returns.
395 my ( $self, $r, $accessor ) = @_;
396 my $meta = $self->meta_info;
397 my @rels = keys %$meta;
400 $related = $meta->{$_}{$accessor};
403 return unless $related;
405 my $mapping = $related->{args}->{mapping};
406 if ( $mapping and @$mapping ) {
407 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
410 return $related->{foreign_class};
416 $class->related_meta($col);
418 Given a column associated with a relationship it will return the relatation
419 ship type and the meta info for the relationship on the column.
424 my ($self,$r, $accssr) = @_;
425 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
426 my $class_meta = $self->meta_info;
427 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
429 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
435 Returns class of a column inherited by is_a.
439 # Maybe put this in IsA?
441 my ($class, $col) = @_;
442 $class->_croak( "Need a column for isa_class." ) unless $col;
444 my $isa = $class->meta_info("is_a") || {};
445 foreach ( keys %$isa ) {
446 $isaclass = $isa->{$_}->foreign_class;
447 return $isaclass if ($isaclass->find_column($col));
449 return 0; # col not in a is_a class
452 =head2 accessor_classes
454 Returns hash ref of classes for accessors.
456 This is an attempt at a more efficient method than calling "related_class()"
457 a bunch of times when you need it for many relations.
458 It may be good to call at startup and store in a global config.
462 sub accessor_classes {
463 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
465 my $meta = $class->meta_info;
467 foreach my $rel (keys %$meta) {
468 my $rel_meta = $meta->{$rel};
469 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
474 # 2 liner to get class of accessor for $name
475 #my $meta = $class->meta_info;
476 #my ($isa) = map $_->foreign_class, grep defined,
477 # map $meta->{$_}->{$name}, keys %$meta;
482 =head2 stringify_column
484 Returns the name of the column to use when stringifying
489 sub stringify_column {
492 $class->columns("Stringify"),
493 ( grep { /^(name|title)$/i } $class->columns ),
494 ( grep { /(name|title)/i } $class->columns ),
495 ( grep { !/id$/i } $class->primary_columns ),
501 Sets the pager template argument ($r->{template_args}{pager})
502 to a Class::DBI::Pager object based on the rows_per_page
503 value set in the configuration of the application.
505 This pager is used via the pager macro in TT Templates, and
506 is also accessible via Mason.
511 my ( $self, $r ) = @_;
512 if ( my $rows = $r->config->rows_per_page ) {
513 return $r->{template_args}{pager} =
514 $self->pager( $rows, $r->query->{page} );
516 else { return $self }
522 Returns the SQL order syntax based on the order parameter passed
523 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
525 $sql .= $self->order($r);
527 If the order column is not a column of this table,
528 or an order argument is not passed, then the return value is undefined.
530 Note: the returned value does not start with a space.
535 my ( $self, $r ) = @_;
536 my %ok_columns = map { $_ => 1 } $self->columns;
538 my $order = $q->{order};
539 return unless $order and $ok_columns{$order};
540 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
546 This method is inherited from Maypole::Model::Base and calls setup_database,
547 which uses Class::DBI::Loader to create and load Class::DBI classes from
548 the given database schema.
552 =head2 setup_database
554 The $opts argument is a hashref of options. The "options" key is a hashref of
555 Database connection options . Other keys may be various Loader arguments or
556 flags. It has this form:
558 # DB connection options
559 options { AutoCommit => 1 , ... },
568 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
569 $dsn ||= $config->dsn;
570 $u ||= $config->user;
571 $p ||= $config->pass;
572 $opts ||= $config->opts;
574 warn "No DSN set in config" unless $dsn;
575 $config->loader || $config->loader(
576 Class::DBI::Loader->new(
577 namespace => $namespace,
584 $config->{classes} = [ $config->{loader}->classes ];
585 $config->{tables} = [ $config->{loader}->tables ];
587 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
588 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
589 if $namespace->debug;
594 returns class for given table
599 my ( $self, $r, $table ) = @_;
600 return $r->config->loader->_table2class($table); # why not find_class ?
605 Returns 1 or more objects of the given class when provided with the request
611 my @pcs = $class->primary_columns;
614 @pks{@pcs}=(@{$r->{args}});
615 return $class->retrieve( %pks );
617 return $class->retrieve( $r->{args}->[0] );
621 ###############################################################################
622 # private / internal functions and classes
626 $class = ref $class || $class;
628 return ${$class . '::COLUMN_INFO'};