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