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};
324 =head2 search_columns
326 $class->search_columns;
328 Returns a list of columns suitable for searching - used in factory templates, over-ridden in
329 classes. Provides same list as display_columns unless over-ridden.
335 return $class->display_columns;
341 $class->related_meta($col);
343 Returns the hash ref of relationship meta info for a given column.
348 my ($self,$r, $accssr) = @_;
349 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
350 my $class_meta = $self->meta_info;
351 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
353 { return $class_meta->{$rel_type}->{$accssr} };
358 =head2 stringify_column
360 Returns the name of the column to use when stringifying
365 sub stringify_column {
368 $class->columns("Stringify"),
369 ( grep { /^(name|title)$/i } $class->columns ),
370 ( grep { /(name|title)/i } $class->columns ),
371 ( grep { !/id$/i } $class->primary_columns ),
377 Sets the pager template argument ($r->{template_args}{pager})
378 to a Class::DBI::Pager object based on the rows_per_page
379 value set in the configuration of the application.
381 This pager is used via the pager macro in TT Templates, and
382 is also accessible via Mason.
387 my ( $self, $r ) = @_;
388 if ( my $rows = $r->config->rows_per_page ) {
389 return $r->{template_args}{pager} =
390 $self->pager( $rows, $r->query->{page} );
392 else { return $self }
398 Returns the SQL order syntax based on the order parameter passed
399 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
401 $sql .= $self->order($r);
403 If the order column is not a column of this table,
404 or an order argument is not passed, then the return value is undefined.
406 Note: the returned value does not start with a space.
411 my ( $self, $r ) = @_;
412 my %ok_columns = map { $_ => 1 } $self->columns;
414 my $order = $q->{order};
415 return unless $order and $ok_columns{$order};
416 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
423 Returns 1 or more objects of the given class when provided with the request
429 my @pcs = $class->primary_columns;
432 @pks{@pcs}=(@{$r->{args}});
433 return $class->retrieve( %pks );
435 return $class->retrieve( $r->{args}->[0] );
441 Private method to return the class a column
442 belongs to that was inherited by an is_a relationship.
443 This should probably be public but need to think of API
448 my ($class, $col) = @_;
449 $class->_croak( "Need a column for _isa_class." ) unless $col;
451 my $isa = $class->meta_info("is_a") || {};
452 foreach ( keys %$isa ) {
453 $isaclass = $isa->{$_}->foreign_class;
454 return $isaclass if ($isaclass->find_column($col));
456 return; # col not in a is_a class
460 # Thanks to dave baird -- form builder for these private functions
464 my $dbh = $self->db_Main;
466 my $meta; # The info we are after
467 my ($catalog, $schema) = (undef, undef);
468 # Dave is suspicious this (above undefs) could
469 # break things if driver useses this info
471 my $original_metadata;
472 # '%' is a search pattern for columns - matches all columns
473 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
474 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
475 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
477 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
480 return $self->COLUMN_INFO;
483 sub _hash_type_meta {
484 my ($self, $sth) = @_;
486 while ( my $row = $sth->fetchrow_hashref ) {
487 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
489 # required / nullable
490 $meta->{$colname}{nullable} = $row->{NULLABLE};
491 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
494 if (defined $row->{COLUMN_DEF}) {
495 my $default = $row->{COLUMN_DEF};
496 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
497 $meta->{$colname}{default} = $default;
499 $meta->{$colname}{default} = '';
503 my $type = $row->{mysql_type_name} || $row->{type};
505 $type = $row->{TYPE_NAME};
506 if ($row->{COLUMN_SIZE}) {
507 $type .= "($row->{COLUMN_SIZE})";
510 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
512 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
515 $meta->{$colname}{type} = $type;
518 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
523 # typeless db e.g. sqlite
524 sub _hash_typeless_meta {
527 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
528 unless $self->can( 'sql_fb_meta_dummy' );
530 my $sth = $self->sql_fb_meta_dummy;
532 $sth->execute or die "Error executing column info: " . $sth->errstr;;
534 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
535 my $cols = $sth->{NAME};
536 my $types = $sth->{TYPE};
537 # my $sizes = $sth->{PRECISION}; # empty
538 # my $nulls = $sth->{NULLABLE}; # empty
540 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
545 foreach my $col ( @$cols ) {
547 $col_meta->{nullable} = 1;
548 $col_meta->{required} = 0;
549 $col_meta->{default} = '';
550 $col_meta->{position} = $order++;
551 # type_name is taken literally from the schema, but is not actually used by sqlite,
552 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
553 my $type = shift( @$types );
554 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
555 $meta->{$col} = $col_meta;
562 my $type = $class->column_type('column_name');
564 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
565 For now, it returns "BOOL" for tinyints.
567 TODO :: TEST with enums
573 my $colname = shift or die "Need a column for column_type";
574 $class->_column_info() unless (ref $class->COLUMN_INFO);
576 if ($class->_isa_class($colname)) {
577 return $class->_isa_class($colname)->column_type($colname);
579 unless ( $class->find_column($colname) ) {
580 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
583 return $class->COLUMN_INFO->{$colname}{type};
586 =head2 required_columns
588 Accessor to get/set required columns for forms, validation, etc.
590 Returns list of required columns. Accepts an array ref of column names.
592 $class->required_columns([qw/foo bar baz/]);
594 Allows you to specify the required columns for a class, over-riding any
595 assumptions and guesses made by Maypole.
597 Any columns specified as required will no longer be 'nullable' or optional, and
598 any columns not specified as 'required' will be 'nullable' or optional.
600 The default for a column is nullable, or whatever is discovered from database
603 Use this instead of $config->{$table}{required_cols}
605 Note : you need to setup the model class before calling this method.
609 sub required_columns {
610 my ($class, $columns) = @_;
611 $class->_column_info() unless (ref $class->COLUMN_INFO);
612 my $column_info = $class->COLUMN_INFO;
615 # get the previously required columns
616 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
618 # update each specified column as required
619 foreach my $colname ( @$columns ) {
620 # handle C::DBI::Rel::IsA
621 if ($class->_isa_class($colname)) {
622 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
623 unless ($class->_isa_class($colname)->column_required);
626 unless ( $class->find_column($colname) ) {
627 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
630 $column_info->{$colname}{required} = 1;
631 delete $previously_required{$colname};
634 # no longer require any columns not specified
635 foreach my $colname ( keys %previously_required ) {
636 $column_info->{$colname}{required} = 0;
637 $column_info->{$colname}{nullable} = 1;
640 # update column metadata
641 $class->COLUMN_INFO($column_info);
644 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
647 =head2 column_required
649 Returns true if a column is required
651 my $required = $class->column_required($column_name);
653 Columns can be required by the application but not the database, but not the other way around,
654 hence there is also a column_nullable method which will tell you if the column is nullable
655 within the database itself.
659 sub column_required {
660 my ($class, $colname) = @_;
661 $colname or $class->_croak( "Need a column for column_required" );
662 $class->_column_info() unless ref $class->COLUMN_INFO;
663 if ($class->_isa_class($colname)) {
664 return $class->_isa_class($colname)->column_required($colname);
666 unless ( $class->find_column($colname) ) {
667 # handle non-existant columns
668 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
671 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
675 =head2 column_nullable
677 Returns true if a column can be NULL within the underlying database and false if not.
679 my $nullable = $class->column_nullable($column_name);
681 Any columns that are not nullable will automatically be specified as required, you can
682 also specify nullable columns as required within your application.
684 It is recomended you use column_required rather than column_nullable within your
685 application, this method is more useful if extending the model or handling your own
690 sub column_nullable {
692 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
694 $class->_column_info() unless ref $class->COLUMN_INFO;
695 if ($class->_isa_class($colname)) {
696 return $class->_isa_class($colname)->column_nullable($colname);
698 unless ( $class->find_column($colname) ) {
699 # handle non-existant columns
700 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
703 return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
707 =head2 column_default
709 Returns default value for column or the empty string.
710 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
717 my $colname = shift or $class->_croak( "Need a column for column_default");
718 $class->_column_info() unless (ref $class->COLUMN_INFO);
719 if ($class->_isa_class($colname)) {
720 return $class->_isa_class($colname)->column_default($colname);
722 unless ( $class->find_column($colname) ) {
723 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
727 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
731 =head2 get_classmetadata
733 Gets class meta data *excluding cgi input* for the passed in class or the
734 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
735 templates when you need some metadata for a related class.
739 sub get_classmetadata {
740 my ($self, $class) = @_; # class is class we want data for
742 $class = ref $class || $class;
746 $res{colnames} = {$class->column_names};
747 $res{columns} = [$class->display_columns];
748 $res{list_columns} = [$class->list_columns];
749 $res{moniker} = $class->moniker;
750 $res{plural} = $class->plural_moniker;
751 $res{table} = $class->table;
752 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
759 L<Maypole>, L<Maypole::Model::CDBI::Base>.
763 Maypole is currently maintained by Aaron Trevena.
765 =head1 AUTHOR EMERITUS
767 Simon Cozens, C<simon#cpan.org>
769 Simon Flack maintained Maypole from 2.05 to 2.09
771 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
775 You may distribute this code under the same terms as Perl itself.