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;
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;
104 die "do_update failed with error : $fatal" if ($fatal);
105 $r->template("edit");
107 $r->template("view");
112 $r->objects( $obj ? [$obj] : []);
115 # split out from do_edit to be reported by Mp::P::Trace
116 sub _do_update_or_create {
117 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
122 my $h = CGI::Untaint->new( %{$r->params} );
126 # We have something to edit
127 eval { $obj->update_from_cgi( $h => {
128 required => $required_cols,
129 ignore => $ignored_cols,
131 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
136 $obj = $self->create_from_cgi( $h => {
137 required => $required_cols,
138 ignore => $ignored_cols,
143 warn "FATAL ERROR: $fatal" if $r->debug;
144 # $self->dbi_rollback;
151 return $obj, $fatal, $creating;
157 Deprecated method that calls do_delete or a given classes delete method, please
158 use do_delete instead
162 Unsuprisingly, this command causes a database record to be forever lost.
164 This method replaces the, now deprecated, delete method provided in prior versions
168 sub delete : Exported {
170 my ($sub) = (caller(1))[3];
171 # So subclasses can still send delete down ...
172 $sub =~ /^(.+)::([^:]+)$/;
173 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
174 $self->SUPER::delete(@_);
176 warn "Maypole::Model::CDBI delete method is deprecated\n";
177 $self->do_delete(@_);
182 my ( $self, $r ) = @_;
183 # FIXME: handle fatal error with exception
184 $_->SUPER::delete for @{ $r->objects || [] };
186 $r->objects( [ $self->retrieve_all ] );
187 $r->{template} = "list";
193 Deprecated searching method - use do_search instead.
197 This action method searches for database records, it replaces
198 the, now deprecated, search method previously provided.
202 sub search : Exported {
204 my ($sub) = (caller(1))[3];
205 $sub =~ /^(.+)::([^:]+)$/;
206 # So subclasses can still send search down ...
207 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
208 $self->SUPER::search(@_) : $self->do_search(@_);
211 sub do_search : Exported {
212 my ( $self, $r ) = @_;
213 my %fields = map { $_ => 1 } $self->columns;
214 my $oper = "like"; # For now
215 my %params = %{ $r->{params} };
216 my %values = map { $_ => { $oper, $params{$_} } }
217 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
220 $r->template("list");
221 if ( !%values ) { return $self->list($r) }
222 my $order = $self->order($r);
223 $self = $self->do_pager($r);
227 \%values, ( $order ? { order_by => $order } : () )
231 $r->{template_args}{search} = 1;
236 The C<list> method fills C<$r-E<gt>objects> with all of the
237 objects in the class. The results are paged using a pager.
241 sub list : Exported {
242 my ( $self, $r ) = @_;
243 my $order = $self->order($r);
244 $self = $self->do_pager($r);
246 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
249 $r->objects( [ $self->retrieve_all ] );
253 #######################
254 # _process_local_srch #
255 #######################
257 # Makes the local part of the db search query
258 # Puts search prams local to this table in where array.
259 # Returns a where array ref and search criteria string.
260 # This is factored out of do_search so sub classes can override this part
261 sub _process_local_srch {
262 my ($self, $hashed) = @_;
263 my %fields = map { $_ => 1 } $self->columns;
264 my $moniker = $self->moniker;
265 my %colnames = $self->column_names;
270 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
271 $oper = $self->sql_search_oper($_);
272 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
273 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
275 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
278 return (\@where, $srch_crit);
281 #########################
282 # _process_foreign_srch #
283 #########################
285 # puts foreign search fields into select statement
286 # changes @where by ref and return sel and srch_criteria string
287 sub _process_foreign_srch {
288 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
289 my %colnames = $self->column_names;
290 my $moniker = $self->moniker;
292 foreach (keys %$hashed) {
293 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
295 my %accssr_class = %{$self->accessor_classes};
296 while (my ( $accssr, $prms) = each %foreign ) {
297 my $fclass = $accssr_class{$accssr};
298 my %fields = map { $_ => 1 } $fclass->columns;
299 my %colnames = $fclass->column_names;
302 # TODO make field name match in all cases in srch crit
305 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
306 $oper = $fclass->sql_search_oper($_);
307 $wc = $oper =~ /LIKE/i ? '%':'';
308 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
310 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
313 next unless @this_where;
314 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
316 # map relationships -- TODO use constraints in has_many and mhaves
318 my $pk = $self->primary_column;
319 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
320 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
321 "$accssr.owner_table = '" . $self->table ."'");
323 # for has_own, has_a where foreign id is in self's table
324 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
325 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
327 push @$where, @this_where;
329 return ($sel, $srch_crit);
332 ###############################################################################
335 =head1 Helper Methods
340 This class method is passed the name of a model class that represensts a table
341 and allows the master model class to do any set-up required.
346 my ( $self, $child ) = @_;
347 $child->autoupdate(1);
348 if ( my $col = $child->stringify_column ) {
349 $child->columns( Stringify => $col );
355 Tell if action is a class method (See Maypole::Plugin::Menu)
360 my ( $self, $method, $attrs ) = @_;
361 die "Usage: method must be passed as first arg" unless $method;
362 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
363 return 1 if $attrs =~ /\bClass\b/i;
364 return 1 if $method =~ /^list$/; # default class actions
370 Tell if action is a object method (See Maypole::Plugin::Menu)
375 my ( $self, $method, $attrs ) = @_;
376 die "Usage: method must be passed as first arg" unless $method;
377 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
378 return 1 if $attrs =~ /\bObject\b/i;
379 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
386 This method returns a list of has-many accessors. A brewery has many
387 beers, so C<BeerDB::Brewery> needs to return C<beers>.
392 my ( $self, $r ) = @_;
393 return keys %{ $self->meta_info('has_many') || {} };
399 Given an accessor name as a method, this function returns the class this accessor returns.
404 my ( $self, $r, $accessor ) = @_;
405 my $meta = $self->meta_info;
406 my @rels = keys %$meta;
409 $related = $meta->{$_}{$accessor};
412 return unless $related;
414 my $mapping = $related->{args}->{mapping};
415 if ( $mapping and @$mapping ) {
416 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
419 return $related->{foreign_class};
425 $class->related_meta($col);
427 Given a column associated with a relationship it will return the relatation
428 ship type and the meta info for the relationship on the column.
433 my ($self,$r, $accssr) = @_;
434 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
435 my $class_meta = $self->meta_info;
436 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
438 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
444 Returns class of a column inherited by is_a.
448 # Maybe put this in IsA?
450 my ($class, $col) = @_;
451 $class->_croak( "Need a column for isa_class." ) unless $col;
453 my $isa = $class->meta_info("is_a") || {};
454 foreach ( keys %$isa ) {
455 $isaclass = $isa->{$_}->foreign_class;
456 return $isaclass if ($isaclass->find_column($col));
458 return 0; # col not in a is_a class
461 =head2 accessor_classes
463 Returns hash ref of classes for accessors.
465 This is an attempt at a more efficient method than calling "related_class()"
466 a bunch of times when you need it for many relations.
467 It may be good to call at startup and store in a global config.
471 sub accessor_classes {
472 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
474 my $meta = $class->meta_info;
476 foreach my $rel (keys %$meta) {
477 my $rel_meta = $meta->{$rel};
478 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
483 # 2 liner to get class of accessor for $name
484 #my $meta = $class->meta_info;
485 #my ($isa) = map $_->foreign_class, grep defined,
486 # map $meta->{$_}->{$name}, keys %$meta;
491 =head2 stringify_column
493 Returns the name of the column to use when stringifying
498 sub stringify_column {
501 $class->columns("Stringify"),
502 ( grep { /^(name|title)$/i } $class->columns ),
503 ( grep { /(name|title)/i } $class->columns ),
504 ( grep { !/id$/i } $class->primary_columns ),
510 Sets the pager template argument ($r->{template_args}{pager})
511 to a Class::DBI::Pager object based on the rows_per_page
512 value set in the configuration of the application.
514 This pager is used via the pager macro in TT Templates, and
515 is also accessible via Mason.
520 my ( $self, $r ) = @_;
521 if ( my $rows = $r->config->rows_per_page ) {
522 return $r->{template_args}{pager} =
523 $self->pager( $rows, $r->query->{page} );
525 else { return $self }
531 Returns the SQL order syntax based on the order parameter passed
532 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
534 $sql .= $self->order($r);
536 If the order column is not a column of this table,
537 or an order argument is not passed, then the return value is undefined.
539 Note: the returned value does not start with a space.
544 my ( $self, $r ) = @_;
545 my %ok_columns = map { $_ => 1 } $self->columns;
547 my $order = $q->{order};
548 return unless $order and $ok_columns{$order};
549 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
555 This method is inherited from Maypole::Model::Base and calls setup_database,
556 which uses Class::DBI::Loader to create and load Class::DBI classes from
557 the given database schema.
561 =head2 setup_database
563 The $opts argument is a hashref of options. The "options" key is a hashref of
564 Database connection options . Other keys may be various Loader arguments or
565 flags. It has this form:
567 # DB connection options
568 options { AutoCommit => 1 , ... },
577 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
578 $dsn ||= $config->dsn;
579 $u ||= $config->user;
580 $p ||= $config->pass;
581 $opts ||= $config->opts;
583 warn "No DSN set in config" unless $dsn;
584 $config->loader || $config->loader(
585 Class::DBI::Loader->new(
586 namespace => $namespace,
593 $config->{classes} = [ $config->{loader}->classes ];
594 $config->{tables} = [ $config->{loader}->tables ];
596 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
597 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
598 if $namespace->debug;
603 returns class for given table
608 my ( $self, $r, $table ) = @_;
609 return $r->config->loader->_table2class($table); # why not find_class ?
614 Returns 1 or more objects of the given class when provided with the request
620 my @pcs = $class->primary_columns;
623 @pks{@pcs}=(@{$r->{args}});
624 return $class->retrieve( %pks );
626 return $class->retrieve( $r->{args}->[0] );
630 ###############################################################################
631 # private / internal functions and classes
635 $class = ref $class || $class;
637 return ${$class . '::COLUMN_INFO'};