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(@_);
186 sub do_delete : Exported {
187 my ( $self, $r ) = @_;
188 # FIXME: handle fatal error with exception
189 $_->SUPER::delete for @{ $r->objects || [] };
191 $r->objects( [ $self->retrieve_all ] );
192 $r->{template} = "list";
198 Deprecated searching method - use do_search instead.
202 This action method searches for database records, it replaces
203 the, now deprecated, search method previously provided.
207 sub search : Exported {
209 my ($sub) = (caller(1))[3];
210 # So subclasses can still send search down ...
211 if ($sub =~ /^(.+)::([^:]+)$/) {
212 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
213 $self->SUPER::search(@_) : $self->do_search(@_);
215 $self->SUPER::search(@_);
219 sub do_search : Exported {
220 my ( $self, $r ) = @_;
221 my %fields = map { $_ => 1 } $self->columns;
222 my $oper = "like"; # For now
223 my %params = %{ $r->{params} };
224 my %values = map { $_ => { $oper, $params{$_} } }
225 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
228 $r->template("list");
229 if ( !%values ) { return $self->list($r) }
230 my $order = $self->order($r);
231 $self = $self->do_pager($r);
233 # FIXME: use pager info to get slice of iterator instead of all the objects as array
238 \%values, ( $order ? { order_by => $order } : () )
242 $r->{template_args}{search} = 1;
247 The C<list> method fills C<$r-E<gt>objects> with all of the
248 objects in the class. The results are paged using a pager.
252 sub list : Exported {
253 my ( $self, $r ) = @_;
254 my $order = $self->order($r);
255 $self = $self->do_pager($r);
257 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
260 $r->objects( [ $self->retrieve_all ] );
264 ###############################################################################
267 =head1 Helper Methods
272 This class method is passed the name of a model class that represents a table
273 and allows the master model class to do any set-up required.
278 my ( $self, $child ) = @_;
279 $child->autoupdate(1);
280 if ( my $col = $child->stringify_column ) {
281 $child->columns( Stringify => $col );
288 This method returns a list of has-many accessors. A brewery has many
289 beers, so C<BeerDB::Brewery> needs to return C<beers>.
294 my ( $self, $r ) = @_;
295 return keys %{ $self->meta_info('has_many') || {} };
301 Given an accessor name as a method, this function returns the class this accessor returns.
306 my ( $self, $r, $accessor ) = @_;
307 my $meta = $self->meta_info;
308 my @rels = keys %$meta;
311 $related = $meta->{$_}{$accessor};
314 return unless $related;
316 my $mapping = $related->{args}->{mapping};
317 if ( $mapping and @$mapping ) {
318 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
321 return $related->{foreign_class};
325 =head2 search_columns
327 $class->search_columns;
329 Returns a list of columns suitable for searching - used in factory templates, over-ridden in
330 classes. Provides same list as display_columns unless over-ridden.
336 return $class->display_columns;
342 $class->related_meta($col);
344 Returns the hash ref of relationship meta info for a given column.
349 my ($self,$r, $accssr) = @_;
350 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
351 my $class_meta = $self->meta_info;
352 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
354 { return $class_meta->{$rel_type}->{$accssr} };
359 =head2 stringify_column
361 Returns the name of the column to use when stringifying
366 sub stringify_column {
369 $class->columns("Stringify"),
370 ( grep { /^(name|title)$/i } $class->columns ),
371 ( grep { /(name|title)/i } $class->columns ),
372 ( grep { !/id$/i } $class->primary_columns ),
378 Sets the pager template argument ($r->{template_args}{pager})
379 to a Class::DBI::Pager object based on the rows_per_page
380 value set in the configuration of the application.
382 This pager is used via the pager macro in TT Templates, and
383 is also accessible via Mason.
388 my ( $self, $r ) = @_;
389 if ( my $rows = $r->config->rows_per_page ) {
390 return $r->{template_args}{pager} =
391 $self->pager( $rows, $r->query->{page} );
393 else { return $self }
399 Returns the SQL order syntax based on the order parameter passed
400 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
402 $sql .= $self->order($r);
404 If the order column is not a column of this table,
405 or an order argument is not passed, then the return value is undefined.
407 Note: the returned value does not start with a space.
412 my ( $self, $r ) = @_;
413 my %ok_columns = map { $_ => 1 } $self->columns;
415 my $order = $q->{order};
416 return unless $order and $ok_columns{$order};
417 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
424 Returns 1 or more objects of the given class when provided with the request
430 my @pcs = $class->primary_columns;
433 @pks{@pcs}=(@{$r->{args}});
434 return $class->retrieve( %pks );
436 return $class->retrieve( $r->{args}->[0] );
442 Private method to return the class a column
443 belongs to that was inherited by an is_a relationship.
444 This should probably be public but need to think of API
449 my ($class, $col) = @_;
450 $class->_croak( "Need a column for _isa_class." ) unless $col;
452 my $isa = $class->meta_info("is_a") || {};
453 foreach ( keys %$isa ) {
454 $isaclass = $isa->{$_}->foreign_class;
455 return $isaclass if ($isaclass->find_column($col));
457 return; # col not in a is_a class
461 # Thanks to dave baird -- form builder for these private functions
465 my $dbh = $self->db_Main;
467 my $meta; # The info we are after
468 my ($catalog, $schema) = (undef, undef);
469 # Dave is suspicious this (above undefs) could
470 # break things if driver useses this info
472 my $original_metadata;
473 # '%' is a search pattern for columns - matches all columns
474 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
475 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
476 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
478 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
481 return $self->COLUMN_INFO;
484 sub _hash_type_meta {
485 my ($self, $sth) = @_;
487 while ( my $row = $sth->fetchrow_hashref ) {
488 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
490 # required / nullable
491 $meta->{$colname}{nullable} = $row->{NULLABLE};
492 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
495 if (defined $row->{COLUMN_DEF}) {
496 my $default = $row->{COLUMN_DEF};
497 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
498 $meta->{$colname}{default} = $default;
500 $meta->{$colname}{default} = '';
504 my $type = $row->{mysql_type_name} || $row->{type};
506 $type = $row->{TYPE_NAME};
507 if ($row->{COLUMN_SIZE}) {
508 $type .= "($row->{COLUMN_SIZE})";
511 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
513 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
516 $meta->{$colname}{type} = $type;
519 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
524 # typeless db e.g. sqlite
525 sub _hash_typeless_meta {
528 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
529 unless $self->can( 'sql_fb_meta_dummy' );
531 my $sth = $self->sql_fb_meta_dummy;
533 $sth->execute or die "Error executing column info: " . $sth->errstr;;
535 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
536 my $cols = $sth->{NAME};
537 my $types = $sth->{TYPE};
538 # my $sizes = $sth->{PRECISION}; # empty
539 # my $nulls = $sth->{NULLABLE}; # empty
541 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
546 foreach my $col ( @$cols ) {
548 $col_meta->{nullable} = 1;
549 $col_meta->{required} = 0;
550 $col_meta->{default} = '';
551 $col_meta->{position} = $order++;
552 # type_name is taken literally from the schema, but is not actually used by sqlite,
553 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
554 my $type = shift( @$types );
555 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
556 $meta->{$col} = $col_meta;
563 my $type = $class->column_type('column_name');
565 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
566 For now, it returns "BOOL" for tinyints.
568 TODO :: TEST with enums
574 my $colname = shift or die "Need a column for column_type";
575 $class->_column_info() unless (ref $class->COLUMN_INFO);
577 if ($class->_isa_class($colname)) {
578 return $class->_isa_class($colname)->column_type($colname);
580 unless ( $class->find_column($colname) ) {
581 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
584 return $class->COLUMN_INFO->{$colname}{type};
587 =head2 required_columns
589 Accessor to get/set required columns for forms, validation, etc.
591 Returns list of required columns. Accepts an array ref of column names.
593 $class->required_columns([qw/foo bar baz/]);
595 Allows you to specify the required columns for a class, over-riding any
596 assumptions and guesses made by Maypole.
598 Any columns specified as required will no longer be 'nullable' or optional, and
599 any columns not specified as 'required' will be 'nullable' or optional.
601 The default for a column is nullable, or whatever is discovered from database
604 Use this instead of $config->{$table}{required_cols}
606 Note : you need to setup the model class before calling this method.
610 sub required_columns {
611 my ($class, $columns) = @_;
612 $class->_column_info() unless (ref $class->COLUMN_INFO);
613 my $column_info = $class->COLUMN_INFO;
616 # get the previously required columns
617 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
619 # update each specified column as required
620 foreach my $colname ( @$columns ) {
621 # handle C::DBI::Rel::IsA
622 if ($class->_isa_class($colname)) {
623 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
624 unless ($class->_isa_class($colname)->column_required);
627 unless ( $class->find_column($colname) ) {
628 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
631 $column_info->{$colname}{required} = 1;
632 delete $previously_required{$colname};
635 # no longer require any columns not specified
636 foreach my $colname ( keys %previously_required ) {
637 $column_info->{$colname}{required} = 0;
638 $column_info->{$colname}{nullable} = 1;
641 # update column metadata
642 $class->COLUMN_INFO($column_info);
645 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
648 =head2 column_required
650 Returns true if a column is required
652 my $required = $class->column_required($column_name);
654 Columns can be required by the application but not the database, but not the other way around,
655 hence there is also a column_nullable method which will tell you if the column is nullable
656 within the database itself.
660 sub column_required {
661 my ($class, $colname) = @_;
662 $colname or $class->_croak( "Need a column for column_required" );
663 $class->_column_info() unless ref $class->COLUMN_INFO;
664 if ($class->_isa_class($colname)) {
665 return $class->_isa_class($colname)->column_required($colname);
667 unless ( $class->find_column($colname) ) {
668 # handle non-existant columns
669 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
672 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
676 =head2 column_nullable
678 Returns true if a column can be NULL within the underlying database and false if not.
680 my $nullable = $class->column_nullable($column_name);
682 Any columns that are not nullable will automatically be specified as required, you can
683 also specify nullable columns as required within your application.
685 It is recomended you use column_required rather than column_nullable within your
686 application, this method is more useful if extending the model or handling your own
691 sub column_nullable {
693 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
695 $class->_column_info() unless ref $class->COLUMN_INFO;
696 if ($class->_isa_class($colname)) {
697 return $class->_isa_class($colname)->column_nullable($colname);
699 unless ( $class->find_column($colname) ) {
700 # handle non-existant columns
701 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
704 return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
708 =head2 column_default
710 Returns default value for column or the empty string.
711 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
718 my $colname = shift or $class->_croak( "Need a column for column_default");
719 $class->_column_info() unless (ref $class->COLUMN_INFO);
720 if ($class->_isa_class($colname)) {
721 return $class->_isa_class($colname)->column_default($colname);
723 unless ( $class->find_column($colname) ) {
724 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
728 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
732 =head2 get_classmetadata
734 Gets class meta data *excluding cgi input* for the passed in class or the
735 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
736 templates when you need some metadata for a related class.
740 sub get_classmetadata {
741 my ($self, $class) = @_; # class is class we want data for
743 $class = ref $class || $class;
747 $res{colnames} = {$class->column_names};
748 $res{columns} = [$class->display_columns];
749 $res{list_columns} = [$class->list_columns];
750 $res{moniker} = $class->moniker;
751 $res{plural} = $class->plural_moniker;
752 $res{table} = $class->table;
753 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
760 L<Maypole>, L<Maypole::Model::Base>.
764 Maypole is currently maintained by Aaron Trevena.
766 =head1 AUTHOR EMERITUS
768 Simon Cozens, C<simon#cpan.org>
770 Simon Flack maintained Maypole from 2.05 to 2.09
772 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
776 You may distribute this code under the same terms as Perl itself.