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 Maypole::Model::CDBI::FromCGI;
30 use CGI::Untaint::Maypole;
31 our $Untainter = 'CGI::Untaint::Maypole';
35 #use Class::DBI::FromCGI;
37 #our $Untainter = 'CGI::Untaint';
39 use Class::DBI::Plugin::Type;
40 use Class::DBI::Loader;
41 use Class::DBI::AbstractSearch;
42 use Class::DBI::Plugin::RetrieveAll;
43 use Class::DBI::Pager;
45 use Lingua::EN::Inflect::Number qw(to_PL);
50 ###############################################################################
55 Action methods are methods that are accessed through web (or other public) interface.
59 If there is an object in C<$r-E<gt>objects>, then it should be edited
60 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
61 be created with those parameters, and put back into C<$r-E<gt>objects>.
62 The template should be changed to C<view>, or C<edit> if there were any
63 errors. A hash of errors will be passed to the template.
67 sub do_edit : Exported {
68 my ($self, $r, $obj) = @_;
70 my $config = $r->config;
71 my $table = $r->table;
73 # handle cancel button hit
74 if ( $r->{params}->{cancel} ) {
76 $r->objects( [$self->retrieve_all] );
80 my $required_cols = $config->{$table}->{required_cols} || [];
81 my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
83 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
85 # handle errors, if none, proceed to view the newly created/updated object
86 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
89 # Set it up as it was:
90 $r->template_args->{cgi_params} = $r->params;
93 # replace user unfriendly error messages with something nicer
95 foreach (@{$config->{$table}->{required_cols}}) {
96 next unless ($errors{$_});
99 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
100 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
101 delete $errors{$key};
104 foreach (keys %errors) {
107 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
108 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
111 undef $obj if $creating;
113 die "do_update failed with error : $fatal" if ($fatal);
114 $r->template("edit");
116 $r->template("view");
121 $r->objects( $obj ? [$obj] : []);
124 # split out from do_edit to be reported by Mp::P::Trace
125 sub _do_update_or_create {
126 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
131 my $h = $Untainter->new( %{$r->params} );
135 # 1: Required fields for update are different than create. Its only required
136 # if it is in the parameters
138 # my @real_required = ();
139 # my %required = map { $_ => 1 } @$required_cols;
140 # foreach (keys %{$r->params}) {
141 # push @real_required, $_ if $required{$_};
144 # We have something to edit
145 eval { $obj->update_from_cgi( $h => {
146 required => $required_cols,
147 ignore => $ignored_cols,
149 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
154 $obj = $self->create_from_cgi( $h => {
155 required => $required_cols,
156 ignore => $ignored_cols,
163 return $obj, $fatal, $creating;
169 Deprecated method that calls do_delete or a given classes delete method, please
170 use do_delete instead
174 Unsuprisingly, this command causes a database record to be forever lost.
176 This method replaces the, now deprecated, delete method provided in prior versions
180 sub delete : Exported {
182 my ($sub) = (caller(1))[3];
183 # So subclasses can still send delete down ...
184 $sub =~ /^(.+)::([^:]+)$/;
185 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
186 $self->SUPER::delete(@_);
188 warn "Maypole::Model::CDBI delete method is deprecated\n";
189 $self->do_delete(@_);
194 my ( $self, $r ) = @_;
195 # FIXME: handle fatal error with exception
196 $_->SUPER::delete for @{ $r->objects || [] };
198 $r->objects( [ $self->retrieve_all ] );
199 $r->{template} = "list";
205 Deprecated searching method - use do_search instead.
209 This action method searches for database records, it replaces
210 the, now deprecated, search method previously provided.
214 sub search : Exported {
216 my ($sub) = (caller(1))[3];
217 $sub =~ /^(.+)::([^:]+)$/;
218 # So subclasses can still send search down ...
219 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
220 $self->SUPER::search(@_) : $self->do_search(@_);
223 sub do_search : Exported {
224 my ( $self, $r ) = @_;
225 my %fields = map { $_ => 1 } $self->columns;
226 my $oper = "like"; # For now
227 my %params = %{ $r->{params} };
228 my %values = map { $_ => { $oper, $params{$_} } }
229 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
232 $r->template("list");
233 if ( !%values ) { return $self->list($r) }
234 my $order = $self->order($r);
235 $self = $self->do_pager($r);
239 \%values, ( $order ? { order_by => $order } : () )
243 $r->{template_args}{search} = 1;
248 The C<list> method fills C<$r-E<gt>objects> with all of the
249 objects in the class. The results are paged using a pager.
253 sub list : Exported {
254 my ( $self, $r ) = @_;
255 my $order = $self->order($r);
256 $self = $self->do_pager($r);
258 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
261 $r->objects( [ $self->retrieve_all ] );
265 #######################
266 # _process_local_srch #
267 #######################
269 # Makes the local part of the db search query
270 # Puts search prams local to this table in where array.
271 # Returns a where array ref and search criteria string.
272 # This is factored out of do_search so sub classes can override this part
273 sub _process_local_srch {
274 my ($self, $hashed) = @_;
275 my %fields = map { $_ => 1 } $self->columns;
276 my $moniker = $self->moniker;
277 my %colnames = $self->column_names;
282 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
283 $oper = $self->sql_search_oper($_);
284 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
285 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
287 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
290 return (\@where, $srch_crit);
293 #########################
294 # _process_foreign_srch #
295 #########################
297 # puts foreign search fields into select statement
298 # changes @where by ref and return sel and srch_criteria string
299 sub _process_foreign_srch {
300 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
301 my %colnames = $self->column_names;
302 my $moniker = $self->moniker;
304 foreach (keys %$hashed) {
305 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
307 my %accssr_class = %{$self->accessor_classes};
308 while (my ( $accssr, $prms) = each %foreign ) {
309 my $fclass = $accssr_class{$accssr};
310 my %fields = map { $_ => 1 } $fclass->columns;
311 my %colnames = $fclass->column_names;
314 # TODO make field name match in all cases in srch crit
317 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
318 $oper = $fclass->sql_search_oper($_);
319 $wc = $oper =~ /LIKE/i ? '%':'';
320 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
322 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
325 next unless @this_where;
326 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
328 # map relationships -- TODO use constraints in has_many and mhaves
330 my $pk = $self->primary_column;
331 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
332 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
333 "$accssr.owner_table = '" . $self->table ."'");
335 # for has_own, has_a where foreign id is in self's table
336 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
337 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
339 push @$where, @this_where;
341 return ($sel, $srch_crit);
344 ###############################################################################
347 =head1 Helper Methods
352 This class method is passed the name of a model class that represensts a table
353 and allows the master model class to do any set-up required.
358 my ( $self, $child ) = @_;
359 $child->autoupdate(1);
360 if ( my $col = $child->stringify_column ) {
361 $child->columns( Stringify => $col );
367 Tell if action is a class method (See Maypole::Plugin::Menu)
372 my ( $self, $method, $attrs ) = @_;
373 die "Usage: method must be passed as first arg" unless $method;
374 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
375 return 1 if $attrs =~ /\bClass\b/i;
376 return 1 if $method =~ /^list$/; # default class actions
382 Tell if action is a object method (See Maypole::Plugin::Menu)
387 my ( $self, $method, $attrs ) = @_;
388 die "Usage: method must be passed as first arg" unless $method;
389 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
390 return 1 if $attrs =~ /\bObject\b/i;
391 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
398 This method returns a list of has-many accessors. A brewery has many
399 beers, so C<BeerDB::Brewery> needs to return C<beers>.
404 my ( $self, $r ) = @_;
405 return keys %{ $self->meta_info('has_many') || {} };
411 Given an accessor name as a method, this function returns the class this accessor returns.
416 my ( $self, $r, $accessor ) = @_;
417 my $meta = $self->meta_info;
418 my @rels = keys %$meta;
421 $related = $meta->{$_}{$accessor};
424 return unless $related;
426 my $mapping = $related->{args}->{mapping};
427 if ( $mapping and @$mapping ) {
428 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
431 return $related->{foreign_class};
437 $class->related_meta($col);
439 Given a column associated with a relationship it will return the relatation
440 ship type and the meta info for the relationship on the column.
445 my ($self,$r, $accssr) = @_;
446 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
447 my $class_meta = $self->meta_info;
448 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
450 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
456 Returns class of a column inherited by is_a.
460 # Maybe put this in IsA?
462 my ($class, $col) = @_;
463 $class->_croak( "Need a column for isa_class." ) unless $col;
465 my $isa = $class->meta_info("is_a") || {};
466 foreach ( keys %$isa ) {
467 $isaclass = $isa->{$_}->foreign_class;
468 return $isaclass if ($isaclass->find_column($col));
470 return 0; # col not in a is_a class
473 =head2 accessor_classes
475 Returns hash ref of classes for accessors.
477 This is an attempt at a more efficient method than calling "related_class()"
478 a bunch of times when you need it for many relations.
479 It may be good to call at startup and store in a global config.
483 sub accessor_classes {
484 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
486 my $meta = $class->meta_info;
488 foreach my $rel (keys %$meta) {
489 my $rel_meta = $meta->{$rel};
490 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
495 # 2 liner to get class of accessor for $name
496 #my $meta = $class->meta_info;
497 #my ($isa) = map $_->foreign_class, grep defined,
498 # map $meta->{$_}->{$name}, keys %$meta;
503 =head2 stringify_column
505 Returns the name of the column to use when stringifying
510 sub stringify_column {
513 $class->columns("Stringify"),
514 ( grep { /^(name|title)$/i } $class->columns ),
515 ( grep { /(name|title)/i } $class->columns ),
516 ( grep { !/id$/i } $class->primary_columns ),
522 Sets the pager template argument ($r->{template_args}{pager})
523 to a Class::DBI::Pager object based on the rows_per_page
524 value set in the configuration of the application.
526 This pager is used via the pager macro in TT Templates, and
527 is also accessible via Mason.
532 my ( $self, $r ) = @_;
533 if ( my $rows = $r->config->rows_per_page ) {
534 return $r->{template_args}{pager} =
535 $self->pager( $rows, $r->query->{page} );
537 else { return $self }
543 Returns the SQL order syntax based on the order parameter passed
544 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
546 $sql .= $self->order($r);
548 If the order column is not a column of this table,
549 or an order argument is not passed, then the return value is undefined.
551 Note: the returned value does not start with a space.
556 my ( $self, $r ) = @_;
557 my %ok_columns = map { $_ => 1 } $self->columns;
559 my $order = $q->{order};
560 return unless $order and $ok_columns{$order};
561 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
567 This method is inherited from Maypole::Model::Base and calls setup_database,
568 which uses Class::DBI::Loader to create and load Class::DBI classes from
569 the given database schema.
573 =head2 setup_database
575 The $opts argument is a hashref of options. The "options" key is a hashref of
576 Database connection options . Other keys may be various Loader arguments or
577 flags. It has this form:
579 # DB connection options
580 options { AutoCommit => 1 , ... },
589 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
590 $dsn ||= $config->dsn;
591 $u ||= $config->user;
592 $p ||= $config->pass;
593 $opts ||= $config->opts;
595 warn "No DSN set in config" unless $dsn;
596 $config->loader || $config->loader(
597 Class::DBI::Loader->new(
598 namespace => $namespace,
605 $config->{classes} = [ $config->{loader}->classes ];
606 $config->{tables} = [ $config->{loader}->tables ];
608 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
609 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
610 if $namespace->debug;
615 returns class for given table
620 my ( $self, $r, $table ) = @_;
621 return $r->config->loader->_table2class($table); # why not find_class ?
626 Returns 1 or more objects of the given class when provided with the request
632 my @pcs = $class->primary_columns;
635 @pks{@pcs}=(@{$r->{args}});
636 return $class->retrieve( %pks );
638 return $class->retrieve( $r->{args}->[0] );
642 ###############################################################################
643 # private / internal functions and classes
647 $class = ref $class || $class;
649 return ${$class . '::COLUMN_INFO'};