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