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