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 Deprecated method that calls do_delete or a given classes delete method, please
151 use do_delete instead
155 Unsuprisingly, this command causes a database record to be forever lost.
157 This method replaces the, now deprecated, delete method provided in prior versions
161 sub delete : Exported {
163 my ($sub) = (caller(1))[3];
164 # So subclasses can still send delete down ...
165 $sub =~ /^(.+)::([^:]+)$/;
166 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
167 $self->SUPER::delete(@_);
169 warn "Maypole::Model::CDBI delete method is deprecated\n";
170 $self->do_delete(@_);
175 my ( $self, $r ) = @_;
176 # FIXME: handle fatal error with exception
177 $_->SUPER::delete for @{ $r->objects || [] };
179 $r->objects( [ $self->retrieve_all ] );
180 $r->{template} = "list";
186 Deprecated searching method - use do_search instead.
190 This action method searches for database records, it replaces
191 the, now deprecated, search method previously provided.
195 sub search : Exported {
197 my ($sub) = (caller(1))[3];
198 # So subclasses can still send search down ...
199 if ($sub =~ /^(.+)::([^:]+)$/) {
200 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
201 $self->SUPER::search(@_) : $self->do_search(@_);
203 $self->SUPER::search(@_);
207 sub do_search : Exported {
208 my ( $self, $r ) = @_;
209 my %fields = map { $_ => 1 } $self->columns;
210 my $oper = "like"; # For now
211 my %params = %{ $r->{params} };
212 my %values = map { $_ => { $oper, $params{$_} } }
213 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
216 $r->template("list");
217 if ( !%values ) { return $self->list($r) }
218 my $order = $self->order($r);
219 $self = $self->do_pager($r);
223 \%values, ( $order ? { order_by => $order } : () )
227 $r->{template_args}{search} = 1;
232 The C<list> method fills C<$r-E<gt>objects> with all of the
233 objects in the class. The results are paged using a pager.
237 sub list : Exported {
238 my ( $self, $r ) = @_;
239 my $order = $self->order($r);
240 $self = $self->do_pager($r);
242 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
245 $r->objects( [ $self->retrieve_all ] );
249 ###############################################################################
252 =head1 Helper Methods
257 This class method is passed the name of a model class that represents a table
258 and allows the master model class to do any set-up required.
263 my ( $self, $child ) = @_;
264 $child->autoupdate(1);
265 if ( my $col = $child->stringify_column ) {
266 $child->columns( Stringify => $col );
273 This method returns a list of has-many accessors. A brewery has many
274 beers, so C<BeerDB::Brewery> needs to return C<beers>.
279 my ( $self, $r ) = @_;
280 return keys %{ $self->meta_info('has_many') || {} };
286 Given an accessor name as a method, this function returns the class this accessor returns.
291 my ( $self, $r, $accessor ) = @_;
292 my $meta = $self->meta_info;
293 my @rels = keys %$meta;
296 $related = $meta->{$_}{$accessor};
299 return unless $related;
301 my $mapping = $related->{args}->{mapping};
302 if ( $mapping and @$mapping ) {
303 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
306 return $related->{foreign_class};
312 $class->related_meta($col);
314 Returns the hash ref of relationship meta info for a given column.
319 my ($self,$r, $accssr) = @_;
320 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
321 my $class_meta = $self->meta_info;
322 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
324 { return $class_meta->{$rel_type}->{$accssr} };
329 =head2 stringify_column
331 Returns the name of the column to use when stringifying
336 sub stringify_column {
339 $class->columns("Stringify"),
340 ( grep { /^(name|title)$/i } $class->columns ),
341 ( grep { /(name|title)/i } $class->columns ),
342 ( grep { !/id$/i } $class->primary_columns ),
348 Sets the pager template argument ($r->{template_args}{pager})
349 to a Class::DBI::Pager object based on the rows_per_page
350 value set in the configuration of the application.
352 This pager is used via the pager macro in TT Templates, and
353 is also accessible via Mason.
358 my ( $self, $r ) = @_;
359 if ( my $rows = $r->config->rows_per_page ) {
360 return $r->{template_args}{pager} =
361 $self->pager( $rows, $r->query->{page} );
363 else { return $self }
369 Returns the SQL order syntax based on the order parameter passed
370 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
372 $sql .= $self->order($r);
374 If the order column is not a column of this table,
375 or an order argument is not passed, then the return value is undefined.
377 Note: the returned value does not start with a space.
382 my ( $self, $r ) = @_;
383 my %ok_columns = map { $_ => 1 } $self->columns;
385 my $order = $q->{order};
386 return unless $order and $ok_columns{$order};
387 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
394 Returns 1 or more objects of the given class when provided with the request
400 my @pcs = $class->primary_columns;
403 @pks{@pcs}=(@{$r->{args}});
404 return $class->retrieve( %pks );
406 return $class->retrieve( $r->{args}->[0] );
412 Private method to return the class a column
413 belongs to that was inherited by an is_a relationship.
414 This should probably be public but need to think of API
419 my ($class, $col) = @_;
420 $class->_croak( "Need a column for _isa_class." ) unless $col;
422 my $isa = $class->meta_info("is_a") || {};
423 foreach ( keys %$isa ) {
424 $isaclass = $isa->{$_}->foreign_class;
425 return $isaclass if ($isaclass->find_column($col));
427 return; # col not in a is_a class
431 # Thanks to dave baird -- form builder for these private functions
435 my $dbh = $self->db_Main;
437 my $meta; # The info we are after
438 my ($catalog, $schema) = (undef, undef);
439 # Dave is suspicious this (above undefs) could
440 # break things if driver useses this info
442 my $original_metadata;
443 # '%' is a search pattern for columns - matches all columns
444 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
445 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
446 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
448 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
451 return $self->COLUMN_INFO;
454 sub _hash_type_meta {
455 my ($self, $sth) = @_;
457 while ( my $row = $sth->fetchrow_hashref ) {
458 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
460 # required / nullable
461 $meta->{$colname}{nullable} = $row->{NULLABLE};
462 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
465 if (defined $row->{COLUMN_DEF}) {
466 my $default = $row->{COLUMN_DEF};
467 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
468 $meta->{$colname}{default} = $default;
470 $meta->{$colname}{default} = '';
474 my $type = $row->{mysql_type_name} || $row->{type};
476 $type = $row->{TYPE_NAME};
477 if ($row->{COLUMN_SIZE}) {
478 $type .= "($row->{COLUMN_SIZE})";
481 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
483 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
486 $meta->{$colname}{type} = $type;
489 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
494 # typeless db e.g. sqlite
495 sub _hash_typeless_meta {
498 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
499 unless $self->can( 'sql_fb_meta_dummy' );
501 my $sth = $self->sql_fb_meta_dummy;
503 $sth->execute or die "Error executing column info: " . $sth->errstr;;
505 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
506 my $cols = $sth->{NAME};
507 my $types = $sth->{TYPE};
508 # my $sizes = $sth->{PRECISION}; # empty
509 # my $nulls = $sth->{NULLABLE}; # empty
511 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
516 foreach my $col ( @$cols ) {
518 $col_meta->{nullable} = 1;
519 $col_meta->{required} = 0;
520 $col_meta->{default} = '';
521 $col_meta->{position} = $order++;
522 # type_name is taken literally from the schema, but is not actually used by sqlite,
523 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
524 my $type = shift( @$types );
525 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
526 $meta->{$col} = $col_meta;
533 my $type = $class->column_type('column_name');
535 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
536 For now, it returns "BOOL" for tinyints.
538 TODO :: TEST with enums
544 my $colname = shift or die "Need a column for column_type";
545 $class->_column_info() unless (ref $class->COLUMN_INFO);
547 if ($class->_isa_class($colname)) {
548 return $class->_isa_class($colname)->column_type($colname);
550 unless ( $class->find_column($colname) ) {
551 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
554 return $class->COLUMN_INFO->{$colname}{type};
557 =head2 required_columns
559 Accessor to get/set required columns for forms, validation, etc.
561 Returns list of required columns. Accepts an array ref of column names.
563 $class->required_columns([qw/foo bar baz/]);
565 Allows you to specify the required columns for a class, over-riding any
566 assumptions and guesses made by Maypole.
568 Any columns specified as required will no longer be 'nullable' or optional, and
569 any columns not specified as 'required' will be 'nullable' or optional.
571 The default for a column is nullable, or whatever is discovered from database
574 Use this instead of $config->{$table}{required_cols}
576 Note : you need to setup the model class before calling this method.
580 sub required_columns {
581 my ($class, $columns) = @_;
582 $class->_column_info() unless (ref $class->COLUMN_INFO);
583 my $column_info = $class->COLUMN_INFO;
586 # get the previously required columns
587 my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
589 # update each specified column as required
590 foreach my $colname ( @$columns ) {
591 # handle C::DBI::Rel::IsA
592 if ($class->_isa_class($colname)) {
593 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
594 unless ($class->_isa_class($colname)->column_required);
597 unless ( $class->find_column($colname) ) {
598 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
601 $column_info->{$colname}{required} = 1;
602 delete $previously_required{$colname};
605 # no longer require any columns not specified
606 foreach my $colname ( keys %previously_required ) {
607 $column_info->{$colname}{required} = 0;
608 $column_info->{$colname}{nullable} = 1;
611 # update column metadata
612 $class->COLUMN_INFO($column_info);
615 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
618 =head2 column_required
620 Returns true if a column is required
622 my $required = $class->column_required($column_name);
624 Columns can be required by the application but not the database, but not the other way around,
625 hence there is also a column_nullable method which will tell you if the column is nullable
626 within the database itself.
630 sub column_required {
631 my ($class, $colname) = @_;
632 $colname or $class->_croak( "Need a column for column_required" );
633 $class->_column_info() unless ref $class->COLUMN_INFO;
634 if ($class->_isa_class($colname)) {
635 return $class->_isa_class($colname)->column_required($colname);
637 unless ( $class->find_column($colname) ) {
638 # handle non-existant columns
639 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
642 return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
646 =head2 column_nullable
648 Returns true if a column can be NULL within the underlying database and false if not.
650 my $nullable = $class->column_nullable($column_name);
652 Any columns that are not nullable will automatically be specified as required, you can
653 also specify nullable columns as required within your application.
655 It is recomended you use column_required rather than column_nullable within your
656 application, this method is more useful if extending the model or handling your own
661 sub column_nullable {
663 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
665 $class->_column_info() unless ref $class->COLUMN_INFO;
666 if ($class->_isa_class($colname)) {
667 return $class->_isa_class($colname)->column_nullable($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}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
678 =head2 column_default
680 Returns default value for column or the empty string.
681 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
688 my $colname = shift or $class->_croak( "Need a column for column_default");
689 $class->_column_info() unless (ref $class->COLUMN_INFO);
690 if ($class->_isa_class($colname)) {
691 return $class->_isa_class($colname)->column_default($colname);
693 unless ( $class->find_column($colname) ) {
694 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
698 return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
702 =head2 get_classmetadata
704 Gets class meta data *excluding cgi input* for the passed in class or the
705 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
706 templates when you need some metadata for a related class.
710 sub get_classmetadata {
711 my ($self, $class) = @_; # class is class we want data for
713 $class = ref $class || $class;
717 $res{colnames} = {$class->column_names};
718 $res{columns} = [$class->display_columns];
719 $res{list_columns} = [$class->list_columns];
720 $res{moniker} = $class->moniker;
721 $res{plural} = $class->plural_moniker;
722 $res{table} = $class->table;
723 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
730 L<Maypole>, L<Maypole::Model::CDBI::Base>.
734 Maypole is currently maintained by Aaron Trevena.
736 =head1 AUTHOR EMERITUS
738 Simon Cozens, C<simon#cpan.org>
740 Simon Flack maintained Maypole from 2.05 to 2.09
742 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
746 You may distribute this code under the same terms as Perl itself.