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>.
21 use base qw(Maypole::Model::Base Class::DBI);
22 use Maypole::Model::CDBI::AsForm;
23 use CGI::Untaint::Maypole;
25 use Class::DBI::FromCGI;
26 use Class::DBI::Loader;
27 use Class::DBI::AbstractSearch;
28 use Class::DBI::Plugin::RetrieveAll;
29 use Class::DBI::Pager;
31 use Lingua::EN::Inflect::Number qw(to_PL);
34 ###############################################################################
39 Action methods are methods that are accessed through web (or other public) interface.
43 If there is an object in C<$r-E<gt>objects>, then it should be edited
44 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
45 be created with those parameters, and put back into C<$r-E<gt>objects>.
46 The template should be changed to C<view>, or C<edit> if there were any
47 errors. A hash of errors will be passed to the template.
51 sub do_edit : Exported {
52 my ($self, $r, $obj) = @_;
54 my $config = $r->config;
55 my $table = $r->table;
57 # handle cancel button hits
58 if ( $r->{params}->{cancel} ) {
60 $r->objects( [$self->retrieve_all] );
64 my $required_cols = $config->{$table}->{required_cols} || [];
65 my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
67 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
69 # handle errors, if none, proceed to view the newly created/updated object
70 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
73 # Set it up as it was:
74 $r->template_args->{cgi_params} = $r->params;
75 $r->template_args->{errors} = \%errors;
77 undef $obj if $creating;
83 $r->objects( $obj ? [$obj] : []);
86 # split out from do_edit to be reported by Mp::P::Trace
87 sub _do_update_or_create {
88 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
92 my $h = CGI::Untaint::Maypole->new( %{$r->params} );
96 # We have something to edit
97 eval { $obj->update_from_cgi( $h => {
98 required => $required_cols,
99 ignore => $ignored_cols,
104 $obj = $self->create_from_cgi( $h => {
105 required => $required_cols,
106 ignore => $ignored_cols,
111 warn "$fatal" if $r->debug;
116 return $obj, $fatal, $creating;
122 Unsuprisingly, this command causes a database record to be forever lost.
124 This method replaces the, now deprecated, delete method provided in prior versions
128 sub delete : Exported {
130 my ($sub) = (caller(1))[3];
131 $sub =~ /^(.+)::([^:]+)$/;
132 # So subclasses can still send search down ...
133 return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
134 $self->SUPER::search(@_) : $self->do_delete(@_);
138 my ( $self, $r ) = @_;
139 $_->SUPER::delete for @{ $r->objects || [] };
140 $r->objects( [ $self->retrieve_all ] );
141 $r->{template} = "list";
148 This action method searches for database records, it replaces
149 the, now deprecated, search method previously provided.
153 sub search : 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 "search") ?
159 $self->SUPER::search(@_) : $self->do_search(@_);
162 sub do_search : Exported {
163 my ( $self, $r ) = @_;
164 my %fields = map { $_ => 1 } $self->columns;
165 my $oper = "like"; # For now
166 my %params = %{ $r->{params} };
167 my %values = map { $_ => { $oper, $params{$_} } }
168 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
171 $r->template("list");
172 if ( !%values ) { return $self->list($r) }
173 my $order = $self->order($r);
174 $self = $self->do_pager($r);
178 \%values, ( $order ? { order_by => $order } : () )
182 $r->{template_args}{search} = 1;
187 The C<list> method fills C<$r-E<gt>objects> with all of the
188 objects in the class. The results are paged using a pager.
192 sub list : Exported {
193 my ( $self, $r ) = @_;
194 my $order = $self->order($r);
195 $self = $self->do_pager($r);
197 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
200 $r->objects( [ $self->retrieve_all ] );
204 #######################
205 # _process_local_srch #
206 #######################
208 # Makes the local part of the db search query
209 # Puts search prams local to this table in where array.
210 # Returns a where array ref and search criteria string.
211 # This is factored out of do_search so sub classes can override this part
212 sub _process_local_srch {
213 my ($self, $hashed) = @_;
214 my %fields = map { $_ => 1 } $self->columns;
215 my $moniker = $self->moniker;
216 my %colnames = $self->column_names;
221 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
222 $oper = $self->sql_search_oper($_);
223 $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
224 "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
226 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
229 return (\@where, $srch_crit);
232 #########################
233 # _process_foreign_srch #
234 #########################
236 # puts foreign search fields into select statement
237 # changes @where by ref and return sel and srch_criteria string
238 sub _process_foreign_srch {
239 my ($self, $hashed, $sel, $where, $srch_crit) = @_;
240 my %colnames = $self->column_names;
241 my $moniker = $self->moniker;
243 foreach (keys %$hashed) {
244 $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
246 my %accssr_class = %{$self->accessor_classes};
247 while (my ( $accssr, $prms) = each %foreign ) {
248 my $fclass = $accssr_class{$accssr};
249 my %fields = map { $_ => 1 } $fclass->columns;
250 my %colnames = $fclass->column_names;
253 # TODO make field name match in all cases in srch crit
256 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
257 $oper = $fclass->sql_search_oper($_);
258 $wc = $oper =~ /LIKE/i ? '%':'';
259 "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
261 grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
264 next unless @this_where;
265 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
267 # map relationships -- TODO use constraints in has_many and mhaves
269 my $pk = $self->primary_column;
270 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
271 unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
272 "$accssr.owner_table = '" . $self->table ."'");
274 # for has_own, has_a where foreign id is in self's table
275 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
276 unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
278 push @$where, @this_where;
280 return ($sel, $srch_crit);
283 ###############################################################################
286 =head1 Helper Methods
291 This class method is passed the name of a model class that represensts a table
292 and allows the master model class to do any set-up required.
297 my ( $self, $child ) = @_;
298 $child->autoupdate(1);
299 if ( my $col = $child->stringify_column ) {
300 $child->columns( Stringify => $col );
306 Tell if action is a class method (See Maypole::Plugin::Menu)
311 my ( $self, $method, $attrs ) = @_;
312 die "Usage: method must be passed as first arg" unless $method;
313 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
314 return 1 if $attrs =~ /\bClass\b/i;
315 return 1 if $method =~ /^list$/; # default class actions
321 Tell if action is a object method (See Maypole::Plugin::Menu)
326 my ( $self, $method, $attrs ) = @_;
327 die "Usage: method must be passed as first arg" unless $method;
328 $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
329 return 1 if $attrs =~ /\bObject\b/i;
330 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
337 This method returns a list of has-many accessors. A brewery has many
338 beers, so C<BeerDB::Brewery> needs to return C<beers>.
343 my ( $self, $r ) = @_;
344 return keys %{ $self->meta_info('has_many') || {} };
350 Given an accessor name as a method, this function returns the class this accessor returns.
355 my ( $self, $r, $accessor ) = @_;
356 my $meta = $self->meta_info;
357 my @rels = keys %$meta;
360 $related = $meta->{$_}{$accessor};
363 return unless $related;
365 my $mapping = $related->{args}->{mapping};
366 if ( $mapping and @$mapping ) {
367 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
370 return $related->{foreign_class};
376 $class->related_meta($col);
378 Given a column associated with a relationship it will return the relatation
379 ship type and the meta info for the relationship on the column.
384 my ($self,$r, $accssr) = @_;
385 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
386 my $class_meta = $self->meta_info;
387 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
389 { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
395 Returns class of a column inherited by is_a.
399 # Maybe put this in IsA?
401 my ($class, $col) = @_;
402 $class->_croak( "Need a column for isa_class." ) unless $col;
404 my $isa = $class->meta_info("is_a") || {};
405 foreach ( keys %$isa ) {
406 $isaclass = $isa->{$_}->foreign_class;
407 return $isaclass if ($isaclass->find_column($col));
409 return 0; # col not in a is_a class
412 =head2 accessor_classes
414 Returns hash ref of classes for accessors.
416 This is an attempt at a more efficient method than calling "related_class()"
417 a bunch of times when you need it for many relations.
418 It may be good to call at startup and store in a global config.
422 sub accessor_classes {
423 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
425 my $meta = $class->meta_info;
427 foreach my $rel (keys %$meta) {
428 my $rel_meta = $meta->{$rel};
429 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
434 # 2 liner to get class of accessor for $name
435 #my $meta = $class->meta_info;
436 #my ($isa) = map $_->foreign_class, grep defined,
437 # map $meta->{$_}->{$name}, keys %$meta;
442 =head2 stringify_column
446 sub stringify_column {
449 $class->columns("Stringify"),
450 ( grep { /^(name|title)$/i } $class->columns ),
451 ( grep { /(name|title)/i } $class->columns ),
452 ( grep { !/id$/i } $class->primary_columns ),
461 my ( $self, $r ) = @_;
462 if ( my $rows = $r->config->rows_per_page ) {
463 return $r->{template_args}{pager} =
464 $self->pager( $rows, $r->query->{page} );
466 else { return $self }
475 my ( $self, $r ) = @_;
476 my %ok_columns = map { $_ => 1 } $self->columns;
478 my $order = $q->{order};
479 return unless $order and $ok_columns{$order};
480 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
484 =head2 setup_database
489 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
490 $dsn ||= $config->dsn;
491 $u ||= $config->user;
492 $p ||= $config->pass;
493 $opts ||= $config->opts;
495 warn "No DSN set in config" unless $dsn;
496 $config->loader || $config->loader(
497 Class::DBI::Loader->new(
498 namespace => $namespace,
505 $config->{classes} = [ $config->{loader}->classes ];
506 $config->{tables} = [ $config->{loader}->tables ];
507 warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
508 if $namespace->debug;
512 my ( $self, $r, $table ) = @_;
513 return $r->config->loader->_table2class($table); # why not find_class ?
518 my @pcs = $class->primary_columns;
521 @pks{@pcs}=(@{$r->{args}});
522 return $class->retrieve( %pks );
524 return $class->retrieve( $r->{args}->[0] );
528 ###############################################################################
529 # private / internal functions and classes
533 $class = ref $class || $class;
535 return ${$class . '::COLUMN_INFO'};