1 package Maypole::Model::CDBI;
9 Maypole::Model::CDBI - Model class based on Class::DBI
13 This is a master model class which uses L<Class::DBI> to do all the hard
14 work of fetching rows and representing them as objects. It is a good
15 model to copy if you're replacing it with other database abstraction
18 It implements a base set of methods required for a Maypole Data Model.
20 It inherits accessor and helper methods from L<Maypole::Model::Base>.
22 When specified as the application model, it will use Class::DBI::Loader
23 to generate the model classes from the provided database. If you do not
24 wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
25 will instead use Class::DBI classes provided.
29 use base qw(Maypole::Model::Base Class::DBI);
30 use Class::DBI::Loader;
31 use Class::DBI::AbstractSearch;
32 use Class::DBI::Plugin::RetrieveAll;
33 use Class::DBI::Pager;
34 use Lingua::EN::Inflect::Number qw(to_PL);
37 use Maypole::Model::CDBI::AsForm;
38 use Maypole::Model::CDBI::FromCGI;
39 use CGI::Untaint::Maypole;
43 Set the class you use to untaint and validate form data
44 Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint
48 sub Untainter { 'CGI::Untaint::Maypole' };
50 =head2 add_model_superclass
52 Adds model as superclass to model classes (if necessary)
56 sub add_model_superclass {
57 my ($class,$config) = @_;
58 foreach my $subclass ( @{ $config->classes } ) {
59 next if $subclass->isa("Maypole::Model::Base");
61 push @{ $subclass . "::ISA" }, $config->model;
67 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
71 Action methods are methods that are accessed through web (or other public) interface.
75 If there is an object in C<$r-E<gt>objects>, then it should be edited
76 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
77 be created with those parameters, and put back into C<$r-E<gt>objects>.
78 The template should be changed to C<view>, or C<edit> if there were any
79 errors. A hash of errors will be passed to the template.
83 sub do_edit : Exported {
84 my ($self, $r, $obj) = @_;
86 my $config = $r->config;
87 my $table = $r->table;
89 # handle cancel button hit
90 if ( $r->{params}->{cancel} ) {
92 $r->objects( [$self->retrieve_all] );
96 my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
97 my $ignored_cols = $config->{$table}{ignore_cols} || [];
99 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
101 # handle errors, if none, proceed to view the newly created/updated object
102 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
105 # Set it up as it was:
106 $r->template_args->{cgi_params} = $r->params;
108 # replace user unfriendly error messages with something nicer
110 foreach (@{$config->{$table}->{required_cols}}) {
111 next unless ($errors{$_});
114 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
115 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
116 delete $errors{$key};
119 foreach (keys %errors) {
122 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
123 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
126 undef $obj if $creating;
128 die "do_update failed with error : $fatal" if ($fatal);
129 $r->template("edit");
131 $r->template("view");
136 $r->objects( $obj ? [$obj] : []);
139 # split out from do_edit to be reported by Mp::P::Trace
140 sub _do_update_or_create {
141 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
146 my $h = $self->Untainter->new( %{$r->params} );
150 # We have something to edit
151 eval { $obj->update_from_cgi( $r => {
152 required => $required_cols,
153 ignore => $ignored_cols,
155 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
160 $obj = $self->create_from_cgi( $r => {
161 required => $required_cols,
162 ignore => $ignored_cols,
168 return $obj, $fatal, $creating;
173 Deprecated method that calls do_delete or a given classes delete method, please
174 use do_delete instead
178 Unsuprisingly, this command causes a database record to be forever lost.
180 This method replaces the, now deprecated, delete method provided in prior versions
184 sub delete : Exported {
186 my ($sub) = (caller(1))[3];
187 # So subclasses can still send delete down ...
188 $sub =~ /^(.+)::([^:]+)$/;
189 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
190 $self->SUPER::delete(@_);
192 warn "Maypole::Model::CDBI delete method is deprecated\n";
193 $self->do_delete(@_);
198 my ( $self, $r ) = @_;
199 # FIXME: handle fatal error with exception
200 $_->SUPER::delete for @{ $r->objects || [] };
202 $r->objects( [ $self->retrieve_all ] );
203 $r->{template} = "list";
209 Deprecated searching method - use do_search instead.
213 This action method searches for database records, it replaces
214 the, now deprecated, search method previously provided.
218 sub search : Exported {
220 my ($sub) = (caller(1))[3];
221 # So subclasses can still send search down ...
222 if ($sub =~ /^(.+)::([^:]+)$/) {
223 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
224 $self->SUPER::search(@_) : $self->do_search(@_);
226 $self->SUPER::search(@_);
230 sub do_search : Exported {
231 my ( $self, $r ) = @_;
232 my %fields = map { $_ => 1 } $self->columns;
233 my $oper = "like"; # For now
234 my %params = %{ $r->{params} };
235 my %values = map { $_ => { $oper, $params{$_} } }
236 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
239 $r->template("list");
240 if ( !%values ) { return $self->list($r) }
241 my $order = $self->order($r);
242 $self = $self->do_pager($r);
246 \%values, ( $order ? { order_by => $order } : () )
250 $r->{template_args}{search} = 1;
255 The C<list> method fills C<$r-E<gt>objects> with all of the
256 objects in the class. The results are paged using a pager.
260 sub list : Exported {
261 my ( $self, $r ) = @_;
262 my $order = $self->order($r);
263 $self = $self->do_pager($r);
265 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
268 $r->objects( [ $self->retrieve_all ] );
272 ###############################################################################
275 =head1 Helper Methods
280 This class method is passed the name of a model class that represensts a table
281 and allows the master model class to do any set-up required.
286 my ( $self, $child ) = @_;
287 $child->autoupdate(1);
288 if ( my $col = $child->stringify_column ) {
289 $child->columns( Stringify => $col );
296 This method returns a list of has-many accessors. A brewery has many
297 beers, so C<BeerDB::Brewery> needs to return C<beers>.
302 my ( $self, $r ) = @_;
303 return keys %{ $self->meta_info('has_many') || {} };
309 Given an accessor name as a method, this function returns the class this accessor returns.
314 my ( $self, $r, $accessor ) = @_;
315 my $meta = $self->meta_info;
316 my @rels = keys %$meta;
319 $related = $meta->{$_}{$accessor};
322 return unless $related;
324 my $mapping = $related->{args}->{mapping};
325 if ( $mapping and @$mapping ) {
326 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
329 return $related->{foreign_class};
335 $class->related_meta($col);
337 Returns the hash ref of relationship meta info for a given column.
342 my ($self,$r, $accssr) = @_;
343 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
344 my $class_meta = $self->meta_info;
345 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
347 { return $class_meta->{$rel_type}->{$accssr} };
352 =head2 stringify_column
354 Returns the name of the column to use when stringifying
359 sub stringify_column {
362 $class->columns("Stringify"),
363 ( grep { /^(name|title)$/i } $class->columns ),
364 ( grep { /(name|title)/i } $class->columns ),
365 ( grep { !/id$/i } $class->primary_columns ),
371 Sets the pager template argument ($r->{template_args}{pager})
372 to a Class::DBI::Pager object based on the rows_per_page
373 value set in the configuration of the application.
375 This pager is used via the pager macro in TT Templates, and
376 is also accessible via Mason.
381 my ( $self, $r ) = @_;
382 if ( my $rows = $r->config->rows_per_page ) {
383 return $r->{template_args}{pager} =
384 $self->pager( $rows, $r->query->{page} );
386 else { return $self }
392 Returns the SQL order syntax based on the order parameter passed
393 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
395 $sql .= $self->order($r);
397 If the order column is not a column of this table,
398 or an order argument is not passed, then the return value is undefined.
400 Note: the returned value does not start with a space.
405 my ( $self, $r ) = @_;
406 my %ok_columns = map { $_ => 1 } $self->columns;
408 my $order = $q->{order};
409 return unless $order and $ok_columns{$order};
410 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
416 This method is inherited from Maypole::Model::Base and calls setup_database,
417 which uses Class::DBI::Loader to create and load Class::DBI classes from
418 the given database schema.
422 =head2 setup_database
424 The $opts argument is a hashref of options. The "options" key is a hashref of
425 Database connection options . Other keys may be various Loader arguments or
426 flags. It has this form:
428 # DB connection options
429 options { AutoCommit => 1 , ... },
438 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
439 $dsn ||= $config->dsn;
440 $u ||= $config->user;
441 $p ||= $config->pass;
442 $opts ||= $config->opts;
444 warn "No DSN set in config" unless $dsn;
445 $config->loader || $config->loader(
446 Class::DBI::Loader->new(
447 namespace => $namespace,
454 $config->{classes} = [ $config->{loader}->classes ];
455 $config->{tables} = [ $config->{loader}->tables ];
457 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
458 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
459 if $namespace->debug;
464 returns class for given table
469 my ( $self, $r, $table ) = @_;
470 return $r->config->loader->_table2class($table); # why not find_class ?
475 Returns 1 or more objects of the given class when provided with the request
481 my @pcs = $class->primary_columns;
484 @pks{@pcs}=(@{$r->{args}});
485 return $class->retrieve( %pks );
487 return $class->retrieve( $r->{args}->[0] );
496 Private method to return the class a column
497 belongs to that was inherited by an is_a relationship.
498 This should probably be public but need to think of API
503 my ($class, $col) = @_;
504 $class->_croak( "Need a column for _isa_class." ) unless $col;
506 my $isa = $class->meta_info("is_a") || {};
507 foreach ( keys %$isa ) {
508 $isaclass = $isa->{$_}->foreign_class;
509 return $isaclass if ($isaclass->find_column($col));
511 return; # col not in a is_a class
515 # Thanks to dave baird -- form builder for these private functions
519 my $dbh = $self->db_Main;
521 my $meta; # The info we are after
522 my ($catalog, $schema) = (undef, undef);
523 # Dave is suspicious this (above undefs) could
524 # break things if driver useses this info
526 my $original_metadata;
527 # '%' is a search pattern for columns - matches all columns
528 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
529 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
530 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
532 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
535 return $self->COLUMN_INFO;
538 sub _hash_type_meta {
539 my ($self, $sth) = @_;
541 while ( my $row = $sth->fetchrow_hashref ) {
542 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
544 # required / nullable
545 $meta->{$colname}{nullable} = $row->{NULLABLE};
546 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
549 if (defined $row->{COLUMN_DEF}) {
550 my $default = $row->{COLUMN_DEF};
551 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
552 $meta->{$colname}{default} = $default;
554 $meta->{$colname}{default} = '';
558 my $type = $row->{mysql_type_name} || $row->{type};
560 $type = $row->{TYPE_NAME};
561 if ($row->{COLUMN_SIZE}) {
562 $type .= "($row->{COLUMN_SIZE})";
565 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
567 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
570 $meta->{$colname}{type} = $type;
573 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
578 # typeless db e.g. sqlite
579 sub _hash_typeless_meta {
582 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
583 unless $self->can( 'sql_fb_meta_dummy' );
585 my $sth = $self->sql_fb_meta_dummy;
587 $sth->execute or die "Error executing column info: " . $sth->errstr;;
589 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
590 my $cols = $sth->{NAME};
591 my $types = $sth->{TYPE};
592 # my $sizes = $sth->{PRECISION}; # empty
593 # my $nulls = $sth->{NULLABLE}; # empty
595 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
600 foreach my $col ( @$cols ) {
602 $col_meta->{nullable} = 1;
603 $col_meta->{required} = 0;
604 $col_meta->{default} = '';
605 $col_meta->{position} = $order++;
606 # type_name is taken literally from the schema, but is not actually used by sqlite,
607 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
608 my $type = shift( @$types );
609 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
610 $meta->{$col} = $col_meta;
617 my $type = $class->column_type('column_name');
619 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
620 For now, it returns "BOOL" for tinyints.
622 TODO :: TEST with enums
628 my $colname = shift or die "Need a column for column_type";
629 $class->_column_info() unless (ref $class->COLUMN_INFO);
631 if ($class->_isa_class($colname)) {
632 return $class->_isa_class($colname)->column_type($colname);
634 unless ( $class->find_column($colname) ) {
635 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
638 return $class->COLUMN_INFO->{$colname}{type};
641 =head2 required_columns
643 Accessor to get/set required columns for forms, validation, etc.
645 Returns list of required columns. Accepts an array ref of column names.
647 $class->required_columns([qw/foo bar baz/]);
649 Allows you to specify the required columns for a class, over-riding any
650 assumptions and guesses made by Maypole.
652 Use this instead of $config->{$table}{required_cols}
654 Note : you need to setup the model class before calling this method.
658 sub required_columns {
659 my ($class, $columns) = @_;
660 $class->_column_info() unless ref $class->COLUMN_INFO;
661 my $column_info = $class->COLUMN_INFO;
664 foreach my $colname ( @$columns ) {
665 if ($class->_isa_class($colname)) {
666 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
667 unless ($class->_isa_class($colname)->column_required);
670 unless ( $class->find_column($colname) ) {
671 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
674 $column_info->{$colname}{required} = 1;
676 $class->COLUMN_INFO($column_info);
679 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
682 =head2 column_required
684 Returns true if a column is required
686 my $required = $class->column_required($column_name);
688 Columns can be required by the application but not the database, but not the other way around,
689 hence there is also a column_nullable method which will tell you if the column is nullable
690 within the database itself.
694 sub column_required {
695 my ($class, $colname) = @_;
696 $colname 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_required($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}{required} || 0;
709 =head2 column_nullable
711 Returns true if a column can be NULL within the underlying database and false if not.
713 my $nullable = $class->column_nullable($column_name);
715 Any columns that are not nullable will automatically be specified as required, you can
716 also specify nullable columns as required within your application.
718 It is recomended you use column_required rather than column_nullable within your
719 application, this method is more useful if extending the model or handling your own
724 sub column_nullable {
726 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
728 $class->_column_info() unless ref $class->COLUMN_INFO;
729 if ($class->_isa_class($colname)) {
730 return $class->_isa_class($colname)->column_nullable($colname);
732 unless ( $class->find_column($colname) ) {
733 # handle non-existant columns
734 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
737 return $class->COLUMN_INFO->{$colname}{nullable} || 0;
740 =head2 column_default
742 Returns default value for column or the empty string.
743 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
750 my $colname = shift or $class->_croak( "Need a column for column_default");
751 $class->_column_info() unless (ref $class->COLUMN_INFO);
752 if ($class->_isa_class($colname)) {
753 return $class->_isa_class($colname)->column_default($colname);
755 unless ( $class->find_column($colname) ) {
756 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
760 return $class->COLUMN_INFO->{$colname}{default};
763 =head2 get_classmetadata
765 Gets class meta data *excluding cgi input* for the passed in class or the
766 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
767 templates when you need some metadata for a related class.
771 sub get_classmetadata {
772 my ($self, $class) = @_; # class is class we want data for
774 $class = ref $class || $class;
778 $res{colnames} = {$class->column_names};
779 $res{columns} = [$class->display_columns];
780 $res{list_columns} = [$class->list_columns];
781 $res{moniker} = $class->moniker;
782 $res{plural} = $class->plural_moniker;
783 $res{table} = $class->table;
784 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;