1 package Maypole::Model::CDBI;
6 Maypole::Model::CDBI - Model 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>.
19 When specified as the application model, it will use Class::DBI::Loader
20 to generate the model classes from the provided database. If you do not
21 wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
22 will instead use Class::DBI classes provided.
26 use base qw(Maypole::Model::Base Class::DBI);
27 #use Class::DBI::Plugin::Type;
28 use Class::DBI::Loader;
29 use Class::DBI::AbstractSearch;
30 use Class::DBI::Plugin::RetrieveAll;
31 use Class::DBI::Pager;
32 use Lingua::EN::Inflect::Number qw(to_PL);
35 use Maypole::Model::CDBI::AsForm;
36 use Maypole::Model::CDBI::FromCGI;
37 use CGI::Untaint::Maypole;
41 Set the class you use to untaint and validate form data
42 Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint
45 sub Untainter { 'CGI::Untaint::Maypole' };
49 #use Class::DBI::FromCGI;
51 #sub Untainter { 'CGI::Untaint' };
54 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
58 Action methods are methods that are accessed through web (or other public) interface.
62 If there is an object in C<$r-E<gt>objects>, then it should be edited
63 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
64 be created with those parameters, and put back into C<$r-E<gt>objects>.
65 The template should be changed to C<view>, or C<edit> if there were any
66 errors. A hash of errors will be passed to the template.
70 sub do_edit : Exported {
71 my ($self, $r, $obj) = @_;
73 my $config = $r->config;
74 my $table = $r->table;
76 # handle cancel button hit
77 if ( $r->{params}->{cancel} ) {
79 $r->objects( [$self->retrieve_all] );
83 my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
84 my $ignored_cols = $config->{$table}{ignore_cols} || [];
86 ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
88 # handle errors, if none, proceed to view the newly created/updated object
89 my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
92 # Set it up as it was:
93 $r->template_args->{cgi_params} = $r->params;
95 # replace user unfriendly error messages with something nicer
97 foreach (@{$config->{$table}->{required_cols}}) {
98 next unless ($errors{$_});
101 $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
102 $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
103 delete $errors{$key};
106 foreach (keys %errors) {
109 $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
110 $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
113 undef $obj if $creating;
115 die "do_update failed with error : $fatal" if ($fatal);
116 $r->template("edit");
118 $r->template("view");
123 $r->objects( $obj ? [$obj] : []);
126 # split out from do_edit to be reported by Mp::P::Trace
127 sub _do_update_or_create {
128 my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
133 my $h = $self->Untainter->new( %{$r->params} );
137 # We have something to edit
138 eval { $obj->update_from_cgi( $r => {
139 required => $required_cols,
140 ignore => $ignored_cols,
142 $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
147 $obj = $self->create_from_cgi( $r => {
148 required => $required_cols,
149 ignore => $ignored_cols,
155 return $obj, $fatal, $creating;
160 Deprecated method that calls do_delete or a given classes delete method, please
161 use do_delete instead
165 Unsuprisingly, this command causes a database record to be forever lost.
167 This method replaces the, now deprecated, delete method provided in prior versions
171 sub delete : Exported {
173 my ($sub) = (caller(1))[3];
174 # So subclasses can still send delete down ...
175 $sub =~ /^(.+)::([^:]+)$/;
176 if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
177 $self->SUPER::delete(@_);
179 warn "Maypole::Model::CDBI delete method is deprecated\n";
180 $self->do_delete(@_);
185 my ( $self, $r ) = @_;
186 # FIXME: handle fatal error with exception
187 $_->SUPER::delete for @{ $r->objects || [] };
189 $r->objects( [ $self->retrieve_all ] );
190 $r->{template} = "list";
196 Deprecated searching method - use do_search instead.
200 This action method searches for database records, it replaces
201 the, now deprecated, search method previously provided.
205 sub search : Exported {
207 my ($sub) = (caller(1))[3];
208 # So subclasses can still send search down ...
209 if ($sub =~ /^(.+)::([^:]+)$/) {
210 return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
211 $self->SUPER::search(@_) : $self->do_search(@_);
213 $self->SUPER::search(@_);
217 sub do_search : Exported {
218 my ( $self, $r ) = @_;
219 my %fields = map { $_ => 1 } $self->columns;
220 my $oper = "like"; # For now
221 my %params = %{ $r->{params} };
222 my %values = map { $_ => { $oper, $params{$_} } }
223 grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
226 $r->template("list");
227 if ( !%values ) { return $self->list($r) }
228 my $order = $self->order($r);
229 $self = $self->do_pager($r);
233 \%values, ( $order ? { order_by => $order } : () )
237 $r->{template_args}{search} = 1;
242 The C<list> method fills C<$r-E<gt>objects> with all of the
243 objects in the class. The results are paged using a pager.
247 sub list : Exported {
248 my ( $self, $r ) = @_;
249 my $order = $self->order($r);
250 $self = $self->do_pager($r);
252 $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
255 $r->objects( [ $self->retrieve_all ] );
259 ###############################################################################
262 =head1 Helper Methods
267 This class method is passed the name of a model class that represensts a table
268 and allows the master model class to do any set-up required.
273 my ( $self, $child ) = @_;
274 $child->autoupdate(1);
275 if ( my $col = $child->stringify_column ) {
276 $child->columns( Stringify => $col );
283 This method returns a list of has-many accessors. A brewery has many
284 beers, so C<BeerDB::Brewery> needs to return C<beers>.
289 my ( $self, $r ) = @_;
290 return keys %{ $self->meta_info('has_many') || {} };
296 Given an accessor name as a method, this function returns the class this accessor returns.
301 my ( $self, $r, $accessor ) = @_;
302 my $meta = $self->meta_info;
303 my @rels = keys %$meta;
306 $related = $meta->{$_}{$accessor};
309 return unless $related;
311 my $mapping = $related->{args}->{mapping};
312 if ( $mapping and @$mapping ) {
313 return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
316 return $related->{foreign_class};
322 $class->related_meta($col);
324 Returns the hash ref of relationship meta info for a given column.
329 my ($self,$r, $accssr) = @_;
330 $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
331 my $class_meta = $self->meta_info;
332 if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
334 { return $class_meta->{$rel_type}->{$accssr} };
339 =head2 stringify_column
341 Returns the name of the column to use when stringifying
346 sub stringify_column {
349 $class->columns("Stringify"),
350 ( grep { /^(name|title)$/i } $class->columns ),
351 ( grep { /(name|title)/i } $class->columns ),
352 ( grep { !/id$/i } $class->primary_columns ),
358 Sets the pager template argument ($r->{template_args}{pager})
359 to a Class::DBI::Pager object based on the rows_per_page
360 value set in the configuration of the application.
362 This pager is used via the pager macro in TT Templates, and
363 is also accessible via Mason.
368 my ( $self, $r ) = @_;
369 if ( my $rows = $r->config->rows_per_page ) {
370 return $r->{template_args}{pager} =
371 $self->pager( $rows, $r->query->{page} );
373 else { return $self }
379 Returns the SQL order syntax based on the order parameter passed
380 to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
382 $sql .= $self->order($r);
384 If the order column is not a column of this table,
385 or an order argument is not passed, then the return value is undefined.
387 Note: the returned value does not start with a space.
392 my ( $self, $r ) = @_;
393 my %ok_columns = map { $_ => 1 } $self->columns;
395 my $order = $q->{order};
396 return unless $order and $ok_columns{$order};
397 $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
403 This method is inherited from Maypole::Model::Base and calls setup_database,
404 which uses Class::DBI::Loader to create and load Class::DBI classes from
405 the given database schema.
409 =head2 setup_database
411 The $opts argument is a hashref of options. The "options" key is a hashref of
412 Database connection options . Other keys may be various Loader arguments or
413 flags. It has this form:
415 # DB connection options
416 options { AutoCommit => 1 , ... },
425 my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
426 $dsn ||= $config->dsn;
427 $u ||= $config->user;
428 $p ||= $config->pass;
429 $opts ||= $config->opts;
431 warn "No DSN set in config" unless $dsn;
432 $config->loader || $config->loader(
433 Class::DBI::Loader->new(
434 namespace => $namespace,
441 $config->{classes} = [ $config->{loader}->classes ];
442 $config->{tables} = [ $config->{loader}->tables ];
444 my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
445 warn( 'Loaded tables to classes: ' . join ', ', @table_class )
446 if $namespace->debug;
451 returns class for given table
456 my ( $self, $r, $table ) = @_;
457 return $r->config->loader->_table2class($table); # why not find_class ?
462 Returns 1 or more objects of the given class when provided with the request
468 my @pcs = $class->primary_columns;
471 @pks{@pcs}=(@{$r->{args}});
472 return $class->retrieve( %pks );
474 return $class->retrieve( $r->{args}->[0] );
483 Private method to return the class a column
484 belongs to that was inherited by an is_a relationship.
485 This should probably be public but need to think of API
490 my ($class, $col) = @_;
491 $class->_croak( "Need a column for _isa_class." ) unless $col;
493 my $isa = $class->meta_info("is_a") || {};
494 foreach ( keys %$isa ) {
495 $isaclass = $isa->{$_}->foreign_class;
496 return $isaclass if ($isaclass->find_column($col));
498 return; # col not in a is_a class
502 # Thanks to dave baird -- form builder for these private functions
506 warn "__column_info called by ", join (', ', caller), "\n";
507 my $dbh = $self->db_Main;
509 my $meta; # The info we are after
510 my ($catalog, $schema) = (undef, undef);
511 # Dave is suspicious this (above undefs) could
512 # break things if driver useses this info
514 my $original_metadata;
515 # '%' is a search pattern for columns - matches all columns
516 if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
517 $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
518 $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
520 $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
523 return $self->COLUMN_INFO;
526 sub _hash_type_meta {
527 my ($self, $sth) = @_;
529 while ( my $row = $sth->fetchrow_hashref ) {
530 my $colname = $row->{COLUMN_NAME} || $row->{column_name};
532 # required / nullable
533 $meta->{$colname}{nullable} = $row->{NULLABLE};
535 $meta->{$colname}{required} = ($row->{NULLABLE} && $row->{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;
652 foreach my $colname ( @$columns ) {
653 if ($class->_isa_class($colname)) {
654 $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
655 unless ($class->_isa_class($colname)->column_required);
658 unless ( $class->find_column($colname) ) {
659 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
662 $column_info->{required} = 1;
664 $class->COLUMN_INFO($column_info);
667 return [ grep ($column_info->{$_}{required}, keys %{$column_info}) ] ;
670 =head2 column_required
672 Returns true if a column is required
674 my $required = $class->column_required($column_name);
676 Columns can be required by the application but not the database, but not the other way around,
677 hence there is also a column_nullable method which will tell you if the column is nullable
678 within the database itself.
682 sub column_required {
683 my ($class, $colname) = @_;
684 $colname or $class->_croak( "Need a column for column_nullable" );
685 $class->_column_info() unless ref $class->COLUMN_INFO;
686 if ($class->_isa_class($colname)) {
687 return $class->_isa_class($colname)->column_required($colname);
689 unless ( $class->find_column($colname) ) {
690 # handle non-existant columns
691 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
694 return $class->COLUMN_INFO->{$colname}{required} || 0;
697 =head2 column_nullable
699 Returns true if a column can be NULL within the underlying database and false if not.
701 my $nullable = $class->column_nullable($column_name);
703 Any columns that are not nullable will automatically be specified as required, you can
704 also specify nullable columns as required within your application.
706 It is recomended you use column_required rather than column_nullable within your
707 application, this method is more useful if extending the model or handling your own
712 sub column_nullable {
714 my $colname = shift or $class->_croak( "Need a column for column_nullable" );
716 $class->_column_info() unless ref $class->COLUMN_INFO;
717 if ($class->_isa_class($colname)) {
718 return $class->_isa_class($colname)->column_nullable($colname);
720 unless ( $class->find_column($colname) ) {
721 # handle non-existant columns
722 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
725 return $class->COLUMN_INFO->{$colname}{nullable} || 0;
728 =head2 column_default
730 Returns default value for column or the empty string.
731 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
738 my $colname = shift or $class->_croak( "Need a column for column_default");
739 $class->_column_info() unless (ref $class->COLUMN_INFO);
740 if ($class->_isa_class($colname)) {
741 return $class->_isa_class($colname)->column_default($colname);
743 unless ( $class->find_column($colname) ) {
744 warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
748 return $class->COLUMN_INFO->{$colname}{default};
751 =head2 get_classmetadata
753 Gets class meta data *excluding cgi input* for the passed in class or the
754 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
755 templates when you need some metadata for a related class.
759 sub get_classmetadata {
760 my ($self, $class) = @_; # class is class we want data for
762 $class = ref $class || $class;
766 $res{colnames} = {$class->column_names};
767 $res{columns} = [$class->display_columns];
768 $res{list_columns} = [$class->list_columns];
769 $res{moniker} = $class->moniker;
770 $res{plural} = $class->plural_moniker;
771 $res{table} = $class->table;
772 $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;