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( $h => {
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( $h => {
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);
235 # FIXME: use pager info to get slice of iterator instead of all the objects as array
240 \%values, ( $order ? { order_by => $order } : () )
244 $r->{template_args}{search} = 1;
249 The C<list> method fills C<$r-E<gt>objects> with all of the
250 objects in the class. The results are paged using a pager.
254 sub list : Exported {
255 my ( $self, $r ) = @_;
256 my $order = $self->order($r);
257 $self = $self->do_pager($r);
259 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
262 $r->objects( [ $self->retrieve_all ] );
266 ###############################################################################
269 =head1 Helper Methods
274 This class method is passed the name of a model class that represents a table
275 and allows the master model class to do any set-up required.
280 my ( $self, $child ) = @_;
281 $child->autoupdate(1);
282 if ( my $col = $child->stringify_column ) {
283 $child->columns( Stringify => $col );
290 This method returns a list of has-many accessors. A brewery has many
291 beers, so C<BeerDB::Brewery> needs to return C<beers>.
296 my ( $self, $r ) = @_;
297 return keys %{ $self->meta_info('has_many') || {} };
303 Given an accessor name as a method, this function returns the class this accessor returns.
308 my ( $self, $r, $accessor ) = @_;
309 my $meta = $self->meta_info;
310 my @rels = keys %$meta;
313 $related = $meta->{$_}{$accessor};
316 return unless $related;
318 my $mapping = $related->{args}->{mapping};
319 if ( $mapping and @$mapping ) {
320 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
323 return $related->{foreign_class};
327 =head2 search_columns
329 $class->search_columns;
331 Returns a list of columns suitable for searching - used in factory templates, over-ridden in
332 classes. Provides same list as display_columns unless over-ridden.
338 return $class->display_columns;
344 $class->related_meta($col);
346 Returns the hash ref of relationship meta info for a given column.
351 my ($self,$r, $accssr) = @_;
352 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
353 my $class_meta = $self->meta_info;
354 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
356 { return $class_meta->{$rel_type}->{$accssr} };
361 =head2 stringify_column
363 Returns the name of the column to use when stringifying
368 sub stringify_column {
371 $class->columns("Stringify"),
372 ( grep { /^(name|title)$/i } $class->columns ),
373 ( grep { /(name|title)/i } $class->columns ),
374 ( grep { !/id$/i } $class->primary_columns ),
380 Sets the pager template argument ($r->{template_args}{pager})
381 to a Class::DBI::Pager object based on the rows_per_page
382 value set in the configuration of the application.
384 This pager is used via the pager macro in TT Templates, and
385 is also accessible via Mason.
390 my ( $self, $r ) = @_;
391 if ( my $rows = $r->config->rows_per_page ) {
392 return $r->{template_args}{pager} =
393 $self->pager( $rows, $r->query->{page} );
395 else { return $self }
401 Returns the SQL order syntax based on the order parameter passed
402 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
404 $sql .= $self->order($r);
406 If the order column is not a column of this table,
407 or an order argument is not passed, then the return value is undefined.
409 Note: the returned value does not start with a space.
414 my ( $self, $r ) = @_;
415 my %ok_columns = map { $_ => 1 } $self->columns;
417 my $order = $q->{order};
418 return unless $order and $ok_columns{$order};
419 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
426 Returns 1 or more objects of the given class when provided with the request
432 my @pcs = $class->primary_columns;
435 @pks{@pcs}=(@{$r->{args}});
436 return $class->retrieve( %pks );
438 return $class->retrieve( $r->{args}->[0] );
444 Private method to return the class a column
445 belongs to that was inherited by an is_a relationship.
446 This should probably be public but need to think of API
451 my ($class, $col) = @_;
452 $class->_croak( "Need a column for _isa_class." ) unless $col;
454 my $isa = $class->meta_info("is_a") || {};
455 foreach ( keys %$isa ) {
456 $isaclass = $isa->{$_}->foreign_class;
457 return $isaclass if ($isaclass->find_column($col));
459 return; # col not in a is_a class
463 # Thanks to dave baird -- form builder for these private functions
467 my $dbh = $self->db_Main;
469 my $meta; # The info we are after
470 my ($catalog, $schema) = (undef, undef);
471 # Dave is suspicious this (above undefs) could
472 # break things if driver useses this info
474 my $original_metadata;
475 # '%' is a search pattern for columns - matches all columns
476 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
477 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
478 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
480 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
483 return $self->COLUMN_INFO;
486 sub _hash_type_meta {
487 my ($self, $sth) = @_;
489 while ( my $row = $sth->fetchrow_hashref ) {
490 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
492 # required / nullable
493 $meta->{$colname}{nullable} = $row->{NULLABLE};
494 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
497 if (defined $row->{COLUMN_DEF}) {
498 my $default = $row->{COLUMN_DEF};
499 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
500 $meta->{$colname}{default} = $default;
502 $meta->{$colname}{default} = '';
506 my $type = $row->{mysql_type_name} || $row->{type};
508 $type = $row->{TYPE_NAME};
509 if ($row->{COLUMN_SIZE}) {
510 $type .= "($row->{COLUMN_SIZE})";
513 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
515 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
518 $meta->{$colname}{type} = $type;
521 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
526 # typeless db e.g. sqlite
527 sub _hash_typeless_meta {
530 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
531 unless $self->can( 'sql_fb_meta_dummy' );
533 my $sth = $self->sql_fb_meta_dummy;
535 $sth->execute or die "Error executing column info: " . $sth->errstr;;
537 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
538 my $cols = $sth->{NAME};
539 my $types = $sth->{TYPE};
540 # my $sizes = $sth->{PRECISION}; # empty
541 # my $nulls = $sth->{NULLABLE}; # empty
543 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
548 foreach my $col ( @$cols ) {
550 $col_meta->{nullable} = 1;
551 $col_meta->{required} = 0;
552 $col_meta->{default} = '';
553 $col_meta->{position} = $order++;
554 # type_name is taken literally from the schema, but is not actually used by sqlite,
555 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
556 my $type = shift( @$types );
557 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
558 $meta->{$col} = $col_meta;
565 my $type = $class->column_type('column_name');
567 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
568 For now, it returns "BOOL" for tinyints.
570 TODO :: TEST with enums
576 my $colname = shift or die "Need a column for column_type";
577 $class->_column_info() unless (ref $class->COLUMN_INFO);
579 if ($class->_isa_class($colname)) {
580 return $class->_isa_class($colname)->column_type($colname);
582 unless ( $class->find_column($colname) ) {
583 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
586 return $class->COLUMN_INFO->{$colname}{type};
589 =head2 required_columns
591 Accessor to get/set required columns for forms, validation, etc.
593 Returns list of required columns. Accepts an array ref of column names.
595 $class->required_columns([qw/foo bar baz/]);
597 Allows you to specify the required columns for a class, over-riding any
598 assumptions and guesses made by Maypole.
600 Any columns specified as required will no longer be 'nullable' or optional, and
601 any columns not specified as 'required' will be 'nullable' or optional.
603 The default for a column is nullable, or whatever is discovered from database
606 Use this instead of $config->{$table}{required_cols}
608 Note : you need to setup the model class before calling this method.
612 sub required_columns {
613 my ($class, $columns) = @_;
614 $class->_column_info() unless (ref $class->COLUMN_INFO);
615 my $column_info = $class->COLUMN_INFO;
618 # get the previously required columns
619 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
621 # update each specified column as required
622 foreach my $colname ( @$columns ) {
623 # handle C::DBI::Rel::IsA
624 if ($class->_isa_class($colname)) {
625 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
626 unless ($class->_isa_class($colname)->column_required);
629 unless ( $class->find_column($colname) ) {
630 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
633 $column_info->{$colname}{required} = 1;
634 delete $previously_required{$colname};
637 # no longer require any columns not specified
638 foreach my $colname ( keys %previously_required ) {
639 $column_info->{$colname}{required} = 0;
640 $column_info->{$colname}{nullable} = 1;
643 # update column metadata
644 $class->COLUMN_INFO($column_info);
647 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
650 =head2 column_required
652 Returns true if a column is required
654 my $required = $class->column_required($column_name);
656 Columns can be required by the application but not the database, but not the other way around,
657 hence there is also a column_nullable method which will tell you if the column is nullable
658 within the database itself.
662 sub column_required {
663 my ($class, $colname) = @_;
664 $colname or $class->_croak( "Need a column for column_required" );
665 $class->_column_info() unless ref $class->COLUMN_INFO;
666 if ($class->_isa_class($colname)) {
667 return $class->_isa_class($colname)->column_required($colname);
669 unless ( $class->find_column($colname) ) {
670 # handle non-existant columns
671 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
674 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
678 =head2 column_nullable
680 Returns true if a column can be NULL within the underlying database and false if not.
682 my $nullable = $class->column_nullable($column_name);
684 Any columns that are not nullable will automatically be specified as required, you can
685 also specify nullable columns as required within your application.
687 It is recomended you use column_required rather than column_nullable within your
688 application, this method is more useful if extending the model or handling your own
693 sub column_nullable {
695 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
697 $class->_column_info() unless ref $class->COLUMN_INFO;
698 if ($class->_isa_class($colname)) {
699 return $class->_isa_class($colname)->column_nullable($colname);
701 unless ( $class->find_column($colname) ) {
702 # handle non-existant columns
703 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
706 return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
710 =head2 column_default
712 Returns default value for column or the empty string.
713 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
720 my $colname = shift or $class->_croak( "Need a column for column_default");
721 $class->_column_info() unless (ref $class->COLUMN_INFO);
722 if ($class->_isa_class($colname)) {
723 return $class->_isa_class($colname)->column_default($colname);
725 unless ( $class->find_column($colname) ) {
726 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
730 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
734 =head2 get_classmetadata
736 Gets class meta data *excluding cgi input* for the passed in class or the
737 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
738 templates when you need some metadata for a related class.
742 sub get_classmetadata {
743 my ($self, $class) = @_; # class is class we want data for
745 $class = ref $class || $class;
749 $res{colnames} = {$class->column_names};
750 $res{columns} = [$class->display_columns];
751 $res{list_columns} = [$class->list_columns];
752 $res{moniker} = $class->moniker;
753 $res{plural} = $class->plural_moniker;
754 $res{table} = $class->table;
755 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
762 L<Maypole>, L<Maypole::Model::Base>.
766 Maypole is currently maintained by Aaron Trevena.
768 =head1 AUTHOR EMERITUS
770 Simon Cozens, C<simon#cpan.org>
772 Simon Flack maintained Maypole from 2.05 to 2.09
774 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
778 You may distribute this code under the same terms as Perl itself.