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 Should return true if a certain action is supported, or false otherwise.
307 Defaults to checking if the sub has the C<:Exported> attribute.
312 my ( $self, $action, $attrs ) = @_;
313 my $cv = $self->can($action);
314 warn "is_public failed . action is $action. self is $self" and return 0 unless $cv;
316 my @attrs = attributes::get($cv) || ();
317 $attrs = join " ", @attrs;
320 warn "is_public failed .$action not exported" if Maypole->debug;
322 } unless $attrs =~ /\bExported\b/i;
329 Tell if action is a class method (See Maypole::Plugin::Menu)
334 my ( $self, $method, $attrs ) = @_;
335 die "Usage: method must be passed as first arg" unless $method;
336 $attrs = $self->method_attrs($method) unless ($attrs);
337 return 1 if $attrs =~ /\bClass\b/i;
338 return 1 if $method =~ /^list$/; # default class actions
344 Tell if action is a object method (See Maypole::Plugin::Menu)
349 my ( $self, $method, $attrs ) = @_;
350 die "Usage: method must be passed as first arg" unless $method;
351 $attrs = $self->method_attrs($method) unless ($attrs);
352 return 1 if $attrs =~ /\bObject\b/i;
353 return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
357 # Get string of joined attributes for matching
359 my ($class, $method) = @_;
360 my $cv = $class->can($method);
362 my @attrs = attributes::get($cv) || ();
363 return join " ", @attrs;
368 This method returns a list of has-many accessors. A brewery has many
369 beers, so C<BeerDB::Brewery> needs to return C<beers>.
374 my ( $self, $r ) = @_;
375 return keys %{ $self->meta_info('has_many') || {} };
381 Given an accessor name as a method, this function returns the class this accessor returns.
386 my ( $self, $r, $accessor ) = @_;
387 my $meta = $self->meta_info;
388 my @rels = keys %$meta;
391 $related = $meta->{$_}{$accessor};
394 return unless $related;
396 my $mapping = $related->{args}->{mapping};
397 if ( $mapping and @$mapping ) {
398 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
401 return $related->{foreign_class};
407 Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels)
412 my ($class, $col) = @_;
413 $class->_croak( "Need a column for isa_class." ) unless $col;
415 # class col is first found in is returned
416 my $isa = $class->meta_info("is_a") || {};
417 foreach ( keys %$isa ) {
418 $isaclass = $isa->{$_}->foreign_class;
419 return $isaclass if ($isaclass->find_column($col));
421 return 0; # col not in a is_a class
424 =head2 accessor_classes
426 Returns hash ref of classes for accessors.
428 This is an attempt at a more efficient method than calling "related_class()"
429 a bunch of times when you need it for many relations.
433 sub accessor_classes {
434 my ($self, $class) = @_; # can pass a class arg to get accssor classes for
436 my $meta = $class->meta_info;
438 foreach my $rel (keys %$meta) {
439 my $rel_meta = $meta->{$rel};
440 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
445 # 2 liner to get class of accessor for $name
446 #my $meta = $class->meta_info;
447 #my ($isa) = map $_->foreign_class, grep defined,
448 # map $meta->{$_}->{$name}, keys %$meta;
453 =head2 stringify_column
457 sub stringify_column {
460 $class->columns("Stringify"),
461 ( grep { /^(name|title)$/i } $class->columns ),
462 ( grep { /(name|title)/i } $class->columns ),
463 ( grep { !/id$/i } $class->primary_columns ),
472 my ( $self, $r ) = @_;
473 if ( my $rows = $r->config->rows_per_page ) {
474 return $r->{template_args}{pager} =
475 $self->pager( $rows, $r->query->{page} );
477 else { return $self }
486 my ( $self, $r ) = @_;
487 my %ok_columns = map { $_ => 1 } $self->columns;
489 my $order = $q->{order};
490 return unless $order and $ok_columns{$order};
491 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
495 =head2 setup_database
500 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
501 $dsn ||= $config->dsn;
502 $u ||= $config->user;
503 $p ||= $config->pass;
504 $opts ||= $config->opts;
506 warn "No DSN set in config" unless $dsn;
507 $config->loader || $config->loader(
508 Class::DBI::Loader->new(
509 namespace => $namespace,
516 $config->{classes} = [ $config->{loader}->classes ];
517 $config->{tables} = [ $config->{loader}->tables ];
518 warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
519 if $namespace->debug;
523 my ( $self, $r, $table ) = @_;
524 return $r->config->loader->_table2class($table); # why not find_class ?
529 my @pcs = $class->primary_columns;
532 @pks{@pcs}=(@{$r->{args}});
533 return $class->retrieve( %pks );
535 return $class->retrieve( $r->{args}->[0] );
539 ###############################################################################
540 # private / internal functions and classes
544 $class = ref $class || $class;
546 return ${$class . '::COLUMN_INFO'};