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 Maypole::Model::CDBI::AsForm;
  28
  29 use Maypole::Model::CDBI::FromCGI;
  30 use CGI::Untaint::Maypole;
  31 our $Untainter = 'CGI::Untaint::Maypole';
  32
  33 # or if you like bugs
  34
  35 #use Class::DBI::FromCGI;
  36 #use CGI::Untaint;
  37 #our $Untainter = 'CGI::Untaint';
  38
  39 use Class::DBI::Plugin::Type;
  40 use Class::DBI::Loader;
  41 use Class::DBI::AbstractSearch;
  42 use Class::DBI::Plugin::RetrieveAll;
  43 use Class::DBI::Pager;
  44
  45 use Lingua::EN::Inflect::Number qw(to_PL);
  46 use attributes ();
  47
  48 use Data::Dumper;
  49
  50 ###############################################################################
  51 # Helper methods
  52
  53 =head1 Action Methods
  54
  55 Action methods are methods that are accessed through web (or other public) interface.
  56
  57 =head2 do_edit
  58
  59 If there is an object in C<$r-E<gt>objects>, then it should be edited
  60 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
  61 be created with those parameters, and put back into C<$r-E<gt>objects>.
  62 The template should be changed to C<view>, or C<edit> if there were any
  63 errors. A hash of errors will be passed to the template.
  64
  65 =cut
  66
  67 sub do_edit : Exported {
  68   my ($self, $r, $obj) = @_;
  69
  70   my $config   = $r->config;
  71   my $table    = $r->table;
  72
  73   # handle cancel button hit
  74   if ( $r->{params}->{cancel} ) {
  75     $r->template("list");
  76     $r->objects( [$self->retrieve_all] );
  77     return;
  78   }
  79
  80   my $required_cols = $config->{$table}->{required_cols} || [];
  81   my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
  82
  83   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
  84
  85   # handle errors, if none, proceed to view the newly created/updated object
  86   my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
  87
  88   if (%errors) {
  89     # Set it up as it was:
  90     $r->template_args->{cgi_params} = $r->params;
  91
  92     #
  93     # replace user unfriendly error messages with something nicer
  94
  95     foreach (@{$config->{$table}->{required_cols}}) {
  96       next unless ($errors{$_});
  97       my $key = $_;
  98       s/_/ /g;
  99       $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
 100       $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
 101       delete $errors{$key};
 102     }
 103
 104     foreach (keys %errors) {
 105       my $key = $_;
 106       s/_/ /g;
 107       $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
 108       $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
 109     }
 110
 111     undef $obj if $creating;
 112
 113     die "do_update failed with error : $fatal" if ($fatal);
 114     $r->template("edit");
 115   } else {
 116     $r->template("view");
 117   }
 118
 119
 120
 121   $r->objects( $obj ? [$obj] : []);
 122 }
 123
 124 # split out from do_edit to be reported by Mp::P::Trace
 125 sub _do_update_or_create {
 126   my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
 127
 128   my $fatal;
 129   my $creating = 0;
 130
 131   my $h = $Untainter->new( %{$r->params} );
 132
 133   # update or create
 134   if ($obj) {
 135                 # 1: Required fields for update are different than create. Its only required
 136           #              if it is in the parameters
 137
 138 #               my @real_required = ();
 139 #               my %required = map { $_ => 1 } @$required_cols;
 140 #    foreach (keys %{$r->params}) {
 141 #                       push @real_required, $_ if $required{$_};
 142 #         }
 143
 144     # We have something to edit
 145     eval { $obj->update_from_cgi( $h => {
 146                                          required => $required_cols,
 147                                          ignore => $ignored_cols,
 148                                         } );
 149            $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
 150          };
 151     $fatal = $@;
 152   } else {
 153         eval {
 154         $obj = $self->create_from_cgi( $h => {
 155                                             required => $required_cols,
 156                                             ignore => $ignored_cols,
 157                                            } );
 158         };
 159         $fatal = $@;
 160         $creating++;
 161   }
 162
 163   return $obj, $fatal, $creating;
 164 }
 165
 166
 167 =head2 delete
 168
 169 Deprecated method that calls do_delete or a given classes delete method, please
 170 use do_delete instead
 171
 172 =head2 do_delete
 173
 174 Unsuprisingly, this command causes a database record to be forever lost.
 175
 176 This method replaces the, now deprecated, delete method provided in prior versions
 177
 178 =cut
 179
 180 sub delete : Exported {
 181   my $self = shift;
 182   my ($sub) = (caller(1))[3];
 183   # So subclasses can still send delete down ...
 184   $sub =~ /^(.+)::([^:]+)$/;
 185   if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
 186     $self->SUPER::delete(@_);
 187   } else {
 188     warn "Maypole::Model::CDBI delete method is deprecated\n";
 189     $self->do_delete(@_);
 190   }
 191 }
 192
 193 sub do_delete {
 194   my ( $self, $r ) = @_;
 195   # FIXME: handle fatal error with exception
 196   $_->SUPER::delete for @{ $r->objects || [] };
 197 #  $self->dbi_commit;
 198   $r->objects( [ $self->retrieve_all ] );
 199   $r->{template} = "list";
 200   $self->list($r);
 201 }
 202
 203 =head2 search
 204
 205 Deprecated searching method - use do_search instead.
 206
 207 =head2 do_search
 208
 209 This action method searches for database records, it replaces
 210 the, now deprecated, search method previously provided.
 211
 212 =cut
 213
 214 sub search : Exported {
 215   my $self = shift;
 216   my ($sub) = (caller(1))[3];
 217   $sub =~ /^(.+)::([^:]+)$/;
 218   # So subclasses can still send search down ...
 219   return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
 220     $self->SUPER::search(@_) : $self->do_search(@_);
 221 }
 222
 223 sub do_search : Exported {
 224     my ( $self, $r ) = @_;
 225     my %fields = map { $_ => 1 } $self->columns;
 226     my $oper   = "like";                                # For now
 227     my %params = %{ $r->{params} };
 228     my %values = map { $_ => { $oper, $params{$_} } }
 229       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 230       keys %params;
 231
 232     $r->template("list");
 233     if ( !%values ) { return $self->list($r) }
 234     my $order = $self->order($r);
 235     $self = $self->do_pager($r);
 236     $r->objects(
 237         [
 238             $self->search_where(
 239                 \%values, ( $order ? { order_by => $order } : () )
 240             )
 241         ]
 242     );
 243     $r->{template_args}{search} = 1;
 244 }
 245
 246 =head2 list
 247
 248 The C<list> method fills C<$r-E<gt>objects> with all of the
 249 objects in the class. The results are paged using a pager.
 250
 251 =cut
 252
 253 sub list : Exported {
 254     my ( $self, $r ) = @_;
 255     my $order = $self->order($r);
 256     $self = $self->do_pager($r);
 257     if ($order) {
 258         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 259     }
 260     else {
 261         $r->objects( [ $self->retrieve_all ] );
 262     }
 263 }
 264
 265 #######################
 266 # _process_local_srch #
 267 #######################
 268
 269 # Makes the local part of the db search query
 270 # Puts search prams local to this table  in where array.
 271 # Returns a  where array ref and search criteria string.
 272 # This is factored out of do_search so sub classes can override this part
 273 sub _process_local_srch {
 274         my ($self, $hashed)  = @_;
 275         my %fields = map { $_ => 1 } $self->columns;
 276         my $moniker = $self->moniker;
 277         my %colnames    = $self->column_names;
 278         my $srch_crit = '';
 279         my ($oper, $wc);
 280         my @where = map {
 281                 # prelim
 282                 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
 283                 $oper = $self->sql_search_oper($_);
 284                 $wc   = $oper =~ /LIKE/i ? '%':''; # match any substr
 285                 "$moniker.$_ $oper '$wc" .  $hashed->{$_} . "$wc'"; #the where clause
 286                 }
 287                 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
 288                 keys %$hashed;
 289
 290         return (\@where, $srch_crit);
 291 }
 292
 293 #########################
 294 # _process_foreign_srch #
 295 #########################
 296
 297 # puts foreign search fields into select statement
 298 # changes  @where  by ref and return sel and srch_criteria string
 299 sub _process_foreign_srch {
 300         my ($self, $hashed, $sel, $where, $srch_crit) = @_;
 301         my %colnames    = $self->column_names;
 302         my $moniker     = $self->moniker;
 303         my %foreign;
 304         foreach (keys  %$hashed) {
 305                 $foreign{$_} =  delete $hashed->{$_} if ref $hashed->{$_};
 306         }
 307         my %accssr_class = %{$self->accessor_classes};
 308         while (my ( $accssr, $prms) =  each %foreign ) {
 309                 my $fclass = $accssr_class{$accssr};
 310                 my %fields = map { $_ => 1 } $fclass->columns;
 311                 my %colnames = $fclass->column_names;
 312                 my ($oper, $wc);
 313                 my @this_where =
 314                    # TODO make field name match in all cases in srch crit
 315                         map {
 316                                 # prelim
 317                                 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
 318                                 $oper = $fclass->sql_search_oper($_);
 319                                 $wc   = $oper =~ /LIKE/i ? '%':'';
 320                              "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
 321                                 }
 322                         grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
 323                         keys %$prms;
 324
 325                 next unless @this_where;
 326                 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
 327
 328                 # map relationships -- TODO use constraints in has_many and mhaves
 329                 # and make general
 330                 my $pk = $self->primary_column;
 331                 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
 332                         unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
 333                                         "$accssr.owner_table = '" . $self->table ."'");
 334                 }
 335                 # for has_own, has_a  where foreign id is in self's table
 336                 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
 337                         unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
 338                 }
 339                 push @$where, @this_where;
 340         }
 341         return ($sel, $srch_crit);
 342 }
 343
 344 ###############################################################################
 345 # Helper methods
 346
 347 =head1 Helper Methods
 348
 349
 350 =head2 adopt
 351
 352 This class method is passed the name of a model class that represensts a table
 353 and allows the master model class to do any set-up required.
 354
 355 =cut
 356
 357 sub adopt {
 358     my ( $self, $child ) = @_;
 359     $child->autoupdate(1);
 360     if ( my $col = $child->stringify_column ) {
 361         $child->columns( Stringify => $col );
 362     }
 363 }
 364
 365 =head2 is_class
 366
 367 Tell if action is a class method (See Maypole::Plugin::Menu)
 368
 369 =cut
 370
 371 sub is_class {
 372         my ( $self, $method, $attrs ) = @_;
 373         die "Usage: method must be passed as first arg" unless $method;
 374         $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
 375         return 1 if $attrs  =~ /\bClass\b/i;
 376         return 1 if $method =~ /^list$/;  # default class actions
 377         return 0;
 378 }
 379
 380 =head2 is_object
 381
 382 Tell if action is a object method (See Maypole::Plugin::Menu)
 383
 384 =cut
 385
 386 sub is_object {
 387         my ( $self, $method, $attrs ) = @_;
 388         die "Usage: method must be passed as first arg" unless $method;
 389         $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
 390         return 1 if $attrs  =~ /\bObject\b/i;
 391         return 1 if $method =~ /(^view$|^edit$|^delete$)/;  # default object actions
 392         return 0;
 393 }
 394
 395
 396 =head2 related
 397
 398 This method returns a list of has-many accessors. A brewery has many
 399 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 400
 401 =cut
 402
 403 sub related {
 404     my ( $self, $r ) = @_;
 405     return keys %{ $self->meta_info('has_many') || {} };
 406 }
 407
 408
 409 =head2 related_class
 410
 411 Given an accessor name as a method, this function returns the class this accessor returns.
 412
 413 =cut
 414
 415 sub related_class {
 416      my ( $self, $r, $accessor ) = @_;
 417      my $meta = $self->meta_info;
 418      my @rels = keys %$meta;
 419      my $related;
 420      foreach (@rels) {
 421          $related = $meta->{$_}{$accessor};
 422          last if $related;
 423      }
 424      return unless $related;
 425
 426      my $mapping = $related->{args}->{mapping};
 427      if ( $mapping and @$mapping ) {
 428        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 429      }
 430      else {
 431          return $related->{foreign_class};
 432      }
 433  }
 434
 435 =head2 related_meta
 436
 437   $class->related_meta($col);
 438
 439 Given a column  associated with a relationship it will return the relatation
 440 ship type and the meta info for the relationship on the column.
 441
 442 =cut
 443
 444 sub related_meta {
 445     my ($self,$r, $accssr) = @_;
 446     $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
 447     my $class_meta = $self->meta_info;
 448     if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 449         keys %$class_meta)
 450     { return  $rel_type, $class_meta->{$rel_type}->{$accssr} };
 451 }
 452
 453
 454 =head2 isa_class
 455
 456 Returns class of a column inherited by is_a.
 457
 458 =cut
 459
 460 # Maybe put this in IsA?
 461 sub isa_class {
 462   my ($class, $col) = @_;
 463   $class->_croak( "Need a column for isa_class." ) unless $col;
 464   my $isaclass;
 465   my $isa = $class->meta_info("is_a") || {};
 466   foreach ( keys %$isa ) {
 467     $isaclass = $isa->{$_}->foreign_class;
 468     return $isaclass if ($isaclass->find_column($col));
 469   }
 470   return 0;                     # col not in a is_a class
 471 }
 472
 473 =head2 accessor_classes
 474
 475 Returns hash ref of classes for accessors.
 476
 477 This is an attempt at a more efficient method than calling "related_class()"
 478 a bunch of times when you need it for many relations.
 479 It may be good to call at startup and store in a global config.
 480
 481 =cut
 482
 483 sub accessor_classes {
 484         my ($self, $class) = @_; # can pass a class arg to get accssor classes for
 485         $class ||= $self;
 486         my $meta = $class->meta_info;
 487         my %res;
 488         foreach my $rel (keys %$meta) {
 489                 my $rel_meta = $meta->{$rel};
 490                 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
 491                                                    keys %$rel_meta );
 492         }
 493         return \%res;
 494
 495         # 2 liner to get class of accessor for $name
 496         #my $meta = $class->meta_info;
 497         #my ($isa) = map $_->foreign_class, grep defined,
 498         # map $meta->{$_}->{$name}, keys %$meta;
 499
 500 }
 501
 502
 503 =head2 stringify_column
 504
 505    Returns the name of the column to use when stringifying
 506    and object.
 507
 508 =cut
 509
 510 sub stringify_column {
 511     my $class = shift;
 512     return (
 513         $class->columns("Stringify"),
 514         ( grep { /^(name|title)$/i } $class->columns ),
 515         ( grep { /(name|title)/i } $class->columns ),
 516         ( grep { !/id$/i } $class->primary_columns ),
 517     )[0];
 518 }
 519
 520 =head2 do_pager
 521
 522    Sets the pager template argument ($r->{template_args}{pager})
 523    to a Class::DBI::Pager object based on the rows_per_page
 524    value set in the configuration of the application.
 525
 526    This pager is used via the pager macro in TT Templates, and
 527    is also accessible via Mason.
 528
 529 =cut
 530
 531 sub do_pager {
 532     my ( $self, $r ) = @_;
 533     if ( my $rows = $r->config->rows_per_page ) {
 534         return $r->{template_args}{pager} =
 535           $self->pager( $rows, $r->query->{page} );
 536     }
 537     else { return $self }
 538 }
 539
 540
 541 =head2 order
 542
 543     Returns the SQL order syntax based on the order parameter passed
 544     to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
 545
 546     $sql .= $self->order($r);
 547
 548     If the order column is not a column of this table,
 549     or an order argument is not passed, then the return value is undefined.
 550
 551     Note: the returned value does not start with a space.
 552
 553 =cut
 554
 555 sub order {
 556     my ( $self, $r ) = @_;
 557     my %ok_columns = map { $_ => 1 } $self->columns;
 558     my $q = $r->query;
 559     my $order = $q->{order};
 560     return unless $order and $ok_columns{$order};
 561     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 562     return $order;
 563 }
 564
 565 =head2 setup
 566
 567   This method is inherited from Maypole::Model::Base and calls setup_database,
 568   which uses Class::DBI::Loader to create and load Class::DBI classes from
 569   the given database schema.
 570
 571 =cut
 572
 573 =head2 setup_database
 574
 575 The $opts argument is a hashref of options.  The "options" key is a hashref of
 576 Database connection options . Other keys may be various Loader arguments or
 577 flags.  It has this form:
 578  {
 579    # DB connection options
 580    options { AutoCommit => 1 , ... },
 581    # Loader args
 582    relationships => 1,
 583    ...
 584  }
 585
 586 =cut
 587
 588 sub setup_database {
 589     my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
 590     $dsn  ||= $config->dsn;
 591     $u    ||= $config->user;
 592     $p    ||= $config->pass;
 593     $opts ||= $config->opts;
 594     $config->dsn($dsn);
 595     warn "No DSN set in config" unless $dsn;
 596     $config->loader || $config->loader(
 597         Class::DBI::Loader->new(
 598             namespace => $namespace,
 599             dsn       => $dsn,
 600             user      => $u,
 601             password  => $p,
 602             %$opts,
 603         )
 604     );
 605     $config->{classes} = [ $config->{loader}->classes ];
 606     $config->{tables}  = [ $config->{loader}->tables ];
 607
 608     my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
 609     warn( 'Loaded tables to classes: ' . join ', ', @table_class )
 610       if $namespace->debug;
 611 }
 612
 613 =head2 class_of
 614
 615   returns class for given table
 616
 617 =cut
 618
 619 sub class_of {
 620     my ( $self, $r, $table ) = @_;
 621     return $r->config->loader->_table2class($table); # why not find_class ?
 622 }
 623
 624 =head2 fetch_objects
 625
 626 Returns 1 or more objects of the given class when provided with the request
 627
 628 =cut
 629
 630 sub fetch_objects {
 631     my ($class, $r)=@_;
 632     my @pcs = $class->primary_columns;
 633     if ( $#pcs ) {
 634     my %pks;
 635         @pks{@pcs}=(@{$r->{args}});
 636         return $class->retrieve( %pks );
 637     }
 638     return $class->retrieve( $r->{args}->[0] );
 639 }
 640
 641
 642 ###############################################################################
 643 # private / internal functions and classes
 644
 645 sub _column_info {
 646         my $class =  shift;
 647         $class = ref $class || $class;
 648         no strict 'refs';
 649         return ${$class . '::COLUMN_INFO'};
 650 }
 651
 652 1;