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;
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 $sub =~ /^(.+)::([^:]+)$/;
162 # So subclasses can still send search down ...
163 return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
164 $self->SUPER::search(@_) : $self->do_delete(@_);
168 my ( $self, $r ) = @_;
169 $_->SUPER::delete for @{ $r->objects || [] };
170 $r->objects( [ $self->retrieve_all ] );
171 $r->{template} = "list";
177 Deprecated searching method - use do_search instead.
181 This action method searches for database records, it replaces
182 the, now deprecated, search method previously provided.
186 sub search : Exported {
188 my ($sub) = (caller(1))[3];
189 $sub =~ /^(.+)::([^:]+)$/;
190 # So subclasses can still send search down ...
191 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
192 $self->SUPER::search(@_) : $self->do_search(@_);
195 sub do_search : Exported {
196 my ( $self, $r ) = @_;
197 my %fields = map { $_ => 1 } $self->columns;
198 my $oper = "like"; # For now
199 my %params = %{ $r->{params} };
200 my %values = map { $_ => { $oper, $params{$_} } }
201 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
204 $r->template("list");
205 if ( !%values ) { return $self->list($r) }
206 my $order = $self->order($r);
207 $self = $self->do_pager($r);
211 \%values, ( $order ? { order_by => $order } : () )
215 $r->{template_args}{search} = 1;
220 The C<list> method fills C<$r-E<gt>objects> with all of the
221 objects in the class. The results are paged using a pager.
225 sub list : Exported {
226 my ( $self, $r ) = @_;
227 my $order = $self->order($r);
228 $self = $self->do_pager($r);
230 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
233 $r->objects( [ $self->retrieve_all ] );
237 #######################
238 # _process_local_srch #
239 #######################
241 # Makes the local part of the db search query
242 # Puts search prams local to this table in where array.
243 # Returns a where array ref and search criteria string.
244 # This is factored out of do_search so sub classes can override this part
245 sub _process_local_srch {
246 my ($self, $hashed) = @_;
247 my %fields = map { $_ => 1 } $self->columns;
248 my $moniker = $self->moniker;
249 my %colnames = $self->column_names;
254 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
255 $oper = $self->sql_search_oper($_);
256 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
257 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
259 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
262 return (\@where, $srch_crit);
265 #########################
266 # _process_foreign_srch #
267 #########################
269 # puts foreign search fields into select statement
270 # changes @where by ref and return sel and srch_criteria string
271 sub _process_foreign_srch {
272 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
273 my %colnames = $self->column_names;
274 my $moniker = $self->moniker;
276 foreach (keys %$hashed) {
277 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
279 my %accssr_class = %{$self->accessor_classes};
280 while (my ( $accssr, $prms) = each %foreign ) {
281 my $fclass = $accssr_class{$accssr};
282 my %fields = map { $_ => 1 } $fclass->columns;
283 my %colnames = $fclass->column_names;
286 # TODO make field name match in all cases in srch crit
289 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
290 $oper = $fclass->sql_search_oper($_);
291 $wc = $oper =~ /LIKE/i ? '%':'';
292 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
294 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
297 next unless @this_where;
298 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
300 # map relationships -- TODO use constraints in has_many and mhaves
302 my $pk = $self->primary_column;
303 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
304 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
305 "$accssr.owner_table = '" . $self->table ."'");
307 # for has_own, has_a where foreign id is in self's table
308 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
309 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
311 push @$where, @this_where;
313 return ($sel, $srch_crit);
316 ###############################################################################
319 =head1 Helper Methods
324 This class method is passed the name of a model class that represensts a table
325 and allows the master model class to do any set-up required.
330 my ( $self, $child ) = @_;
331 $child->autoupdate(1);
332 if ( my $col = $child->stringify_column ) {
333 $child->columns( Stringify => $col );
339 Tell if action is a class method (See Maypole::Plugin::Menu)
344 my ( $self, $method, $attrs ) = @_;
345 die "Usage: method must be passed as first arg" unless $method;
346 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
347 return 1 if $attrs =~ /\bClass\b/i;
348 return 1 if $method =~ /^list$/; # default class actions
354 Tell if action is a object method (See Maypole::Plugin::Menu)
359 my ( $self, $method, $attrs ) = @_;
360 die "Usage: method must be passed as first arg" unless $method;
361 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
362 return 1 if $attrs =~ /\bObject\b/i;
363 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
370 This method returns a list of has-many accessors. A brewery has many
371 beers, so C<BeerDB::Brewery> needs to return C<beers>.
376 my ( $self, $r ) = @_;
377 return keys %{ $self->meta_info('has_many') || {} };
383 Given an accessor name as a method, this function returns the class this accessor returns.
388 my ( $self, $r, $accessor ) = @_;
389 my $meta = $self->meta_info;
390 my @rels = keys %$meta;
393 $related = $meta->{$_}{$accessor};
396 return unless $related;
398 my $mapping = $related->{args}->{mapping};
399 if ( $mapping and @$mapping ) {
400 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
403 return $related->{foreign_class};
409 $class->related_meta($col);
411 Given a column associated with a relationship it will return the relatation
412 ship type and the meta info for the relationship on the column.
417 my ($self,$r, $accssr) = @_;
418 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
419 my $class_meta = $self->meta_info;
420 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
422 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
428 Returns class of a column inherited by is_a.
432 # Maybe put this in IsA?
434 my ($class, $col) = @_;
435 $class->_croak( "Need a column for isa_class." ) unless $col;
437 my $isa = $class->meta_info("is_a") || {};
438 foreach ( keys %$isa ) {
439 $isaclass = $isa->{$_}->foreign_class;
440 return $isaclass if ($isaclass->find_column($col));
442 return 0; # col not in a is_a class
445 =head2 accessor_classes
447 Returns hash ref of classes for accessors.
449 This is an attempt at a more efficient method than calling "related_class()"
450 a bunch of times when you need it for many relations.
451 It may be good to call at startup and store in a global config.
455 sub accessor_classes {
456 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
458 my $meta = $class->meta_info;
460 foreach my $rel (keys %$meta) {
461 my $rel_meta = $meta->{$rel};
462 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
467 # 2 liner to get class of accessor for $name
468 #my $meta = $class->meta_info;
469 #my ($isa) = map $_->foreign_class, grep defined,
470 # map $meta->{$_}->{$name}, keys %$meta;
475 =head2 stringify_column
477 Returns the name of the column to use when stringifying
482 sub stringify_column {
485 $class->columns("Stringify"),
486 ( grep { /^(name|title)$/i } $class->columns ),
487 ( grep { /(name|title)/i } $class->columns ),
488 ( grep { !/id$/i } $class->primary_columns ),
494 Sets the pager template argument ($r->{template_args}{pager})
495 to a Class::DBI::Pager object based on the rows_per_page
496 value set in the configuration of the application.
498 This pager is used via the pager macro in TT Templates, and
499 is also accessible via Mason.
504 my ( $self, $r ) = @_;
505 if ( my $rows = $r->config->rows_per_page ) {
506 return $r->{template_args}{pager} =
507 $self->pager( $rows, $r->query->{page} );
509 else { return $self }
515 Returns the SQL order syntax based on the order parameter passed
516 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
518 $sql .= $self->order($r);
520 If the order column is not a column of this table,
521 or an order argument is not passed, then the return value is undefined.
523 Note: the returned value does not start with a space.
528 my ( $self, $r ) = @_;
529 my %ok_columns = map { $_ => 1 } $self->columns;
531 my $order = $q->{order};
532 return unless $order and $ok_columns{$order};
533 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
539 This method is inherited from Maypole::Model::Base and calls setup_database,
540 which uses Class::DBI::Loader to create and load Class::DBI classes from
541 the given database schema.
545 =head2 setup_database
547 The $opts argument is a hashref of options. The "options" key is a hashref of
548 Database connection options . Other keys may be various Loader arguments or
549 flags. It has this form:
551 # DB connection options
552 options { AutoCommit => 1 , ... },
561 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
562 $dsn ||= $config->dsn;
563 $u ||= $config->user;
564 $p ||= $config->pass;
565 $opts ||= $config->opts;
567 warn "No DSN set in config" unless $dsn;
568 $config->loader || $config->loader(
569 Class::DBI::Loader->new(
570 namespace => $namespace,
577 $config->{classes} = [ $config->{loader}->classes ];
578 $config->{tables} = [ $config->{loader}->tables ];
579 warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
580 if $namespace->debug;
585 returns class for given table
590 my ( $self, $r, $table ) = @_;
591 return $r->config->loader->_table2class($table); # why not find_class ?
596 Returns 1 or more objects of the given class when provided with the request
602 my @pcs = $class->primary_columns;
605 @pks{@pcs}=(@{$r->{args}});
606 return $class->retrieve( %pks );
608 return $class->retrieve( $r->{args}->[0] );
612 ###############################################################################
613 # private / internal functions and classes
617 $class = ref $class || $class;
619 return ${$class . '::COLUMN_INFO'};