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