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   # So subclasses can still send search down ...
 243   if ($sub =~ /^(.+)::([^:]+)$/) {
 244     return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
 245       $self->SUPER::search(@_) : $self->do_search(@_);
 246   } else {
 247     $self->SUPER::search(@_);
 248   }
 249 }
 250
 251 sub do_search : Exported {
 252     my ( $self, $r ) = @_;
 253     my %fields = map { $_ => 1 } $self->columns;
 254     my $oper   = "like";                                # For now
 255     my %params = %{ $r->{params} };
 256     my %values = map { $_ => { $oper, $params{$_} } }
 257       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 258       keys %params;
 259
 260     $r->template("list");
 261     if ( !%values ) { return $self->list($r) }
 262     my $order = $self->order($r);
 263     $self = $self->do_pager($r);
 264     $r->objects(
 265         [
 266             $self->search_where(
 267                 \%values, ( $order ? { order_by => $order } : () )
 268             )
 269         ]
 270     );
 271     $r->{template_args}{search} = 1;
 272 }
 273
 274 =head2 list
 275
 276 The C<list> method fills C<$r-E<gt>objects> with all of the
 277 objects in the class. The results are paged using a pager.
 278
 279 =cut
 280
 281 sub list : Exported {
 282     my ( $self, $r ) = @_;
 283     my $order = $self->order($r);
 284     $self = $self->do_pager($r);
 285     if ($order) {
 286         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 287     }
 288     else {
 289         $r->objects( [ $self->retrieve_all ] );
 290     }
 291 }
 292
 293 ###############################################################################
 294 # Helper methods
 295
 296 =head1 Helper Methods
 297
 298
 299 =head2 adopt
 300
 301 This class method is passed the name of a model class that represensts a table
 302 and allows the master model class to do any set-up required.
 303
 304 =cut
 305
 306 sub adopt {
 307     my ( $self, $child ) = @_;
 308     $child->autoupdate(1);
 309     if ( my $col = $child->stringify_column ) {
 310         $child->columns( Stringify => $col );
 311     }
 312 }
 313
 314
 315 =head2 related
 316
 317 This method returns a list of has-many accessors. A brewery has many
 318 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 319
 320 =cut
 321
 322 sub related {
 323     my ( $self, $r ) = @_;
 324     return keys %{ $self->meta_info('has_many') || {} };
 325 }
 326
 327
 328 =head2 related_class
 329
 330 Given an accessor name as a method, this function returns the class this accessor returns.
 331
 332 =cut
 333
 334 sub related_class {
 335      my ( $self, $r, $accessor ) = @_;
 336      my $meta = $self->meta_info;
 337      my @rels = keys %$meta;
 338      my $related;
 339      foreach (@rels) {
 340          $related = $meta->{$_}{$accessor};
 341          last if $related;
 342      }
 343      return unless $related;
 344
 345      my $mapping = $related->{args}->{mapping};
 346      if ( $mapping and @$mapping ) {
 347        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 348      }
 349      else {
 350          return $related->{foreign_class};
 351      }
 352  }
 353
 354 =head2 related_meta
 355
 356   $class->related_meta($col);
 357
 358 Returns the hash ref of relationship meta info for a given column.
 359
 360 =cut
 361
 362 sub related_meta {
 363     my ($self,$r, $accssr) = @_;
 364     $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
 365     my $class_meta = $self->meta_info;
 366     if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 367         keys %$class_meta)
 368     { return  $class_meta->{$rel_type}->{$accssr} };
 369 }
 370
 371
 372
 373 =head2 stringify_column
 374
 375    Returns the name of the column to use when stringifying
 376    and object.
 377
 378 =cut
 379
 380 sub stringify_column {
 381     my $class = shift;
 382     return (
 383         $class->columns("Stringify"),
 384         ( grep { /^(name|title)$/i } $class->columns ),
 385         ( grep { /(name|title)/i } $class->columns ),
 386         ( grep { !/id$/i } $class->primary_columns ),
 387     )[0];
 388 }
 389
 390 =head2 do_pager
 391
 392    Sets the pager template argument ($r->{template_args}{pager})
 393    to a Class::DBI::Pager object based on the rows_per_page
 394    value set in the configuration of the application.
 395
 396    This pager is used via the pager macro in TT Templates, and
 397    is also accessible via Mason.
 398
 399 =cut
 400
 401 sub do_pager {
 402     my ( $self, $r ) = @_;
 403     if ( my $rows = $r->config->rows_per_page ) {
 404         return $r->{template_args}{pager} =
 405           $self->pager( $rows, $r->query->{page} );
 406     }
 407     else { return $self }
 408 }
 409
 410
 411 =head2 order
 412
 413     Returns the SQL order syntax based on the order parameter passed
 414     to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
 415
 416     $sql .= $self->order($r);
 417
 418     If the order column is not a column of this table,
 419     or an order argument is not passed, then the return value is undefined.
 420
 421     Note: the returned value does not start with a space.
 422
 423 =cut
 424
 425 sub order {
 426     my ( $self, $r ) = @_;
 427     my %ok_columns = map { $_ => 1 } $self->columns;
 428     my $q = $r->query;
 429     my $order = $q->{order};
 430     return unless $order and $ok_columns{$order};
 431     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 432     return $order;
 433 }
 434
 435 =head2 setup
 436
 437   This method is inherited from Maypole::Model::Base and calls setup_database,
 438   which uses Class::DBI::Loader to create and load Class::DBI classes from
 439   the given database schema.
 440
 441 =cut
 442
 443 =head2 setup_database
 444
 445 The $opts argument is a hashref of options.  The "options" key is a hashref of
 446 Database connection options . Other keys may be various Loader arguments or
 447 flags.  It has this form:
 448  {
 449    # DB connection options
 450    options { AutoCommit => 1 , ... },
 451    # Loader args
 452    relationships => 1,
 453    ...
 454  }
 455
 456 =cut
 457
 458 sub setup_database {
 459     my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
 460     $dsn  ||= $config->dsn;
 461     $u    ||= $config->user;
 462     $p    ||= $config->pass;
 463     $opts ||= $config->opts;
 464     $config->dsn($dsn);
 465     warn "No DSN set in config" unless $dsn;
 466     $config->loader || $config->loader(
 467         Class::DBI::Loader->new(
 468             namespace => $namespace,
 469             dsn       => $dsn,
 470             user      => $u,
 471             password  => $p,
 472             %$opts,
 473         )
 474     );
 475     $config->{classes} = [ $config->{loader}->classes ];
 476     $config->{tables}  = [ $config->{loader}->tables ];
 477
 478     my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
 479     warn( 'Loaded tables to classes: ' . join ', ', @table_class )
 480       if $namespace->debug;
 481 }
 482
 483 =head2 class_of
 484
 485   returns class for given table
 486
 487 =cut
 488
 489 sub class_of {
 490     my ( $self, $r, $table ) = @_;
 491     return $r->config->loader->_table2class($table); # why not find_class ?
 492 }
 493
 494 =head2 fetch_objects
 495
 496 Returns 1 or more objects of the given class when provided with the request
 497
 498 =cut
 499
 500 sub fetch_objects {
 501     my ($class, $r)=@_;
 502     my @pcs = $class->primary_columns;
 503     if ( $#pcs ) {
 504     my %pks;
 505         @pks{@pcs}=(@{$r->{args}});
 506         return $class->retrieve( %pks );
 507     }
 508     return $class->retrieve( $r->{args}->[0] );
 509 }
 510
 511
 512
 513
 514
 515 =head2 _isa_class
 516
 517 Private method to return the class a column
 518 belongs to that was inherited by an is_a relationship.
 519 This should probably be public but need to think of API
 520
 521 =cut
 522
 523 sub _isa_class {
 524     my ($class, $col) = @_;
 525     $class->_croak( "Need a column for _isa_class." ) unless $col;
 526     my $isaclass;
 527     my $isa = $class->meta_info("is_a") || {};
 528     foreach ( keys %$isa ) {
 529         $isaclass = $isa->{$_}->foreign_class;
 530         return $isaclass if ($isaclass->find_column($col));
 531     }
 532     return; # col not in a is_a class
 533 }
 534
 535
 536
 537 # Thanks to dave baird --  form builder for these private functions
 538 sub _column_info {
 539     my $self = shift;
 540         my $dbh = $self->db_Main;
 541         return $self->COLUMN_INFO if ref $self->COLUMN_INFO;
 542
 543         my $meta;  # The info we are after
 544         my ($catalog, $schema) = (undef, undef);
 545         # Dave is suspicious this (above undefs) could
 546         # break things if driver useses this info
 547
 548         # '%' is a search pattern for columns - matches all columns
 549     if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) )
 550     {
 551         $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
 552         $self->COLUMN_INFO( $self->_hash_type_meta( $sth ) );
 553 #       use Data::Dumper; warn "col info for typed is " . Dumper($self->COLUMN_INFO);
 554     }
 555     else
 556     {
 557         $self->COLUMN_INFO( $self->_hash_typeless_meta( ) );
 558 #               use Data::Dumper; warn "col info TYPELESS is " . Dumper($self->COLUMN_INFO);
 559     }
 560         return $self->COLUMN_INFO;
 561 }
 562
 563 sub _hash_type_meta
 564 {
 565     my ($self, $sth) = @_;
 566         my $meta;
 567     while ( my $row = $sth->fetchrow_hashref )
 568
 569     {
 570         my ($col_meta, $col_name);
 571
 572         foreach my $key ( keys %$row)
 573         {
 574             my $value = $row->{$key} || $row->{ uc $key };
 575             $col_meta->{$key} = $value;
 576             $col_name = $row->{COLUMN_NAME} || $row->{column_name};
 577         }
 578
 579         $meta->{$col_name} =  $col_meta;
 580     }
 581         return $meta;
 582 }
 583
 584 # typeless db e.g. sqlite
 585 sub _hash_typeless_meta
 586 {
 587     my ( $self ) = @_;
 588
 589     $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
 590         unless $self->can( 'sql_fb_meta_dummy' );
 591
 592     my $sth = $self->sql_fb_meta_dummy;
 593
 594     $sth->execute or die "Error executing column info: "  . $sth->errstr;;
 595
 596     # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
 597     my $cols  = $sth->{NAME};
 598     my $types = $sth->{TYPE};
 599     # my $sizes = $sth->{PRECISION};    # empty
 600     # my $nulls = $sth->{NULLABLE};     # empty
 601
 602     # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
 603     $sth->finish;
 604
 605     my $order = 0;
 606     my $meta;
 607     foreach my $col ( @$cols )
 608     {
 609         my $col_meta;
 610
 611         $col_meta->{NULLABLE}    = 1;
 612
 613         # in my limited testing, the columns are returned in the same order as they were defined in the schema
 614         $col_meta->{ORDINAL_POSITION} = $order++;
 615
 616         # type_name is taken literally from the schema, but is not actually used by sqlite,
 617         # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
 618                 my $type = shift( @$types );
 619                 $type =~ /(\w+)\((\w+)\)/;
 620         $col_meta->{type} = $type;
 621                 $col_meta->{TYPE_NAME} = $1;
 622                 my $size = $2;
 623                 $col_meta->{COLUMN_SIZE} = $size if $type =~ /(CHAR|INT)/i;
 624                 $meta->{$col} = $col_meta;
 625     }
 626         return $meta;
 627 }
 628
 629
 630
 631 =head2 column_type
 632
 633     my $type = $class->column_type('column_name');
 634
 635 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 636 For now, it returns "BOOL" for tinyints.
 637
 638 TODO :: TEST with enums and postgres
 639
 640 =cut
 641 sub column_type {
 642     my $class = shift;
 643     my $col = shift or die "Need a column for column_type";
 644         my $info = $class->_column_info->{$col} ||
 645                            eval { $class->_isa_class($col)->_column_info($col) } ||
 646                            return '';
 647
 648     my $type = $info->{mysql_type_name} || $info->{type};
 649         unless ($type) {
 650                 $type =  $info->{TYPE_NAME};
 651                 if ($info->{COLUMN_SIZE}) { $type .= "($info->{COLUMN_SIZE})"; }
 652     }
 653         # Bool if tinyint
 654         if ($type and $type =~ /^tinyint/i and $info->{COLUMN_SIZE} == 1) {
 655                         $type = 'BOOL';
 656         }
 657         return $type;
 658 }
 659
 660 =head2 column_nullable
 661
 662 Returns true if a column can be NULL and false if not.
 663
 664 =cut
 665
 666 sub column_nullable {
 667     my $class = shift;
 668     my $col = shift or $class->_croak( "Need a column for column_nullable" );
 669         my $info = $class->_column_info->{$col} ||
 670                            eval { $class->_isa_class($col)->_column_info($col) } ||
 671                            return 1;
 672     return $info->{NULLABLE};
 673 }
 674
 675 =head2 column_default
 676
 677 Returns default value for column or the empyty string.
 678 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 679 have '' returned.
 680
 681 =cut
 682
 683 sub column_default {
 684     my $class = shift;
 685     my $col = shift or $class->_croak( "Need a column for column_default");
 686         #return unless $class->find_column($col); # not a real column
 687
 688         my $info = $class->_column_info->{$col} ||
 689                            eval { $class->_isa_class($col)->_column_info($col) } ||
 690                            return '';
 691
 692     my $def = $info->{COLUMN_DEF};
 693     $def = '' unless defined $def; # is this good?
 694         return $def;
 695 }
 696
 697
 698
 699
 700
 701 =head2 get_classmetadata
 702
 703 Gets class meta data *excluding cgi input* for the passed in class or the
 704 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
 705 templates when you need some metadata for a related class.
 706
 707 =cut
 708
 709 sub get_classmetadata {
 710     my ($self, $class) = @_; # class is class we want data for
 711     $class ||= $self;
 712     $class = ref $class || $class;
 713
 714     my %res;
 715     $res{name}          = $class;
 716     $res{colnames}      = {$class->column_names};
 717     $res{columns}       = [$class->display_columns];
 718     $res{list_columns}  = [$class->list_columns];
 719     $res{moniker}       = $class->moniker;
 720     $res{plural}        = $class->plural_moniker;
 721     $res{table}         = $class->table;
 722     \%res;
 723 }
 724
 725
 726 1;