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 = $r->{config}{ $r->{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( $h => {
 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( $h => {
 148                                             required => $required_cols,
 149                                             ignore => $ignored_cols,
 150                                            } );
 151         };
 152         $fatal = $@;
 153         $creating++;
 154   }
 155
 156   return $obj, $fatal, $creating;
 157 }
 158
 159
 160 =head2 delete
 161
 162 Deprecated method that calls do_delete or a given classes delete method, please
 163 use do_delete instead
 164
 165 =head2 do_delete
 166
 167 Unsuprisingly, this command causes a database record to be forever lost.
 168
 169 This method replaces the, now deprecated, delete method provided in prior versions
 170
 171 =cut
 172
 173 sub delete : Exported {
 174   my $self = shift;
 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(@_);
 180   } else {
 181     warn "Maypole::Model::CDBI delete method is deprecated\n";
 182     $self->do_delete(@_);
 183   }
 184 }
 185
 186 sub do_delete {
 187   my ( $self, $r ) = @_;
 188   # FIXME: handle fatal error with exception
 189   $_->SUPER::delete for @{ $r->objects || [] };
 190 #  $self->dbi_commit;
 191   $r->objects( [ $self->retrieve_all ] );
 192   $r->{template} = "list";
 193   $self->list($r);
 194 }
 195
 196 =head2 search
 197
 198 Deprecated searching method - use do_search instead.
 199
 200 =head2 do_search
 201
 202 This action method searches for database records, it replaces
 203 the, now deprecated, search method previously provided.
 204
 205 =cut
 206
 207 sub search : Exported {
 208   my $self = shift;
 209   my ($sub) = (caller(1))[3];
 210   $sub =~ /^(.+)::([^:]+)$/;
 211   # So subclasses can still send search down ...
 212   return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
 213     $self->SUPER::search(@_) : $self->do_search(@_);
 214 }
 215
 216 sub do_search : Exported {
 217     my ( $self, $r ) = @_;
 218     my %fields = map { $_ => 1 } $self->columns;
 219     my $oper   = "like";                                # For now
 220     my %params = %{ $r->{params} };
 221     my %values = map { $_ => { $oper, $params{$_} } }
 222       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 223       keys %params;
 224
 225     $r->template("list");
 226     if ( !%values ) { return $self->list($r) }
 227     my $order = $self->order($r);
 228     $self = $self->do_pager($r);
 229     $r->objects(
 230         [
 231             $self->search_where(
 232                 \%values, ( $order ? { order_by => $order } : () )
 233             )
 234         ]
 235     );
 236     $r->{template_args}{search} = 1;
 237 }
 238
 239 =head2 list
 240
 241 The C<list> method fills C<$r-E<gt>objects> with all of the
 242 objects in the class. The results are paged using a pager.
 243
 244 =cut
 245
 246 sub list : Exported {
 247     my ( $self, $r ) = @_;
 248     my $order = $self->order($r);
 249     $self = $self->do_pager($r);
 250     if ($order) {
 251         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 252     }
 253     else {
 254         $r->objects( [ $self->retrieve_all ] );
 255     }
 256 }
 257
 258 ###############################################################################
 259 # Helper methods
 260
 261 =head1 Helper Methods
 262
 263
 264 =head2 adopt
 265
 266 This class method is passed the name of a model class that represensts a table
 267 and allows the master model class to do any set-up required.
 268
 269 =cut
 270
 271 sub adopt {
 272     my ( $self, $child ) = @_;
 273     $child->autoupdate(1);
 274     if ( my $col = $child->stringify_column ) {
 275         $child->columns( Stringify => $col );
 276     }
 277 }
 278
 279
 280 =head2 related
 281
 282 This method returns a list of has-many accessors. A brewery has many
 283 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 284
 285 =cut
 286
 287 sub related {
 288     my ( $self, $r ) = @_;
 289     return keys %{ $self->meta_info('has_many') || {} };
 290 }
 291
 292
 293 =head2 related_class
 294
 295 Given an accessor name as a method, this function returns the class this accessor returns.
 296
 297 =cut
 298
 299 sub related_class {
 300      my ( $self, $r, $accessor ) = @_;
 301      my $meta = $self->meta_info;
 302      my @rels = keys %$meta;
 303      my $related;
 304      foreach (@rels) {
 305          $related = $meta->{$_}{$accessor};
 306          last if $related;
 307      }
 308      return unless $related;
 309
 310      my $mapping = $related->{args}->{mapping};
 311      if ( $mapping and @$mapping ) {
 312        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 313      }
 314      else {
 315          return $related->{foreign_class};
 316      }
 317  }
 318
 319 =head2 related_meta
 320
 321   $class->related_meta($col);
 322
 323 Given a column  associated with a relationship it will return the relatation
 324 ship type and the meta info for the relationship on the column.
 325
 326 =cut
 327
 328 sub related_meta {
 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} }
 333         keys %$class_meta)
 334     { return  $rel_type, $class_meta->{$rel_type}->{$accssr} };
 335 }
 336
 337
 338
 339 =head2 stringify_column
 340
 341    Returns the name of the column to use when stringifying
 342    and object.
 343
 344 =cut
 345
 346 sub stringify_column {
 347     my $class = shift;
 348     return (
 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 ),
 353     )[0];
 354 }
 355
 356 =head2 do_pager
 357
 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.
 361
 362    This pager is used via the pager macro in TT Templates, and
 363    is also accessible via Mason.
 364
 365 =cut
 366
 367 sub do_pager {
 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} );
 372     }
 373     else { return $self }
 374 }
 375
 376
 377 =head2 order
 378
 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'.
 381
 382     $sql .= $self->order($r);
 383
 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.
 386
 387     Note: the returned value does not start with a space.
 388
 389 =cut
 390
 391 sub order {
 392     my ( $self, $r ) = @_;
 393     my %ok_columns = map { $_ => 1 } $self->columns;
 394     my $q = $r->query;
 395     my $order = $q->{order};
 396     return unless $order and $ok_columns{$order};
 397     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 398     return $order;
 399 }
 400
 401 =head2 setup
 402
 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.
 406
 407 =cut
 408
 409 =head2 setup_database
 410
 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:
 414  {
 415    # DB connection options
 416    options { AutoCommit => 1 , ... },
 417    # Loader args
 418    relationships => 1,
 419    ...
 420  }
 421
 422 =cut
 423
 424 sub setup_database {
 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;
 430     $config->dsn($dsn);
 431     warn "No DSN set in config" unless $dsn;
 432     $config->loader || $config->loader(
 433         Class::DBI::Loader->new(
 434             namespace => $namespace,
 435             dsn       => $dsn,
 436             user      => $u,
 437             password  => $p,
 438             %$opts,
 439         )
 440     );
 441     $config->{classes} = [ $config->{loader}->classes ];
 442     $config->{tables}  = [ $config->{loader}->tables ];
 443
 444     my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
 445     warn( 'Loaded tables to classes: ' . join ', ', @table_class )
 446       if $namespace->debug;
 447 }
 448
 449 =head2 class_of
 450
 451   returns class for given table
 452
 453 =cut
 454
 455 sub class_of {
 456     my ( $self, $r, $table ) = @_;
 457     return $r->config->loader->_table2class($table); # why not find_class ?
 458 }
 459
 460 =head2 fetch_objects
 461
 462 Returns 1 or more objects of the given class when provided with the request
 463
 464 =cut
 465
 466 sub fetch_objects {
 467     my ($class, $r)=@_;
 468     my @pcs = $class->primary_columns;
 469     if ( $#pcs ) {
 470     my %pks;
 471         @pks{@pcs}=(@{$r->{args}});
 472         return $class->retrieve( %pks );
 473     }
 474     return $class->retrieve( $r->{args}->[0] );
 475 }
 476
 477
 478
 479
 480
 481 =head2 _isa_class
 482
 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
 486
 487 =cut
 488
 489 sub _isa_class {
 490     my ($class, $col) = @_;
 491     $class->_croak( "Need a column for _isa_class." ) unless $col;
 492     my $isaclass;
 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));
 497     }
 498     return; # col not in a is_a class
 499 }
 500
 501
 502
 503 # Thanks to dave baird --  form builder for these private functions
 504 sub _column_info {
 505     my $self = shift;
 506         my $dbh = $self->db_Main;
 507         return $self->COLUMN_INFO if ref $self->COLUMN_INFO;
 508
 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
 513
 514         # '%' is a search pattern for columns - matches all columns
 515     if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) )
 516     {
 517         $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
 518         $self->COLUMN_INFO( $self->_hash_type_meta( $sth ) );
 519 #       use Data::Dumper; warn "col info for typed is " . Dumper($self->COLUMN_INFO);
 520     }
 521     else
 522     {
 523         $self->COLUMN_INFO( $self->_hash_typeless_meta( ) );
 524 #               use Data::Dumper; warn "col info TYPELESS is " . Dumper($self->COLUMN_INFO);
 525     }
 526         return $self->COLUMN_INFO;
 527 }
 528
 529 sub _hash_type_meta
 530 {
 531     my ($self, $sth) = @_;
 532         my $meta;
 533     while ( my $row = $sth->fetchrow_hashref )
 534
 535     {
 536         my ($col_meta, $col_name);
 537
 538         foreach my $key ( keys %$row)
 539         {
 540             my $value = $row->{$key} || $row->{ uc $key };
 541             $col_meta->{$key} = $value;
 542             $col_name = $row->{COLUMN_NAME} || $row->{column_name};
 543         }
 544
 545         $meta->{$col_name} =  $col_meta;
 546     }
 547         return $meta;
 548 }
 549
 550 # typeless db e.g. sqlite
 551 sub _hash_typeless_meta
 552 {
 553     my ( $self ) = @_;
 554
 555     $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
 556         unless $self->can( 'sql_fb_meta_dummy' );
 557
 558     my $sth = $self->sql_fb_meta_dummy;
 559
 560     $sth->execute or die "Error executing column info: "  . $sth->errstr;;
 561
 562     # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
 563     my $cols  = $sth->{NAME};
 564     my $types = $sth->{TYPE};
 565     # my $sizes = $sth->{PRECISION};    # empty
 566     # my $nulls = $sth->{NULLABLE};     # empty
 567
 568     # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
 569     $sth->finish;
 570
 571     my $order = 0;
 572     my $meta;
 573     foreach my $col ( @$cols )
 574     {
 575         my $col_meta;
 576
 577         $col_meta->{NULLABLE}    = 1;
 578
 579         # in my limited testing, the columns are returned in the same order as they were defined in the schema
 580         $col_meta->{ORDINAL_POSITION} = $order++;
 581
 582         # type_name is taken literally from the schema, but is not actually used by sqlite,
 583         # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
 584                 my $type = shift( @$types );
 585                 $type =~ /(\w+)\((\w+)\)/;
 586         $col_meta->{type} = $type;
 587                 $col_meta->{TYPE_NAME} = $1;
 588                 my $size = $2;
 589                 $col_meta->{COLUMN_SIZE} = $size if $type =~ /(CHAR|INT)/i;
 590                 $meta->{$col} = $col_meta;
 591     }
 592         return $meta;
 593 }
 594
 595
 596
 597 =head2 column_type
 598
 599     my $type = $class->column_type('column_name');
 600
 601 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 602 For now, it returns "BOOL" for tinyints.
 603
 604 TODO :: TEST with enums and postgres
 605
 606 =cut
 607 sub column_type {
 608     my $class = shift;
 609     my $col = shift or die "Need a column for column_type";
 610         my $info = $class->_column_info->{$col} ||
 611                            eval { $class->_isa_class($col)->_column_info($col) } ||
 612                            return '';
 613
 614     my $type = $info->{mysql_type_name} || $info->{type};
 615         unless ($type) {
 616                 $type =  $info->{TYPE_NAME};
 617                 if ($info->{COLUMN_SIZE}) { $type .= "($info->{COLUMN_SIZE})"; }
 618     }
 619         # Bool if tinyint
 620         if ($type and $type =~ /^tinyint/i and $info->{COLUMN_SIZE} == 1) {
 621                         $type = 'BOOL';
 622         }
 623         return $type;
 624 }
 625
 626 =head2 column_nullable
 627
 628 Returns true if a column can be NULL and false if not.
 629
 630 =cut
 631
 632 sub column_nullable {
 633     my $class = shift;
 634     my $col = shift or $class->_croak( "Need a column for column_nullable" );
 635         my $info = $class->_column_info->{$col} ||
 636                            eval { $class->_isa_class($col)->_column_info($col) } ||
 637                            return 1;
 638     return $info->{NULLABLE};
 639 }
 640
 641 =head2 column_default
 642
 643 Returns default value for column or the empyty string.
 644 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 645 have '' returned.
 646
 647 =cut
 648
 649 sub column_default {
 650     my $class = shift;
 651     my $col = shift or $class->_croak( "Need a column for column_default");
 652         #return unless $class->find_column($col); # not a real column
 653
 654         my $info = $class->_column_info->{$col} ||
 655                            eval { $class->_isa_class($col)->_column_info($col) } ||
 656                            return '';
 657
 658     my $def = $info->{COLUMN_DEF};
 659     $def = '' unless defined $def;
 660
 661     # exclude defaults we don't want to display-- may need some additions here
 662     if ( $class->column_type($col)  =~ /^BOOL/i ) {
 663             $def = $def ? 1 : 0; # allow 0 or 1 for bool cols
 664     }
 665     else {
 666         $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
 667
 668     }
 669     return $def;
 670 }
 671
 672
 673
 674 =head2 get_classmetadata
 675
 676 Gets class meta data *excluding cgi input* for the passed in class or the
 677 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
 678 templates when you need some metadata for a related class.
 679
 680 =cut
 681
 682 sub get_classmetadata {
 683     my ($self, $class) = @_; # class is class we want data for
 684     $class ||= $self;
 685     $class = ref $class || $class;
 686
 687     my %res;
 688     $res{name}          = $class;
 689     $res{colnames}      = {$class->column_names};
 690     $res{columns}       = [$class->display_columns];
 691     $res{list_columns}  = [$class->list_columns];
 692     $res{moniker}       = $class->moniker;
 693     $res{plural}        = $class->plural_moniker;
 694     $res{table}         = $class->table;
 695     \%res;
 696 }
 697
 698
 699 1;