1 package Maypole::Model::CDBI::Base;
7 Maypole::Model::CDBI::Base - Model base class based on Class::DBI
11 This is a master model class which uses L<Class::DBI> to do all the hard
12 work of fetching rows and representing them as objects. It is a good
13 model to copy if you're replacing it with other database abstraction
16 It implements a base set of methods required for a Maypole Data Model.
18 It inherits accessor and helper methods from L<Maypole::Model::Base>.
22 use base qw(Maypole::Model::Base Class::DBI);
23 use Class::DBI::AbstractSearch;
24 use Class::DBI::Plugin::RetrieveAll;
25 use Class::DBI::Pager;
26 use Lingua::EN::Inflect::Number qw(to_PL);
30 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
32 =head2 add_model_superclass
34 Adds model as superclass to model classes (if necessary)
38 sub add_model_superclass {
39 my ($class,$config) = @_;
40 foreach my $subclass ( @{ $config->classes } ) {
41 next if $subclass->isa("Maypole::Model::Base");
43 push @{ $subclass . "::ISA" }, $config->model;
50 Action methods are methods that are accessed through web (or other public) interface.
54 If there is an object in C<$r-E<gt>objects>, then it should be edited
55 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
56 be created with those parameters, and put back into C<$r-E<gt>objects>.
57 The template should be changed to C<view>, or C<edit> if there were any
58 errors. A hash of errors will be passed to the template.
62 sub do_edit : Exported {
63 my ($self, $r, $obj) = @_;
65 my $config = $r->config;
66 my $table = $r->table;
68 # handle cancel button hit
69 if ( $r->{params}->{cancel} ) {
71 $r->objects( [$self->retrieve_all] );
75 my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
76 my $ignored_cols = $config->{$table}{ignore_cols} || [];
78 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
80 # handle errors, if none, proceed to view the newly created/updated object
81 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
84 # Set it up as it was:
85 $r->template_args->{cgi_params} = $r->params;
87 # replace user unfriendly error messages with something nicer
89 foreach (@{$config->{$table}->{required_cols}}) {
90 next unless ($errors{$_});
93 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
94 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
98 foreach (keys %errors) {
101 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
102 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
105 undef $obj if $creating;
107 die "do_update failed with error : $fatal" if ($fatal);
108 $r->template("edit");
110 $r->template("view");
113 $r->objects( $obj ? [$obj] : []);
116 # split out from do_edit to be reported by Mp::P::Trace
117 sub _do_update_or_create {
118 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
123 my $h = $self->Untainter->new( %{$r->params} );
127 # We have something to edit
128 eval { $obj->update_from_cgi( $r => {
129 required => $required_cols,
130 ignore => $ignored_cols,
132 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
137 $obj = $self->create_from_cgi( $r => {
138 required => $required_cols,
139 ignore => $ignored_cols,
145 return $obj, $fatal, $creating;
150 This command shows the object using the view factory template.
154 sub view : Exported {
156 $r->build_form_elements(0);
163 Deprecated method that calls do_delete or a given classes delete method, please
164 use do_delete instead
168 Unsuprisingly, this command causes a database record to be forever lost.
170 This method replaces the, now deprecated, delete method provided in prior versions
174 sub delete : Exported {
176 my ($sub) = (caller(1))[3];
177 # So subclasses can still send delete down ...
178 $sub =~ /^(.+)::([^:]+)$/;
179 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
180 $self->SUPER::delete(@_);
182 warn "Maypole::Model::CDBI::Base delete method is deprecated\n";
183 $self->do_delete(@_);
189 my ( $self, $r ) = @_;
190 # FIXME: handle fatal error with exception
191 $_->SUPER::delete for @{ $r->objects || [] };
193 $r->objects( [ $self->retrieve_all ] );
194 $r->{template} = "list";
200 Deprecated searching method - use do_search instead.
204 This action method searches for database records, it replaces
205 the, now deprecated, search method previously provided.
209 sub search : Exported {
211 my ($sub) = (caller(1))[3];
212 # So subclasses can still send search down ...
213 if ($sub =~ /^(.+)::([^:]+)$/) {
214 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
215 $self->SUPER::search(@_) : $self->do_search(@_);
217 $self->SUPER::search(@_);
221 sub do_search : Exported {
222 my ( $self, $r ) = @_;
223 my %fields = map { $_ => 1 } $self->columns;
224 my $oper = "like"; # For now
225 my %params = %{ $r->{params} };
226 my %values = map { $_ => { $oper, $params{$_} } }
227 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
230 $r->template("list");
231 if ( !%values ) { return $self->list($r) }
232 my $order = $self->order($r);
233 $self = $self->do_pager($r);
237 \%values, ( $order ? { order_by => $order } : () )
241 $r->{template_args}{search} = 1;
246 The C<list> method fills C<$r-E<gt>objects> with all of the
247 objects in the class. The results are paged using a pager.
251 sub list : Exported {
252 my ( $self, $r ) = @_;
253 my $order = $self->order($r);
254 $self = $self->do_pager($r);
256 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
259 $r->objects( [ $self->retrieve_all ] );
263 ###############################################################################
266 =head1 Helper Methods
271 This class method is passed the name of a model class that represents a table
272 and allows the master model class to do any set-up required.
277 my ( $self, $child ) = @_;
278 $child->autoupdate(1);
279 if ( my $col = $child->stringify_column ) {
280 $child->columns( Stringify => $col );
287 This method returns a list of has-many accessors. A brewery has many
288 beers, so C<BeerDB::Brewery> needs to return C<beers>.
293 my ( $self, $r ) = @_;
294 return keys %{ $self->meta_info('has_many') || {} };
300 Given an accessor name as a method, this function returns the class this accessor returns.
305 my ( $self, $r, $accessor ) = @_;
306 my $meta = $self->meta_info;
307 my @rels = keys %$meta;
310 $related = $meta->{$_}{$accessor};
313 return unless $related;
315 my $mapping = $related->{args}->{mapping};
316 if ( $mapping and @$mapping ) {
317 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
320 return $related->{foreign_class};
326 $class->related_meta($col);
328 Returns the hash ref of relationship meta info for a given column.
333 my ($self,$r, $accssr) = @_;
334 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
335 my $class_meta = $self->meta_info;
336 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
338 { return $class_meta->{$rel_type}->{$accssr} };
343 =head2 stringify_column
345 Returns the name of the column to use when stringifying
350 sub stringify_column {
353 $class->columns("Stringify"),
354 ( grep { /^(name|title)$/i } $class->columns ),
355 ( grep { /(name|title)/i } $class->columns ),
356 ( grep { !/id$/i } $class->primary_columns ),
362 Sets the pager template argument ($r->{template_args}{pager})
363 to a Class::DBI::Pager object based on the rows_per_page
364 value set in the configuration of the application.
366 This pager is used via the pager macro in TT Templates, and
367 is also accessible via Mason.
372 my ( $self, $r ) = @_;
373 if ( my $rows = $r->config->rows_per_page ) {
374 return $r->{template_args}{pager} =
375 $self->pager( $rows, $r->query->{page} );
377 else { return $self }
383 Returns the SQL order syntax based on the order parameter passed
384 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
386 $sql .= $self->order($r);
388 If the order column is not a column of this table,
389 or an order argument is not passed, then the return value is undefined.
391 Note: the returned value does not start with a space.
396 my ( $self, $r ) = @_;
397 my %ok_columns = map { $_ => 1 } $self->columns;
399 my $order = $q->{order};
400 return unless $order and $ok_columns{$order};
401 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
408 Returns 1 or more objects of the given class when provided with the request
414 my @pcs = $class->primary_columns;
417 @pks{@pcs}=(@{$r->{args}});
418 return $class->retrieve( %pks );
420 return $class->retrieve( $r->{args}->[0] );
426 Private method to return the class a column
427 belongs to that was inherited by an is_a relationship.
428 This should probably be public but need to think of API
433 my ($class, $col) = @_;
434 $class->_croak( "Need a column for _isa_class." ) unless $col;
436 my $isa = $class->meta_info("is_a") || {};
437 foreach ( keys %$isa ) {
438 $isaclass = $isa->{$_}->foreign_class;
439 return $isaclass if ($isaclass->find_column($col));
441 return; # col not in a is_a class
445 # Thanks to dave baird -- form builder for these private functions
449 my $dbh = $self->db_Main;
451 my $meta; # The info we are after
452 my ($catalog, $schema) = (undef, undef);
453 # Dave is suspicious this (above undefs) could
454 # break things if driver useses this info
456 my $original_metadata;
457 # '%' is a search pattern for columns - matches all columns
458 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
459 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
460 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
462 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
465 return $self->COLUMN_INFO;
468 sub _hash_type_meta {
469 my ($self, $sth) = @_;
471 while ( my $row = $sth->fetchrow_hashref ) {
472 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
474 # required / nullable
475 $meta->{$colname}{nullable} = $row->{NULLABLE};
476 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
479 if (defined $row->{COLUMN_DEF}) {
480 my $default = $row->{COLUMN_DEF};
481 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
482 $meta->{$colname}{default} = $default;
484 $meta->{$colname}{default} = '';
488 my $type = $row->{mysql_type_name} || $row->{type};
490 $type = $row->{TYPE_NAME};
491 if ($row->{COLUMN_SIZE}) {
492 $type .= "($row->{COLUMN_SIZE})";
495 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
497 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
500 $meta->{$colname}{type} = $type;
503 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
508 # typeless db e.g. sqlite
509 sub _hash_typeless_meta {
512 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
513 unless $self->can( 'sql_fb_meta_dummy' );
515 my $sth = $self->sql_fb_meta_dummy;
517 $sth->execute or die "Error executing column info: " . $sth->errstr;;
519 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
520 my $cols = $sth->{NAME};
521 my $types = $sth->{TYPE};
522 # my $sizes = $sth->{PRECISION}; # empty
523 # my $nulls = $sth->{NULLABLE}; # empty
525 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
530 foreach my $col ( @$cols ) {
532 $col_meta->{nullable} = 1;
533 $col_meta->{required} = 0;
534 $col_meta->{default} = '';
535 $col_meta->{position} = $order++;
536 # type_name is taken literally from the schema, but is not actually used by sqlite,
537 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
538 my $type = shift( @$types );
539 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
540 $meta->{$col} = $col_meta;
547 my $type = $class->column_type('column_name');
549 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
550 For now, it returns "BOOL" for tinyints.
552 TODO :: TEST with enums
558 my $colname = shift or die "Need a column for column_type";
559 $class->_column_info() unless (ref $class->COLUMN_INFO);
561 if ($class->_isa_class($colname)) {
562 return $class->_isa_class($colname)->column_type($colname);
564 unless ( $class->find_column($colname) ) {
565 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
568 return $class->COLUMN_INFO->{$colname}{type};
571 =head2 required_columns
573 Accessor to get/set required columns for forms, validation, etc.
575 Returns list of required columns. Accepts an array ref of column names.
577 $class->required_columns([qw/foo bar baz/]);
579 Allows you to specify the required columns for a class, over-riding any
580 assumptions and guesses made by Maypole.
582 Any columns specified as required will no longer be 'nullable' or optional, and
583 any columns not specified as 'required' will be 'nullable' or optional.
585 The default for a column is nullable, or whatever is discovered from database
588 Use this instead of $config->{$table}{required_cols}
590 Note : you need to setup the model class before calling this method.
594 sub required_columns {
595 my ($class, $columns) = @_;
596 $class->_column_info() unless (ref $class->COLUMN_INFO);
597 my $column_info = $class->COLUMN_INFO;
600 # get the previously required columns
601 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
603 # update each specified column as required
604 foreach my $colname ( @$columns ) {
605 # handle C::DBI::Rel::IsA
606 if ($class->_isa_class($colname)) {
607 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
608 unless ($class->_isa_class($colname)->column_required);
611 unless ( $class->find_column($colname) ) {
612 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
615 $column_info->{$colname}{required} = 1;
616 delete $previously_required{$colname};
619 # no longer require any columns not specified
620 foreach my $colname ( keys %previously_required ) {
621 $column_info->{$colname}{required} = 0;
622 $column_info->{$colname}{nullable} = 1;
625 # update column metadata
626 $class->COLUMN_INFO($column_info);
629 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
632 =head2 column_required
634 Returns true if a column is required
636 my $required = $class->column_required($column_name);
638 Columns can be required by the application but not the database, but not the other way around,
639 hence there is also a column_nullable method which will tell you if the column is nullable
640 within the database itself.
644 sub column_required {
645 my ($class, $colname) = @_;
646 $colname or $class->_croak( "Need a column for column_required" );
647 $class->_column_info() unless ref $class->COLUMN_INFO;
648 if ($class->_isa_class($colname)) {
649 return $class->_isa_class($colname)->column_required($colname);
651 unless ( $class->find_column($colname) ) {
652 # handle non-existant columns
653 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
656 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
660 =head2 column_nullable
662 Returns true if a column can be NULL within the underlying database and false if not.
664 my $nullable = $class->column_nullable($column_name);
666 Any columns that are not nullable will automatically be specified as required, you can
667 also specify nullable columns as required within your application.
669 It is recomended you use column_required rather than column_nullable within your
670 application, this method is more useful if extending the model or handling your own
675 sub column_nullable {
677 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
679 $class->_column_info() unless ref $class->COLUMN_INFO;
680 if ($class->_isa_class($colname)) {
681 return $class->_isa_class($colname)->column_nullable($colname);
683 unless ( $class->find_column($colname) ) {
684 # handle non-existant columns
685 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
688 return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
692 =head2 column_default
694 Returns default value for column or the empty string.
695 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
702 my $colname = shift or $class->_croak( "Need a column for column_default");
703 $class->_column_info() unless (ref $class->COLUMN_INFO);
704 if ($class->_isa_class($colname)) {
705 return $class->_isa_class($colname)->column_default($colname);
707 unless ( $class->find_column($colname) ) {
708 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
712 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
716 =head2 get_classmetadata
718 Gets class meta data *excluding cgi input* for the passed in class or the
719 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
720 templates when you need some metadata for a related class.
724 sub get_classmetadata {
725 my ($self, $class) = @_; # class is class we want data for
727 $class = ref $class || $class;
731 $res{colnames} = {$class->column_names};
732 $res{columns} = [$class->display_columns];
733 $res{list_columns} = [$class->list_columns];
734 $res{moniker} = $class->moniker;
735 $res{plural} = $class->plural_moniker;
736 $res{table} = $class->table;
737 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
744 L<Maypole>, L<Maypole::Model::CDBI::Base>.
748 Maypole is currently maintained by Aaron Trevena.
750 =head1 AUTHOR EMERITUS
752 Simon Cozens, C<simon#cpan.org>
754 Simon Flack maintained Maypole from 2.05 to 2.09
756 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
760 You may distribute this code under the same terms as Perl itself.