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 Unsuprisingly, this command causes a database record to be forever lost.
149 This method replaces the, now deprecated, delete method provided in prior versions
153 sub delete : Exported {
155 my ($sub) = (caller(1))[3];
156 $sub =~ /^(.+)::([^:]+)$/;
157 # So subclasses can still send search down ...
158 return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
159 $self->SUPER::search(@_) : $self->do_delete(@_);
163 my ( $self, $r ) = @_;
164 $_->SUPER::delete for @{ $r->objects || [] };
165 $r->objects( [ $self->retrieve_all ] );
166 $r->{template} = "list";
173 This action method searches for database records, it replaces
174 the, now deprecated, search method previously provided.
178 sub search : Exported {
180 my ($sub) = (caller(1))[3];
181 $sub =~ /^(.+)::([^:]+)$/;
182 # So subclasses can still send search down ...
183 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
184 $self->SUPER::search(@_) : $self->do_search(@_);
187 sub do_search : Exported {
188 my ( $self, $r ) = @_;
189 my %fields = map { $_ => 1 } $self->columns;
190 my $oper = "like"; # For now
191 my %params = %{ $r->{params} };
192 my %values = map { $_ => { $oper, $params{$_} } }
193 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
196 $r->template("list");
197 if ( !%values ) { return $self->list($r) }
198 my $order = $self->order($r);
199 $self = $self->do_pager($r);
203 \%values, ( $order ? { order_by => $order } : () )
207 $r->{template_args}{search} = 1;
212 The C<list> method fills C<$r-E<gt>objects> with all of the
213 objects in the class. The results are paged using a pager.
217 sub list : Exported {
218 my ( $self, $r ) = @_;
219 my $order = $self->order($r);
220 $self = $self->do_pager($r);
222 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
225 $r->objects( [ $self->retrieve_all ] );
229 #######################
230 # _process_local_srch #
231 #######################
233 # Makes the local part of the db search query
234 # Puts search prams local to this table in where array.
235 # Returns a where array ref and search criteria string.
236 # This is factored out of do_search so sub classes can override this part
237 sub _process_local_srch {
238 my ($self, $hashed) = @_;
239 my %fields = map { $_ => 1 } $self->columns;
240 my $moniker = $self->moniker;
241 my %colnames = $self->column_names;
246 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
247 $oper = $self->sql_search_oper($_);
248 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
249 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
251 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
254 return (\@where, $srch_crit);
257 #########################
258 # _process_foreign_srch #
259 #########################
261 # puts foreign search fields into select statement
262 # changes @where by ref and return sel and srch_criteria string
263 sub _process_foreign_srch {
264 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
265 my %colnames = $self->column_names;
266 my $moniker = $self->moniker;
268 foreach (keys %$hashed) {
269 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
271 my %accssr_class = %{$self->accessor_classes};
272 while (my ( $accssr, $prms) = each %foreign ) {
273 my $fclass = $accssr_class{$accssr};
274 my %fields = map { $_ => 1 } $fclass->columns;
275 my %colnames = $fclass->column_names;
278 # TODO make field name match in all cases in srch crit
281 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
282 $oper = $fclass->sql_search_oper($_);
283 $wc = $oper =~ /LIKE/i ? '%':'';
284 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
286 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
289 next unless @this_where;
290 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
292 # map relationships -- TODO use constraints in has_many and mhaves
294 my $pk = $self->primary_column;
295 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
296 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
297 "$accssr.owner_table = '" . $self->table ."'");
299 # for has_own, has_a where foreign id is in self's table
300 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
301 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
303 push @$where, @this_where;
305 return ($sel, $srch_crit);
308 ###############################################################################
311 =head1 Helper Methods
316 This class method is passed the name of a model class that represensts a table
317 and allows the master model class to do any set-up required.
322 my ( $self, $child ) = @_;
323 $child->autoupdate(1);
324 if ( my $col = $child->stringify_column ) {
325 $child->columns( Stringify => $col );
331 Tell if action is a class method (See Maypole::Plugin::Menu)
336 my ( $self, $method, $attrs ) = @_;
337 die "Usage: method must be passed as first arg" unless $method;
338 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
339 return 1 if $attrs =~ /\bClass\b/i;
340 return 1 if $method =~ /^list$/; # default class actions
346 Tell if action is a object 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 =~ /\bObject\b/i;
355 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
362 This method returns a list of has-many accessors. A brewery has many
363 beers, so C<BeerDB::Brewery> needs to return C<beers>.
368 my ( $self, $r ) = @_;
369 return keys %{ $self->meta_info('has_many') || {} };
375 Given an accessor name as a method, this function returns the class this accessor returns.
380 my ( $self, $r, $accessor ) = @_;
381 my $meta = $self->meta_info;
382 my @rels = keys %$meta;
385 $related = $meta->{$_}{$accessor};
388 return unless $related;
390 my $mapping = $related->{args}->{mapping};
391 if ( $mapping and @$mapping ) {
392 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
395 return $related->{foreign_class};
401 $class->related_meta($col);
403 Given a column associated with a relationship it will return the relatation
404 ship type and the meta info for the relationship on the column.
409 my ($self,$r, $accssr) = @_;
410 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
411 my $class_meta = $self->meta_info;
412 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
414 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
420 Returns class of a column inherited by is_a.
424 # Maybe put this in IsA?
426 my ($class, $col) = @_;
427 $class->_croak( "Need a column for isa_class." ) unless $col;
429 my $isa = $class->meta_info("is_a") || {};
430 foreach ( keys %$isa ) {
431 $isaclass = $isa->{$_}->foreign_class;
432 return $isaclass if ($isaclass->find_column($col));
434 return 0; # col not in a is_a class
437 =head2 accessor_classes
439 Returns hash ref of classes for accessors.
441 This is an attempt at a more efficient method than calling "related_class()"
442 a bunch of times when you need it for many relations.
443 It may be good to call at startup and store in a global config.
447 sub accessor_classes {
448 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
450 my $meta = $class->meta_info;
452 foreach my $rel (keys %$meta) {
453 my $rel_meta = $meta->{$rel};
454 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
459 # 2 liner to get class of accessor for $name
460 #my $meta = $class->meta_info;
461 #my ($isa) = map $_->foreign_class, grep defined,
462 # map $meta->{$_}->{$name}, keys %$meta;
467 =head2 stringify_column
469 Returns the name of the column to use when stringifying
474 sub stringify_column {
477 $class->columns("Stringify"),
478 ( grep { /^(name|title)$/i } $class->columns ),
479 ( grep { /(name|title)/i } $class->columns ),
480 ( grep { !/id$/i } $class->primary_columns ),
486 Sets the pager template argument ($r->{template_args}{pager})
487 to a Class::DBI::Pager object based on the rows_per_page
488 value set in the configuration of the application.
490 This pager is used via the pager macro in TT Templates, and
491 is also accessible via Mason.
496 my ( $self, $r ) = @_;
497 if ( my $rows = $r->config->rows_per_page ) {
498 return $r->{template_args}{pager} =
499 $self->pager( $rows, $r->query->{page} );
501 else { return $self }
507 Returns the SQL order syntax based on the order parameter passed
508 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
510 $sql .= $self->order($r);
512 If the order column is not a column of this table,
513 or an order argument is not passed, then the return value is undefined.
515 Note: the returned value does not start with a space.
520 my ( $self, $r ) = @_;
521 my %ok_columns = map { $_ => 1 } $self->columns;
523 my $order = $q->{order};
524 return unless $order and $ok_columns{$order};
525 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
531 This method is inherited from Maypole::Model::Base and calls setup_database,
532 which uses Class::DBI::Loader to create and load Class::DBI classes from
533 the given database schema.
537 =head2 setup_database
539 The $opts argument is a hashref of options. The "options" key is a hashref of
540 Database connection options . Other keys may be various Loader arguments or
541 flags. It has this form:
543 # DB connection options
544 options { AutoCommit => 1 , ... },
553 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
554 $dsn ||= $config->dsn;
555 $u ||= $config->user;
556 $p ||= $config->pass;
557 $opts ||= $config->opts;
559 warn "No DSN set in config" unless $dsn;
560 $config->loader || $config->loader(
561 Class::DBI::Loader->new(
562 namespace => $namespace,
569 $config->{classes} = [ $config->{loader}->classes ];
570 $config->{tables} = [ $config->{loader}->tables ];
571 warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
572 if $namespace->debug;
577 returns class for given table
582 my ( $self, $r, $table ) = @_;
583 return $r->config->loader->_table2class($table); # why not find_class ?
588 my @pcs = $class->primary_columns;
591 @pks{@pcs}=(@{$r->{args}});
592 return $class->retrieve( %pks );
594 return $class->retrieve( $r->{args}->[0] );
598 ###############################################################################
599 # private / internal functions and classes
603 $class = ref $class || $class;
605 return ${$class . '::COLUMN_INFO'};