1 package Maypole::Model::CDBI::Base;
6 Maypole::Model::CDBI::Base - Model base 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 Class::DBI::AbstractSearch;
23 use Class::DBI::Plugin::RetrieveAll;
24 use Class::DBI::Pager;
25 use Lingua::EN::Inflect::Number qw(to_PL);
29 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
31 =head2 add_model_superclass
33 Adds model as superclass to model classes (if necessary)
37 sub add_model_superclass {
38 my ($class,$config) = @_;
39 foreach my $subclass ( @{ $config->classes } ) {
40 next if $subclass->isa("Maypole::Model::Base");
42 push @{ $subclass . "::ISA" }, $config->model;
49 Action methods are methods that are accessed through web (or other public) interface.
53 If there is an object in C<$r-E<gt>objects>, then it should be edited
54 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
55 be created with those parameters, and put back into C<$r-E<gt>objects>.
56 The template should be changed to C<view>, or C<edit> if there were any
57 errors. A hash of errors will be passed to the template.
61 sub do_edit : Exported {
62 my ($self, $r, $obj) = @_;
64 my $config = $r->config;
65 my $table = $r->table;
67 # handle cancel button hit
68 if ( $r->{params}->{cancel} ) {
70 $r->objects( [$self->retrieve_all] );
74 my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
75 my $ignored_cols = $config->{$table}{ignore_cols} || [];
77 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
79 # handle errors, if none, proceed to view the newly created/updated object
80 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
83 # Set it up as it was:
84 $r->template_args->{cgi_params} = $r->params;
86 # replace user unfriendly error messages with something nicer
88 foreach (@{$config->{$table}->{required_cols}}) {
89 next unless ($errors{$_});
92 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
93 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
97 foreach (keys %errors) {
100 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
101 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
104 undef $obj if $creating;
106 die "do_update failed with error : $fatal" if ($fatal);
107 $r->template("edit");
109 $r->template("view");
112 $r->objects( $obj ? [$obj] : []);
115 # split out from do_edit to be reported by Mp::P::Trace
116 sub _do_update_or_create {
117 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
122 my $h = $self->Untainter->new( %{$r->params} );
126 # We have something to edit
127 eval { $obj->update_from_cgi( $h => {
128 required => $required_cols,
129 ignore => $ignored_cols,
131 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
136 $obj = $self->create_from_cgi( $h => {
137 required => $required_cols,
138 ignore => $ignored_cols,
144 return $obj, $fatal, $creating;
149 This command shows the object using the view factory template.
153 sub view : Exported {
155 $r->build_form_elements(0);
162 Deprecated method that calls do_delete or a given classes delete method, please
163 use do_delete instead
167 Unsuprisingly, this command causes a database record to be forever lost.
169 This method replaces the, now deprecated, delete method provided in prior versions
173 sub delete : Exported {
175 my ($sub) = (caller(1))[3];
176 # So subclasses can still send delete down ...
177 $sub =~ /^(.+)::([^:]+)$/;
178 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
179 $self->SUPER::delete(@_);
181 warn "Maypole::Model::CDBI::Base delete method is deprecated\n";
182 $self->do_delete(@_);
188 my ( $self, $r ) = @_;
189 # FIXME: handle fatal error with exception
190 $_->SUPER::delete for @{ $r->objects || [] };
192 $r->objects( [ $self->retrieve_all ] );
193 $r->{template} = "list";
199 Deprecated searching method - use do_search instead.
203 This action method searches for database records, it replaces
204 the, now deprecated, search method previously provided.
208 sub search : Exported {
210 my ($sub) = (caller(1))[3];
211 # So subclasses can still send search down ...
212 if ($sub =~ /^(.+)::([^:]+)$/) {
213 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
214 $self->SUPER::search(@_) : $self->do_search(@_);
216 $self->SUPER::search(@_);
220 sub do_search : Exported {
221 my ( $self, $r ) = @_;
222 my %fields = map { $_ => 1 } $self->columns;
223 my $oper = "like"; # For now
224 my %params = %{ $r->{params} };
225 my %values = map { $_ => { $oper, $params{$_} } }
226 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
229 $r->template("list");
230 if ( !%values ) { return $self->list($r) }
231 my $order = $self->order($r);
232 $self = $self->do_pager($r);
234 # FIXME: use pager info to get slice of iterator instead of all the objects as array
239 \%values, ( $order ? { order_by => $order } : () )
243 $r->{template_args}{search} = 1;
248 The C<list> method fills C<$r-E<gt>objects> with all of the
249 objects in the class. The results are paged using a pager.
253 sub list : Exported {
254 my ( $self, $r ) = @_;
255 my $order = $self->order($r);
256 $self = $self->do_pager($r);
258 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
261 $r->objects( [ $self->retrieve_all ] );
265 ###############################################################################
268 =head1 Helper Methods
273 This class method is passed the name of a model class that represents a table
274 and allows the master model class to do any set-up required.
279 my ( $self, $child ) = @_;
280 $child->autoupdate(1);
281 if ( my $col = $child->stringify_column ) {
282 $child->columns( Stringify => $col );
289 This method returns a list of has-many accessors. A brewery has many
290 beers, so C<BeerDB::Brewery> needs to return C<beers>.
295 my ( $self, $r ) = @_;
296 return keys %{ $self->meta_info('has_many') || {} };
302 Given an accessor name as a method, this function returns the class this accessor returns.
307 my ( $self, $r, $accessor ) = @_;
308 my $meta = $self->meta_info;
309 my @rels = keys %$meta;
312 $related = $meta->{$_}{$accessor};
315 return unless $related;
317 my $mapping = $related->{args}->{mapping};
318 if ( $mapping and @$mapping ) {
319 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
322 return $related->{foreign_class};
326 =head2 search_columns
328 $class->search_columns;
330 Returns a list of columns suitable for searching - used in factory templates, over-ridden in
331 classes. Provides same list as display_columns unless over-ridden.
337 return $class->display_columns;
343 $class->related_meta($col);
345 Returns the hash ref of relationship meta info for a given column.
350 my ($self,$r, $accssr) = @_;
351 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
352 my $class_meta = $self->meta_info;
353 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
355 { return $class_meta->{$rel_type}->{$accssr} };
360 =head2 stringify_column
362 Returns the name of the column to use when stringifying
367 sub stringify_column {
370 $class->columns("Stringify"),
371 ( grep { /^(name|title)$/i } $class->columns ),
372 ( grep { /(name|title)/i } $class->columns ),
373 ( grep { !/id$/i } $class->primary_columns ),
379 Sets the pager template argument ($r->{template_args}{pager})
380 to a Class::DBI::Pager object based on the rows_per_page
381 value set in the configuration of the application.
383 This pager is used via the pager macro in TT Templates, and
384 is also accessible via Mason.
389 my ( $self, $r ) = @_;
390 if ( my $rows = $r->config->rows_per_page ) {
391 return $r->{template_args}{pager} =
392 $self->pager( $rows, $r->query->{page} );
394 else { return $self }
400 Returns the SQL order syntax based on the order parameter passed
401 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
403 $sql .= $self->order($r);
405 If the order column is not a column of this table,
406 or an order argument is not passed, then the return value is undefined.
408 Note: the returned value does not start with a space.
413 my ( $self, $r ) = @_;
414 my %ok_columns = map { $_ => 1 } $self->columns;
416 my $order = $q->{order};
417 return unless $order and $ok_columns{$order};
418 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
425 Returns 1 or more objects of the given class when provided with the request
431 my @pcs = $class->primary_columns;
434 @pks{@pcs}=(@{$r->{args}});
435 return $class->retrieve( %pks );
437 return $class->retrieve( $r->{args}->[0] );
443 Private method to return the class a column
444 belongs to that was inherited by an is_a relationship.
445 This should probably be public but need to think of API
450 my ($class, $col) = @_;
451 $class->_croak( "Need a column for _isa_class." ) unless $col;
453 my $isa = $class->meta_info("is_a") || {};
454 foreach ( keys %$isa ) {
455 $isaclass = $isa->{$_}->foreign_class;
456 return $isaclass if ($isaclass->find_column($col));
458 return; # col not in a is_a class
462 # Thanks to dave baird -- form builder for these private functions
466 my $dbh = $self->db_Main;
468 my $meta; # The info we are after
469 my ($catalog, $schema) = (undef, undef);
470 # Dave is suspicious this (above undefs) could
471 # break things if driver useses this info
473 my $original_metadata;
474 # '%' is a search pattern for columns - matches all columns
475 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
476 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
477 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
479 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
482 return $self->COLUMN_INFO;
485 sub _hash_type_meta {
486 my ($self, $sth) = @_;
488 while ( my $row = $sth->fetchrow_hashref ) {
489 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
491 # required / nullable
492 $meta->{$colname}{nullable} = $row->{NULLABLE};
493 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
496 if (defined $row->{COLUMN_DEF}) {
497 my $default = $row->{COLUMN_DEF};
498 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
499 $meta->{$colname}{default} = $default;
501 $meta->{$colname}{default} = '';
505 my $type = $row->{mysql_type_name} || $row->{type};
507 $type = $row->{TYPE_NAME};
508 if ($row->{COLUMN_SIZE}) {
509 $type .= "($row->{COLUMN_SIZE})";
512 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
514 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
517 $meta->{$colname}{type} = $type;
520 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
525 # typeless db e.g. sqlite
526 sub _hash_typeless_meta {
529 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
530 unless $self->can( 'sql_fb_meta_dummy' );
532 my $sth = $self->sql_fb_meta_dummy;
534 $sth->execute or die "Error executing column info: " . $sth->errstr;;
536 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
537 my $cols = $sth->{NAME};
538 my $types = $sth->{TYPE};
539 # my $sizes = $sth->{PRECISION}; # empty
540 # my $nulls = $sth->{NULLABLE}; # empty
542 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
547 foreach my $col ( @$cols ) {
549 $col_meta->{nullable} = 1;
550 $col_meta->{required} = 0;
551 $col_meta->{default} = '';
552 $col_meta->{position} = $order++;
553 # type_name is taken literally from the schema, but is not actually used by sqlite,
554 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
555 my $type = shift( @$types );
556 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
557 $meta->{$col} = $col_meta;
564 my $type = $class->column_type('column_name');
566 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
567 For now, it returns "BOOL" for tinyints.
569 TODO :: TEST with enums
575 my $colname = shift or die "Need a column for column_type";
576 $class->_column_info() unless (ref $class->COLUMN_INFO);
578 if ($class->_isa_class($colname)) {
579 return $class->_isa_class($colname)->column_type($colname);
581 unless ( $class->find_column($colname) ) {
582 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
585 return $class->COLUMN_INFO->{$colname}{type};
588 =head2 required_columns
590 Accessor to get/set required columns for forms, validation, etc.
592 Returns list of required columns. Accepts an array ref of column names.
594 $class->required_columns([qw/foo bar baz/]);
596 Allows you to specify the required columns for a class, over-riding any
597 assumptions and guesses made by Maypole.
599 Any columns specified as required will no longer be 'nullable' or optional, and
600 any columns not specified as 'required' will be 'nullable' or optional.
602 The default for a column is nullable, or whatever is discovered from database
605 Use this instead of $config->{$table}{required_cols}
607 Note : you need to setup the model class before calling this method.
611 sub required_columns {
612 my ($class, $columns) = @_;
613 $class->_column_info() unless (ref $class->COLUMN_INFO);
614 my $column_info = $class->COLUMN_INFO;
617 # get the previously required columns
618 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
620 # update each specified column as required
621 foreach my $colname ( @$columns ) {
622 # handle C::DBI::Rel::IsA
623 if ($class->_isa_class($colname)) {
624 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
625 unless ($class->_isa_class($colname)->column_required);
628 unless ( $class->find_column($colname) ) {
629 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
632 $column_info->{$colname}{required} = 1;
633 delete $previously_required{$colname};
636 # no longer require any columns not specified
637 foreach my $colname ( keys %previously_required ) {
638 $column_info->{$colname}{required} = 0;
639 $column_info->{$colname}{nullable} = 1;
642 # update column metadata
643 $class->COLUMN_INFO($column_info);
646 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
649 =head2 column_required
651 Returns true if a column is required
653 my $required = $class->column_required($column_name);
655 Columns can be required by the application but not the database, but not the other way around,
656 hence there is also a column_nullable method which will tell you if the column is nullable
657 within the database itself.
661 sub column_required {
662 my ($class, $colname) = @_;
663 $colname or $class->_croak( "Need a column for column_required" );
664 $class->_column_info() unless ref $class->COLUMN_INFO;
665 if ($class->_isa_class($colname)) {
666 return $class->_isa_class($colname)->column_required($colname);
668 unless ( $class->find_column($colname) ) {
669 # handle non-existant columns
670 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
673 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
677 =head2 column_nullable
679 Returns true if a column can be NULL within the underlying database and false if not.
681 my $nullable = $class->column_nullable($column_name);
683 Any columns that are not nullable will automatically be specified as required, you can
684 also specify nullable columns as required within your application.
686 It is recomended you use column_required rather than column_nullable within your
687 application, this method is more useful if extending the model or handling your own
692 sub column_nullable {
694 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
696 $class->_column_info() unless ref $class->COLUMN_INFO;
697 if ($class->_isa_class($colname)) {
698 return $class->_isa_class($colname)->column_nullable($colname);
700 unless ( $class->find_column($colname) ) {
701 # handle non-existant columns
702 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
705 return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
709 =head2 column_default
711 Returns default value for column or the empty string.
712 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
719 my $colname = shift or $class->_croak( "Need a column for column_default");
720 $class->_column_info() unless (ref $class->COLUMN_INFO);
721 if ($class->_isa_class($colname)) {
722 return $class->_isa_class($colname)->column_default($colname);
724 unless ( $class->find_column($colname) ) {
725 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
729 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
733 =head2 get_classmetadata
735 Gets class meta data *excluding cgi input* for the passed in class or the
736 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
737 templates when you need some metadata for a related class.
741 sub get_classmetadata {
742 my ($self, $class) = @_; # class is class we want data for
744 $class = ref $class || $class;
748 $res{colnames} = {$class->column_names};
749 $res{columns} = [$class->display_columns];
750 $res{list_columns} = [$class->list_columns];
751 $res{moniker} = $class->moniker;
752 $res{plural} = $class->plural_moniker;
753 $res{table} = $class->table;
754 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
761 L<Maypole>, L<Maypole::Model::Base>.
765 Maypole is currently maintained by Aaron Trevena.
767 =head1 AUTHOR EMERITUS
769 Simon Cozens, C<simon#cpan.org>
771 Simon Flack maintained Maypole from 2.05 to 2.09
773 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
777 You may distribute this code under the same terms as Perl itself.