lib/Maypole/Model/CDBI.pm

   1 package Maypole::Model::CDBI;
   2 use strict;
   3
   4 =head1 NAME
   5
   6 Maypole::Model::CDBI - Model class based on Class::DBI
   7
   8 =head1 DESCRIPTION
   9
  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
  13 modules.
  14
  15 It implements a base set of methods required for a Maypole Data Model.
  16
  17 It inherits accessor and helper methods from L<Maypole::Model::Base>.
  18
  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.
  23
  24 =cut
  25
  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);
  33 use attributes ();
  34
  35 use Maypole::Model::CDBI::AsForm;
  36 use Maypole::Model::CDBI::FromCGI;
  37 use CGI::Untaint::Maypole;
  38
  39 =head2 Untainter
  40
  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
  43
  44 =cut
  45 sub Untainter { 'CGI::Untaint::Maypole' };
  46
  47 # or if you like bugs
  48
  49 #use Class::DBI::FromCGI;
  50 #use CGI::Untaint;
  51 #sub Untainter { 'CGI::Untaint' };
  52
  53
  54 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
  55
  56 =head1 Action Methods
  57
  58 Action methods are methods that are accessed through web (or other public) interface.
  59
  60 =head2 do_edit
  61
  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.
  67
  68 =cut
  69
  70 sub do_edit : Exported {
  71   my ($self, $r, $obj) = @_;
  72
  73   my $config   = $r->config;
  74   my $table    = $r->table;
  75
  76   # handle cancel button hit
  77   if ( $r->{params}->{cancel} ) {
  78     $r->template("list");
  79     $r->objects( [$self->retrieve_all] );
  80     return;
  81   }
  82
  83   my $required_cols = $config->{$table}{required_cols} || [];
  84   my $ignored_cols  = $config->{$table}{ignore_cols} || [];
  85
  86   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
  87
  88   # handle errors, if none, proceed to view the newly created/updated object
  89   my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
  90
  91   if (%errors) {
  92     # Set it up as it was:
  93     $r->template_args->{cgi_params} = $r->params;
  94
  95     # replace user unfriendly error messages with something nicer
  96
  97     foreach (@{$config->{$table}->{required_cols}}) {
  98       next unless ($errors{$_});
  99       my $key = $_;
 100       s/_/ /g;
 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};
 104     }
 105
 106     foreach (keys %errors) {
 107       my $key = $_;
 108       s/_/ /g;
 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';
 111     }
 112
 113     undef $obj if $creating;
 114
 115     die "do_update failed with error : $fatal" if ($fatal);
 116     $r->template("edit");
 117   } else {
 118     $r->template("view");
 119   }
 120
 121
 122
 123   $r->objects( $obj ? [$obj] : []);
 124 }
 125
 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) = @_;
 129
 130   my $fatal;
 131   my $creating = 0;
 132
 133   my $h = $self->Untainter->new( %{$r->params} );
 134
 135   # update or create
 136   if ($obj) {
 137     # We have something to edit
 138     eval { $obj->update_from_cgi( $r => {
 139                                          required => $required_cols,
 140                                          ignore => $ignored_cols,
 141                                         });
 142            $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
 143          };
 144     $fatal = $@;
 145   } else {
 146         eval {
 147         $obj = $self->create_from_cgi( $r => {
 148                                             required => $required_cols,
 149                                             ignore => $ignored_cols,
 150                                            } );
 151         };
 152         $fatal = $@;
 153         $creating++;
 154   }
 155   return $obj, $fatal, $creating;
 156 }
 157
 158
 159 # split out from do_edit to be reported by Mp::P::Trace
 160 #sub _do_update_or_create {
 161 #  my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
 162 #
 163 #  my $fatal;
 164 #  my $creating = 0;
 165 #
 166 #  my $h = $self->Untainter->new( %{$r->params} );
 167 #
 168 #  # update or create
 169 #  if ($obj) {
 170 #    # We have something to edit
 171 #    eval { $obj->update_from_cgi( $h => {
 172 #                                        required => $required_cols,
 173 #                                        ignore => $ignored_cols,
 174 #                                       } );
 175 #          $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
 176 #        };
 177 #    $fatal = $@;
 178 #  } else {
 179 #       eval {
 180 #       $obj = $self->create_from_cgi( $h => {
 181 #                                           required => $required_cols,
 182 #                                           ignore => $ignored_cols,
 183 #                                          } );
 184 #       };
 185 #       $fatal = $@;
 186 #       $creating++;
 187 #  }
 188 #
 189 #  return $obj, $fatal, $creating;
 190 #}
 191
 192 =head2 delete
 193
 194 Deprecated method that calls do_delete or a given classes delete method, please
 195 use do_delete instead
 196
 197 =head2 do_delete
 198
 199 Unsuprisingly, this command causes a database record to be forever lost.
 200
 201 This method replaces the, now deprecated, delete method provided in prior versions
 202
 203 =cut
 204
 205 sub delete : Exported {
 206   my $self = shift;
 207   my ($sub) = (caller(1))[3];
 208   # So subclasses can still send delete down ...
 209   $sub =~ /^(.+)::([^:]+)$/;
 210   if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
 211     $self->SUPER::delete(@_);
 212   } else {
 213     warn "Maypole::Model::CDBI delete method is deprecated\n";
 214     $self->do_delete(@_);
 215   }
 216 }
 217
 218 sub do_delete {
 219   my ( $self, $r ) = @_;
 220   # FIXME: handle fatal error with exception
 221   $_->SUPER::delete for @{ $r->objects || [] };
 222 #  $self->dbi_commit;
 223   $r->objects( [ $self->retrieve_all ] );
 224   $r->{template} = "list";
 225   $self->list($r);
 226 }
 227
 228 =head2 search
 229
 230 Deprecated searching method - use do_search instead.
 231
 232 =head2 do_search
 233
 234 This action method searches for database records, it replaces
 235 the, now deprecated, search method previously provided.
 236
 237 =cut
 238
 239 sub search : Exported {
 240   my $self = shift;
 241   my ($sub) = (caller(1))[3];
 242   $sub =~ /^(.+)::([^:]+)$/;
 243   # So subclasses can still send search down ...
 244   return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
 245     $self->SUPER::search(@_) : $self->do_search(@_);
 246 }
 247
 248 sub do_search : Exported {
 249     my ( $self, $r ) = @_;
 250     my %fields = map { $_ => 1 } $self->columns;
 251     my $oper   = "like";                                # For now
 252     my %params = %{ $r->{params} };
 253     my %values = map { $_ => { $oper, $params{$_} } }
 254       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 255       keys %params;
 256
 257     $r->template("list");
 258     if ( !%values ) { return $self->list($r) }
 259     my $order = $self->order($r);
 260     $self = $self->do_pager($r);
 261     $r->objects(
 262         [
 263             $self->search_where(
 264                 \%values, ( $order ? { order_by => $order } : () )
 265             )
 266         ]
 267     );
 268     $r->{template_args}{search} = 1;
 269 }
 270
 271 =head2 list
 272
 273 The C<list> method fills C<$r-E<gt>objects> with all of the
 274 objects in the class. The results are paged using a pager.
 275
 276 =cut
 277
 278 sub list : Exported {
 279     my ( $self, $r ) = @_;
 280     my $order = $self->order($r);
 281     $self = $self->do_pager($r);
 282     if ($order) {
 283         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 284     }
 285     else {
 286         $r->objects( [ $self->retrieve_all ] );
 287     }
 288 }
 289
 290 ###############################################################################
 291 # Helper methods
 292
 293 =head1 Helper Methods
 294
 295
 296 =head2 adopt
 297
 298 This class method is passed the name of a model class that represensts a table
 299 and allows the master model class to do any set-up required.
 300
 301 =cut
 302
 303 sub adopt {
 304     my ( $self, $child ) = @_;
 305     $child->autoupdate(1);
 306     if ( my $col = $child->stringify_column ) {
 307         $child->columns( Stringify => $col );
 308     }
 309 }
 310
 311
 312 =head2 related
 313
 314 This method returns a list of has-many accessors. A brewery has many
 315 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 316
 317 =cut
 318
 319 sub related {
 320     my ( $self, $r ) = @_;
 321     return keys %{ $self->meta_info('has_many') || {} };
 322 }
 323
 324
 325 =head2 related_class
 326
 327 Given an accessor name as a method, this function returns the class this accessor returns.
 328
 329 =cut
 330
 331 sub related_class {
 332      my ( $self, $r, $accessor ) = @_;
 333      my $meta = $self->meta_info;
 334      my @rels = keys %$meta;
 335      my $related;
 336      foreach (@rels) {
 337          $related = $meta->{$_}{$accessor};
 338          last if $related;
 339      }
 340      return unless $related;
 341
 342      my $mapping = $related->{args}->{mapping};
 343      if ( $mapping and @$mapping ) {
 344        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 345      }
 346      else {
 347          return $related->{foreign_class};
 348      }
 349  }
 350
 351 =head2 related_meta
 352
 353   $class->related_meta($col);
 354
 355 Returns the hash ref of relationship meta info for a given column.
 356
 357 =cut
 358
 359 sub related_meta {
 360     my ($self,$r, $accssr) = @_;
 361     $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
 362     my $class_meta = $self->meta_info;
 363     if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 364         keys %$class_meta)
 365     { return  $class_meta->{$rel_type}->{$accssr} };
 366 }
 367
 368
 369
 370 =head2 stringify_column
 371
 372    Returns the name of the column to use when stringifying
 373    and object.
 374
 375 =cut
 376
 377 sub stringify_column {
 378     my $class = shift;
 379     return (
 380         $class->columns("Stringify"),
 381         ( grep { /^(name|title)$/i } $class->columns ),
 382         ( grep { /(name|title)/i } $class->columns ),
 383         ( grep { !/id$/i } $class->primary_columns ),
 384     )[0];
 385 }
 386
 387 =head2 do_pager
 388
 389    Sets the pager template argument ($r->{template_args}{pager})
 390    to a Class::DBI::Pager object based on the rows_per_page
 391    value set in the configuration of the application.
 392
 393    This pager is used via the pager macro in TT Templates, and
 394    is also accessible via Mason.
 395
 396 =cut
 397
 398 sub do_pager {
 399     my ( $self, $r ) = @_;
 400     if ( my $rows = $r->config->rows_per_page ) {
 401         return $r->{template_args}{pager} =
 402           $self->pager( $rows, $r->query->{page} );
 403     }
 404     else { return $self }
 405 }
 406
 407
 408 =head2 order
 409
 410     Returns the SQL order syntax based on the order parameter passed
 411     to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
 412
 413     $sql .= $self->order($r);
 414
 415     If the order column is not a column of this table,
 416     or an order argument is not passed, then the return value is undefined.
 417
 418     Note: the returned value does not start with a space.
 419
 420 =cut
 421
 422 sub order {
 423     my ( $self, $r ) = @_;
 424     my %ok_columns = map { $_ => 1 } $self->columns;
 425     my $q = $r->query;
 426     my $order = $q->{order};
 427     return unless $order and $ok_columns{$order};
 428     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 429     return $order;
 430 }
 431
 432 =head2 setup
 433
 434   This method is inherited from Maypole::Model::Base and calls setup_database,
 435   which uses Class::DBI::Loader to create and load Class::DBI classes from
 436   the given database schema.
 437
 438 =cut
 439
 440 =head2 setup_database
 441
 442 The $opts argument is a hashref of options.  The "options" key is a hashref of
 443 Database connection options . Other keys may be various Loader arguments or
 444 flags.  It has this form:
 445  {
 446    # DB connection options
 447    options { AutoCommit => 1 , ... },
 448    # Loader args
 449    relationships => 1,
 450    ...
 451  }
 452
 453 =cut
 454
 455 sub setup_database {
 456     my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
 457     $dsn  ||= $config->dsn;
 458     $u    ||= $config->user;
 459     $p    ||= $config->pass;
 460     $opts ||= $config->opts;
 461     $config->dsn($dsn);
 462     warn "No DSN set in config" unless $dsn;
 463     $config->loader || $config->loader(
 464         Class::DBI::Loader->new(
 465             namespace => $namespace,
 466             dsn       => $dsn,
 467             user      => $u,
 468             password  => $p,
 469             %$opts,
 470         )
 471     );
 472     $config->{classes} = [ $config->{loader}->classes ];
 473     $config->{tables}  = [ $config->{loader}->tables ];
 474
 475     my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
 476     warn( 'Loaded tables to classes: ' . join ', ', @table_class )
 477       if $namespace->debug;
 478 }
 479
 480 =head2 class_of
 481
 482   returns class for given table
 483
 484 =cut
 485
 486 sub class_of {
 487     my ( $self, $r, $table ) = @_;
 488     return $r->config->loader->_table2class($table); # why not find_class ?
 489 }
 490
 491 =head2 fetch_objects
 492
 493 Returns 1 or more objects of the given class when provided with the request
 494
 495 =cut
 496
 497 sub fetch_objects {
 498     my ($class, $r)=@_;
 499     my @pcs = $class->primary_columns;
 500     if ( $#pcs ) {
 501     my %pks;
 502         @pks{@pcs}=(@{$r->{args}});
 503         return $class->retrieve( %pks );
 504     }
 505     return $class->retrieve( $r->{args}->[0] );
 506 }
 507
 508
 509
 510
 511
 512 =head2 _isa_class
 513
 514 Private method to return the class a column
 515 belongs to that was inherited by an is_a relationship.
 516 This should probably be public but need to think of API
 517
 518 =cut
 519
 520 sub _isa_class {
 521     my ($class, $col) = @_;
 522     $class->_croak( "Need a column for _isa_class." ) unless $col;
 523     my $isaclass;
 524     my $isa = $class->meta_info("is_a") || {};
 525     foreach ( keys %$isa ) {
 526         $isaclass = $isa->{$_}->foreign_class;
 527         return $isaclass if ($isaclass->find_column($col));
 528     }
 529     return; # col not in a is_a class
 530 }
 531
 532
 533
 534 # Thanks to dave baird --  form builder for these private functions
 535 sub _column_info {
 536     my $self = shift;
 537         my $dbh = $self->db_Main;
 538         return $self->COLUMN_INFO if ref $self->COLUMN_INFO;
 539
 540         my $meta;  # The info we are after
 541         my ($catalog, $schema) = (undef, undef);
 542         # Dave is suspicious this (above undefs) could
 543         # break things if driver useses this info
 544
 545         # '%' is a search pattern for columns - matches all columns
 546     if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) )
 547     {
 548         $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
 549         $self->COLUMN_INFO( $self->_hash_type_meta( $sth ) );
 550 #       use Data::Dumper; warn "col info for typed is " . Dumper($self->COLUMN_INFO);
 551     }
 552     else
 553     {
 554         $self->COLUMN_INFO( $self->_hash_typeless_meta( ) );
 555 #               use Data::Dumper; warn "col info TYPELESS is " . Dumper($self->COLUMN_INFO);
 556     }
 557         return $self->COLUMN_INFO;
 558 }
 559
 560 sub _hash_type_meta
 561 {
 562     my ($self, $sth) = @_;
 563         my $meta;
 564     while ( my $row = $sth->fetchrow_hashref )
 565
 566     {
 567         my ($col_meta, $col_name);
 568
 569         foreach my $key ( keys %$row)
 570         {
 571             my $value = $row->{$key} || $row->{ uc $key };
 572             $col_meta->{$key} = $value;
 573             $col_name = $row->{COLUMN_NAME} || $row->{column_name};
 574         }
 575
 576         $meta->{$col_name} =  $col_meta;
 577     }
 578         return $meta;
 579 }
 580
 581 # typeless db e.g. sqlite
 582 sub _hash_typeless_meta
 583 {
 584     my ( $self ) = @_;
 585
 586     $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
 587         unless $self->can( 'sql_fb_meta_dummy' );
 588
 589     my $sth = $self->sql_fb_meta_dummy;
 590
 591     $sth->execute or die "Error executing column info: "  . $sth->errstr;;
 592
 593     # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
 594     my $cols  = $sth->{NAME};
 595     my $types = $sth->{TYPE};
 596     # my $sizes = $sth->{PRECISION};    # empty
 597     # my $nulls = $sth->{NULLABLE};     # empty
 598
 599     # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
 600     $sth->finish;
 601
 602     my $order = 0;
 603     my $meta;
 604     foreach my $col ( @$cols )
 605     {
 606         my $col_meta;
 607
 608         $col_meta->{NULLABLE}    = 1;
 609
 610         # in my limited testing, the columns are returned in the same order as they were defined in the schema
 611         $col_meta->{ORDINAL_POSITION} = $order++;
 612
 613         # type_name is taken literally from the schema, but is not actually used by sqlite,
 614         # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
 615                 my $type = shift( @$types );
 616                 $type =~ /(\w+)\((\w+)\)/;
 617         $col_meta->{type} = $type;
 618                 $col_meta->{TYPE_NAME} = $1;
 619                 my $size = $2;
 620                 $col_meta->{COLUMN_SIZE} = $size if $type =~ /(CHAR|INT)/i;
 621                 $meta->{$col} = $col_meta;
 622     }
 623         return $meta;
 624 }
 625
 626
 627
 628 =head2 column_type
 629
 630     my $type = $class->column_type('column_name');
 631
 632 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 633 For now, it returns "BOOL" for tinyints.
 634
 635 TODO :: TEST with enums and postgres
 636
 637 =cut
 638 sub column_type {
 639     my $class = shift;
 640     my $col = shift or die "Need a column for column_type";
 641         my $info = $class->_column_info->{$col} ||
 642                            eval { $class->_isa_class($col)->_column_info($col) } ||
 643                            return '';
 644
 645     my $type = $info->{mysql_type_name} || $info->{type};
 646         unless ($type) {
 647                 $type =  $info->{TYPE_NAME};
 648                 if ($info->{COLUMN_SIZE}) { $type .= "($info->{COLUMN_SIZE})"; }
 649     }
 650         # Bool if tinyint
 651         if ($type and $type =~ /^tinyint/i and $info->{COLUMN_SIZE} == 1) {
 652                         $type = 'BOOL';
 653         }
 654         return $type;
 655 }
 656
 657 =head2 column_nullable
 658
 659 Returns true if a column can be NULL and false if not.
 660
 661 =cut
 662
 663 sub column_nullable {
 664     my $class = shift;
 665     my $col = shift or $class->_croak( "Need a column for column_nullable" );
 666         my $info = $class->_column_info->{$col} ||
 667                            eval { $class->_isa_class($col)->_column_info($col) } ||
 668                            return 1;
 669     return $info->{NULLABLE};
 670 }
 671
 672 =head2 column_default
 673
 674 Returns default value for column or the empyty string.
 675 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 676 have '' returned.
 677
 678 =cut
 679
 680 sub column_default {
 681     my $class = shift;
 682     my $col = shift or $class->_croak( "Need a column for column_default");
 683         #return unless $class->find_column($col); # not a real column
 684
 685         my $info = $class->_column_info->{$col} ||
 686                            eval { $class->_isa_class($col)->_column_info($col) } ||
 687                            return '';
 688
 689     my $def = $info->{COLUMN_DEF};
 690     $def = '' unless defined $def; # is this good?
 691         return $def;
 692 }
 693
 694
 695
 696
 697
 698 =head2 get_classmetadata
 699
 700 Gets class meta data *excluding cgi input* for the passed in class or the
 701 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
 702 templates when you need some metadata for a related class.
 703
 704 =cut
 705
 706 sub get_classmetadata {
 707     my ($self, $class) = @_; # class is class we want data for
 708     $class ||= $self;
 709     $class = ref $class || $class;
 710
 711     my %res;
 712     $res{name}          = $class;
 713     $res{colnames}      = {$class->column_names};
 714     $res{columns}       = [$class->display_columns];
 715     $res{list_columns}  = [$class->list_columns];
 716     $res{moniker}       = $class->moniker;
 717     $res{plural}        = $class->plural_moniker;
 718     $res{table}         = $class->table;
 719     \%res;
 720 }
 721
 722
 723 1;