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