1 package Maypole::Model::CDBI;
8 Maypole::Model::CDBI - Model class based on Class::DBI
12 This is a master model class which uses L<Class::DBI> to do all the hard
13 work of fetching rows and representing them as objects. It is a good
14 model to copy if you're replacing it with other database abstraction
17 It implements a base set of methods required for a Maypole Data Model.
19 It inherits accessor and helper methods from L<Maypole::Model::Base>.
21 When specified as the application model, it will use Class::DBI::Loader
22 to generate the model classes from the provided database. If you do not
23 wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
24 will instead use Class::DBI classes provided.
28 use base qw(Maypole::Model::Base Class::DBI);
29 #use Class::DBI::Plugin::Type;
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
47 sub Untainter { 'CGI::Untaint::Maypole' };
51 #use Class::DBI::FromCGI;
53 #sub Untainter { 'CGI::Untaint' };
56 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
60 Action methods are methods that are accessed through web (or other public) interface.
64 If there is an object in C<$r-E<gt>objects>, then it should be edited
65 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
66 be created with those parameters, and put back into C<$r-E<gt>objects>.
67 The template should be changed to C<view>, or C<edit> if there were any
68 errors. A hash of errors will be passed to the template.
72 sub do_edit : Exported {
73 my ($self, $r, $obj) = @_;
75 my $config = $r->config;
76 my $table = $r->table;
78 # handle cancel button hit
79 if ( $r->{params}->{cancel} ) {
81 $r->objects( [$self->retrieve_all] );
85 my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
86 my $ignored_cols = $config->{$table}{ignore_cols} || [];
88 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
90 # handle errors, if none, proceed to view the newly created/updated object
91 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
94 # Set it up as it was:
95 $r->template_args->{cgi_params} = $r->params;
97 # replace user unfriendly error messages with something nicer
99 foreach (@{$config->{$table}->{required_cols}}) {
100 next unless ($errors{$_});
103 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
104 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
105 delete $errors{$key};
108 foreach (keys %errors) {
111 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
112 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
115 undef $obj if $creating;
117 die "do_update failed with error : $fatal" if ($fatal);
118 $r->template("edit");
120 $r->template("view");
125 $r->objects( $obj ? [$obj] : []);
128 # split out from do_edit to be reported by Mp::P::Trace
129 sub _do_update_or_create {
130 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
135 my $h = $self->Untainter->new( %{$r->params} );
139 # We have something to edit
140 eval { $obj->update_from_cgi( $r => {
141 required => $required_cols,
142 ignore => $ignored_cols,
144 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
149 $obj = $self->create_from_cgi( $r => {
150 required => $required_cols,
151 ignore => $ignored_cols,
157 return $obj, $fatal, $creating;
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 delete method is deprecated\n";
182 $self->do_delete(@_);
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);
235 \%values, ( $order ? { order_by => $order } : () )
239 $r->{template_args}{search} = 1;
244 The C<list> method fills C<$r-E<gt>objects> with all of the
245 objects in the class. The results are paged using a pager.
249 sub list : Exported {
250 my ( $self, $r ) = @_;
251 my $order = $self->order($r);
252 $self = $self->do_pager($r);
254 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
257 $r->objects( [ $self->retrieve_all ] );
261 ###############################################################################
264 =head1 Helper Methods
269 This class method is passed the name of a model class that represensts a table
270 and allows the master model class to do any set-up required.
275 my ( $self, $child ) = @_;
276 $child->autoupdate(1);
277 if ( my $col = $child->stringify_column ) {
278 $child->columns( Stringify => $col );
285 This method returns a list of has-many accessors. A brewery has many
286 beers, so C<BeerDB::Brewery> needs to return C<beers>.
291 my ( $self, $r ) = @_;
292 return keys %{ $self->meta_info('has_many') || {} };
298 Given an accessor name as a method, this function returns the class this accessor returns.
303 my ( $self, $r, $accessor ) = @_;
304 my $meta = $self->meta_info;
305 my @rels = keys %$meta;
308 $related = $meta->{$_}{$accessor};
311 return unless $related;
313 my $mapping = $related->{args}->{mapping};
314 if ( $mapping and @$mapping ) {
315 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
318 return $related->{foreign_class};
324 $class->related_meta($col);
326 Returns the hash ref of relationship meta info for a given column.
331 my ($self,$r, $accssr) = @_;
332 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
333 my $class_meta = $self->meta_info;
334 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
336 { return $class_meta->{$rel_type}->{$accssr} };
341 =head2 stringify_column
343 Returns the name of the column to use when stringifying
348 sub stringify_column {
351 $class->columns("Stringify"),
352 ( grep { /^(name|title)$/i } $class->columns ),
353 ( grep { /(name|title)/i } $class->columns ),
354 ( grep { !/id$/i } $class->primary_columns ),
360 Sets the pager template argument ($r->{template_args}{pager})
361 to a Class::DBI::Pager object based on the rows_per_page
362 value set in the configuration of the application.
364 This pager is used via the pager macro in TT Templates, and
365 is also accessible via Mason.
370 my ( $self, $r ) = @_;
371 if ( my $rows = $r->config->rows_per_page ) {
372 return $r->{template_args}{pager} =
373 $self->pager( $rows, $r->query->{page} );
375 else { return $self }
381 Returns the SQL order syntax based on the order parameter passed
382 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
384 $sql .= $self->order($r);
386 If the order column is not a column of this table,
387 or an order argument is not passed, then the return value is undefined.
389 Note: the returned value does not start with a space.
394 my ( $self, $r ) = @_;
395 my %ok_columns = map { $_ => 1 } $self->columns;
397 my $order = $q->{order};
398 return unless $order and $ok_columns{$order};
399 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
405 This method is inherited from Maypole::Model::Base and calls setup_database,
406 which uses Class::DBI::Loader to create and load Class::DBI classes from
407 the given database schema.
411 =head2 setup_database
413 The $opts argument is a hashref of options. The "options" key is a hashref of
414 Database connection options . Other keys may be various Loader arguments or
415 flags. It has this form:
417 # DB connection options
418 options { AutoCommit => 1 , ... },
427 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
428 $dsn ||= $config->dsn;
429 $u ||= $config->user;
430 $p ||= $config->pass;
431 $opts ||= $config->opts;
433 warn "No DSN set in config" unless $dsn;
434 $config->loader || $config->loader(
435 Class::DBI::Loader->new(
436 namespace => $namespace,
443 $config->{classes} = [ $config->{loader}->classes ];
444 $config->{tables} = [ $config->{loader}->tables ];
446 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
447 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
448 if $namespace->debug;
453 returns class for given table
458 my ( $self, $r, $table ) = @_;
459 return $r->config->loader->_table2class($table); # why not find_class ?
464 Returns 1 or more objects of the given class when provided with the request
470 my @pcs = $class->primary_columns;
473 @pks{@pcs}=(@{$r->{args}});
474 return $class->retrieve( %pks );
476 return $class->retrieve( $r->{args}->[0] );
485 Private method to return the class a column
486 belongs to that was inherited by an is_a relationship.
487 This should probably be public but need to think of API
492 my ($class, $col) = @_;
493 $class->_croak( "Need a column for _isa_class." ) unless $col;
495 my $isa = $class->meta_info("is_a") || {};
496 foreach ( keys %$isa ) {
497 $isaclass = $isa->{$_}->foreign_class;
498 return $isaclass if ($isaclass->find_column($col));
500 return; # col not in a is_a class
504 # Thanks to dave baird -- form builder for these private functions
508 my $dbh = $self->db_Main;
510 my $meta; # The info we are after
511 my ($catalog, $schema) = (undef, undef);
512 # Dave is suspicious this (above undefs) could
513 # break things if driver useses this info
515 my $original_metadata;
516 # '%' is a search pattern for columns - matches all columns
517 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
518 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
519 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
521 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
524 return $self->COLUMN_INFO;
527 sub _hash_type_meta {
528 my ($self, $sth) = @_;
530 while ( my $row = $sth->fetchrow_hashref ) {
531 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
533 # required / nullable
534 $meta->{$colname}{nullable} = $row->{NULLABLE};
535 $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
538 if (defined $row->{COLUMN_DEF}) {
539 my $default = $row->{COLUMN_DEF};
540 $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
541 $meta->{$colname}{default} = $default;
543 $meta->{$colname}{default} = '';
547 my $type = $row->{mysql_type_name} || $row->{type};
549 $type = $row->{TYPE_NAME};
550 if ($row->{COLUMN_SIZE}) {
551 $type .= "($row->{COLUMN_SIZE})";
554 $type =~ s/['"]?(.*)['"]?::.*$/$1/;
556 if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
559 $meta->{$colname}{type} = $type;
562 $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
567 # typeless db e.g. sqlite
568 sub _hash_typeless_meta {
571 $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
572 unless $self->can( 'sql_fb_meta_dummy' );
574 my $sth = $self->sql_fb_meta_dummy;
576 $sth->execute or die "Error executing column info: " . $sth->errstr;;
578 # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
579 my $cols = $sth->{NAME};
580 my $types = $sth->{TYPE};
581 # my $sizes = $sth->{PRECISION}; # empty
582 # my $nulls = $sth->{NULLABLE}; # empty
584 # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
589 foreach my $col ( @$cols ) {
591 $col_meta->{nullable} = 1;
592 $col_meta->{required} = 0;
593 $col_meta->{default} = '';
594 $col_meta->{position} = $order++;
595 # type_name is taken literally from the schema, but is not actually used by sqlite,
596 # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
597 my $type = shift( @$types );
598 $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
599 $meta->{$col} = $col_meta;
606 my $type = $class->column_type('column_name');
608 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
609 For now, it returns "BOOL" for tinyints.
611 TODO :: TEST with enums
617 my $colname = shift or die "Need a column for column_type";
618 $class->_column_info() unless (ref $class->COLUMN_INFO);
620 if ($class->_isa_class($colname)) {
621 return $class->_isa_class($colname)->column_type($colname);
623 unless ( $class->find_column($colname) ) {
624 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
627 return $class->COLUMN_INFO->{$colname}{type};
630 =head2 required_columns
632 Accessor to get/set required columns for forms, validation, etc.
634 Returns list of required columns. Accepts an array ref of column names.
636 $class->required_columns([qw/foo bar baz/]);
638 Allows you to specify the required columns for a class, over-riding any
639 assumptions and guesses made by Maypole.
641 Use this instead of $config->{$table}{required_cols}
643 Note : you need to setup the model class before calling this method.
647 sub required_columns {
648 my ($class, $columns) = @_;
649 $class->_column_info() unless ref $class->COLUMN_INFO;
650 my $column_info = $class->COLUMN_INFO;
653 foreach my $colname ( @$columns ) {
654 if ($class->_isa_class($colname)) {
655 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
656 unless ($class->_isa_class($colname)->column_required);
659 unless ( $class->find_column($colname) ) {
660 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
663 $column_info->{$colname}{required} = 1;
665 $class->COLUMN_INFO($column_info);
668 return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
671 =head2 column_required
673 Returns true if a column is required
675 my $required = $class->column_required($column_name);
677 Columns can be required by the application but not the database, but not the other way around,
678 hence there is also a column_nullable method which will tell you if the column is nullable
679 within the database itself.
683 sub column_required {
684 my ($class, $colname) = @_;
685 $colname or $class->_croak( "Need a column for column_nullable" );
686 $class->_column_info() unless ref $class->COLUMN_INFO;
687 if ($class->_isa_class($colname)) {
688 return $class->_isa_class($colname)->column_required($colname);
690 unless ( $class->find_column($colname) ) {
691 # handle non-existant columns
692 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
695 return $class->COLUMN_INFO->{$colname}{required} || 0;
698 =head2 column_nullable
700 Returns true if a column can be NULL within the underlying database and false if not.
702 my $nullable = $class->column_nullable($column_name);
704 Any columns that are not nullable will automatically be specified as required, you can
705 also specify nullable columns as required within your application.
707 It is recomended you use column_required rather than column_nullable within your
708 application, this method is more useful if extending the model or handling your own
713 sub column_nullable {
715 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
717 $class->_column_info() unless ref $class->COLUMN_INFO;
718 if ($class->_isa_class($colname)) {
719 return $class->_isa_class($colname)->column_nullable($colname);
721 unless ( $class->find_column($colname) ) {
722 # handle non-existant columns
723 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
726 return $class->COLUMN_INFO->{$colname}{nullable} || 0;
729 =head2 column_default
731 Returns default value for column or the empty string.
732 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
739 my $colname = shift or $class->_croak( "Need a column for column_default");
740 $class->_column_info() unless (ref $class->COLUMN_INFO);
741 if ($class->_isa_class($colname)) {
742 return $class->_isa_class($colname)->column_default($colname);
744 unless ( $class->find_column($colname) ) {
745 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
749 return $class->COLUMN_INFO->{$colname}{default};
752 =head2 get_classmetadata
754 Gets class meta data *excluding cgi input* for the passed in class or the
755 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
756 templates when you need some metadata for a related class.
760 sub get_classmetadata {
761 my ($self, $class) = @_; # class is class we want data for
763 $class = ref $class || $class;
767 $res{colnames} = {$class->column_names};
768 $res{columns} = [$class->display_columns];
769 $res{list_columns} = [$class->list_columns];
770 $res{moniker} = $class->moniker;
771 $res{plural} = $class->plural_moniker;
772 $res{table} = $class->table;
773 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;