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