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