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 =cut
  20
  21 use base qw(Maypole::Model::Base Class::DBI);
  22 use Maypole::Model::CDBI::AsForm;
  23 use CGI::Untaint::Maypole;
  24
  25 use Class::DBI::FromCGI;
  26 use Class::DBI::Loader;
  27 use Class::DBI::AbstractSearch;
  28 use Class::DBI::Plugin::RetrieveAll;
  29 use Class::DBI::Pager;
  30
  31 use Lingua::EN::Inflect::Number qw(to_PL);
  32 use attributes ();
  33
  34 ###############################################################################
  35 # Helper methods
  36
  37 =head1 Action Methods
  38
  39 Action methods are methods that are accessed through web (or other public) interface.
  40
  41 =item do_edit
  42
  43 If there is an object in C<$r-E<gt>objects>, then it should be edited
  44 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
  45 be created with those parameters, and put back into C<$r-E<gt>objects>.
  46 The template should be changed to C<view>, or C<edit> if there were any
  47 errors. A hash of errors will be passed to the template.
  48
  49 =cut
  50
  51 sub do_edit : Exported {
  52   my ($self, $r, $obj) = @_;
  53
  54   my $config   = $r->config;
  55   my $table    = $r->table;
  56
  57   # handle cancel button hits
  58   if ( $r->{params}->{cancel} ) {
  59     $r->template("list");
  60     $r->objects( [$self->retrieve_all] );
  61     return;
  62   }
  63
  64   my $required_cols = $config->{$table}->{required_cols} || [];
  65   my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
  66
  67   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
  68
  69   # handle errors, if none, proceed to view the newly created/updated object
  70   my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
  71
  72   if (%errors) {
  73     # Set it up as it was:
  74     $r->template_args->{cgi_params} = $r->params;
  75     $r->template_args->{errors}     = \%errors;
  76
  77     undef $obj if $creating;
  78     $r->template("edit");
  79   } else {
  80     $r->template("view");
  81   }
  82
  83   $r->objects( $obj ? [$obj] : []);
  84 }
  85
  86 # split out from do_edit to be reported by Mp::P::Trace
  87 sub _do_update_or_create {
  88   my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
  89
  90   my $fatal;
  91   my $creating = 0;
  92   my $h = CGI::Untaint::Maypole->new( %{$r->params} );
  93
  94   # update or create
  95   if ($obj) {
  96     # We have something to edit
  97     eval { $obj->update_from_cgi( $h => {
  98                                          required => $required_cols,
  99                                          ignore => $ignored_cols,
 100                                         } ) };
 101     $fatal = $@;
 102   } else {
 103     eval {
 104       $obj = $self->create_from_cgi( $h => {
 105                                             required => $required_cols,
 106                                             ignore => $ignored_cols,
 107                                            } )
 108     };
 109
 110     if ($fatal = $@) {
 111       warn "$fatal" if $r->debug;
 112     }
 113     $creating++;
 114   }
 115
 116   return $obj, $fatal, $creating;
 117 }
 118
 119
 120 =head2 do_delete
 121
 122 Unsuprisingly, this command causes a database record to be forever lost.
 123
 124 This method replaces the, now deprecated, delete method provided in prior versions
 125
 126 =cut
 127
 128 sub delete : Exported {
 129   my $self = shift;
 130   my ($sub) = (caller(1))[3];
 131   $sub =~ /^(.+)::([^:]+)$/;
 132   # So subclasses can still send search down ...
 133   return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
 134     $self->SUPER::search(@_) : $self->do_delete(@_);
 135 }
 136
 137 sub do_delete {
 138   my ( $self, $r ) = @_;
 139   $_->SUPER::delete for @{ $r->objects || [] };
 140   $r->objects( [ $self->retrieve_all ] );
 141   $r->{template} = "list";
 142   $self->list($r);
 143 }
 144
 145
 146 =head2 do_search
 147
 148 This action method searches for database records, it replaces
 149 the, now deprecated, search method previously provided.
 150
 151 =cut
 152
 153 sub search : 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 "search") ?
 159     $self->SUPER::search(@_) : $self->do_search(@_);
 160 }
 161
 162 sub do_search : Exported {
 163     my ( $self, $r ) = @_;
 164     my %fields = map { $_ => 1 } $self->columns;
 165     my $oper   = "like";                                # For now
 166     my %params = %{ $r->{params} };
 167     my %values = map { $_ => { $oper, $params{$_} } }
 168       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 169       keys %params;
 170
 171     $r->template("list");
 172     if ( !%values ) { return $self->list($r) }
 173     my $order = $self->order($r);
 174     $self = $self->do_pager($r);
 175     $r->objects(
 176         [
 177             $self->search_where(
 178                 \%values, ( $order ? { order_by => $order } : () )
 179             )
 180         ]
 181     );
 182     $r->{template_args}{search} = 1;
 183 }
 184
 185 =head2 list
 186
 187 The C<list> method fills C<$r-E<gt>objects> with all of the
 188 objects in the class. The results are paged using a pager.
 189
 190 =cut
 191
 192 sub list : Exported {
 193     my ( $self, $r ) = @_;
 194     my $order = $self->order($r);
 195     $self = $self->do_pager($r);
 196     if ($order) {
 197         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 198     }
 199     else {
 200         $r->objects( [ $self->retrieve_all ] );
 201     }
 202 }
 203
 204 #######################
 205 # _process_local_srch #
 206 #######################
 207
 208 # Makes the local part of the db search query
 209 # Puts search prams local to this table  in where array.
 210 # Returns a  where array ref and search criteria string.
 211 # This is factored out of do_search so sub classes can override this part
 212 sub _process_local_srch {
 213         my ($self, $hashed)  = @_;
 214         my %fields = map { $_ => 1 } $self->columns;
 215         my $moniker = $self->moniker;
 216         my %colnames    = $self->column_names;
 217         my $srch_crit = '';
 218         my ($oper, $wc);
 219         my @where = map {
 220                 # prelim
 221                 $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
 222                 $oper = $self->sql_search_oper($_);
 223                 $wc   = $oper =~ /LIKE/i ? '%':''; # match any substr
 224                 "$moniker.$_ $oper '$wc" .  $hashed->{$_} . "$wc'"; #the where clause
 225                 }
 226                 grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
 227                 keys %$hashed;
 228
 229         return (\@where, $srch_crit);
 230 }
 231
 232 #########################
 233 # _process_foreign_srch #
 234 #########################
 235
 236 # puts foreign search fields into select statement
 237 # changes  @where  by ref and return sel and srch_criteria string
 238 sub _process_foreign_srch {
 239         my ($self, $hashed, $sel, $where, $srch_crit) = @_;
 240         my %colnames    = $self->column_names;
 241         my $moniker     = $self->moniker;
 242         my %foreign;
 243         foreach (keys  %$hashed) {
 244                 $foreign{$_} =  delete $hashed->{$_} if ref $hashed->{$_};
 245         }
 246         my %accssr_class = %{$self->accessor_classes};
 247         while (my ( $accssr, $prms) =  each %foreign ) {
 248                 my $fclass = $accssr_class{$accssr};
 249                 my %fields = map { $_ => 1 } $fclass->columns;
 250                 my %colnames = $fclass->column_names;
 251                 my ($oper, $wc);
 252                 my @this_where =
 253                    # TODO make field name match in all cases in srch crit
 254                         map {
 255                                 # prelim
 256                                 $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
 257                                 $oper = $fclass->sql_search_oper($_);
 258                                 $wc   = $oper =~ /LIKE/i ? '%':'';
 259                              "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
 260                                 }
 261                         grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
 262                         keys %$prms;
 263
 264                 next unless @this_where;
 265                 $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
 266
 267                 # map relationships -- TODO use constraints in has_many and mhaves
 268                 # and make general
 269                 my $pk = $self->primary_column;
 270                 if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
 271                         unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
 272                                         "$accssr.owner_table = '" . $self->table ."'");
 273                 }
 274                 # for has_own, has_a  where foreign id is in self's table
 275                 elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
 276                         unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
 277                 }
 278                 push @$where, @this_where;
 279         }
 280         return ($sel, $srch_crit);
 281 }
 282
 283 ###############################################################################
 284 # Helper methods
 285
 286 =head1 Helper Methods
 287
 288
 289 =head2 adopt
 290
 291 This class method is passed the name of a model class that represensts a table
 292 and allows the master model class to do any set-up required.
 293
 294 =cut
 295
 296 sub adopt {
 297     my ( $self, $child ) = @_;
 298     $child->autoupdate(1);
 299     if ( my $col = $child->stringify_column ) {
 300         $child->columns( Stringify => $col );
 301     }
 302 }
 303
 304 =head2 is_class
 305
 306 Tell if action is a class method (See Maypole::Plugin::Menu)
 307
 308 =cut
 309
 310 sub is_class {
 311         my ( $self, $method, $attrs ) = @_;
 312         die "Usage: method must be passed as first arg" unless $method;
 313         $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
 314         return 1 if $attrs  =~ /\bClass\b/i;
 315         return 1 if $method =~ /^list$/;  # default class actions
 316         return 0;
 317 }
 318
 319 =head2 is_object
 320
 321 Tell if action is a object method (See Maypole::Plugin::Menu)
 322
 323 =cut
 324
 325 sub is_object {
 326         my ( $self, $method, $attrs ) = @_;
 327         die "Usage: method must be passed as first arg" unless $method;
 328         $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
 329         return 1 if $attrs  =~ /\bObject\b/i;
 330         return 1 if $method =~ /(^view$|^edit$|^delete$)/;  # default object actions
 331         return 0;
 332 }
 333
 334
 335 =head2 related
 336
 337 This method returns a list of has-many accessors. A brewery has many
 338 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 339
 340 =cut
 341
 342 sub related {
 343     my ( $self, $r ) = @_;
 344     return keys %{ $self->meta_info('has_many') || {} };
 345 }
 346
 347
 348 =head2 related_class
 349
 350 Given an accessor name as a method, this function returns the class this accessor returns.
 351
 352 =cut
 353
 354 sub related_class {
 355      my ( $self, $r, $accessor ) = @_;
 356      my $meta = $self->meta_info;
 357      my @rels = keys %$meta;
 358      my $related;
 359      foreach (@rels) {
 360          $related = $meta->{$_}{$accessor};
 361          last if $related;
 362      }
 363      return unless $related;
 364
 365      my $mapping = $related->{args}->{mapping};
 366      if ( $mapping and @$mapping ) {
 367        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 368      }
 369      else {
 370          return $related->{foreign_class};
 371      }
 372  }
 373
 374 =head2 isa_class
 375
 376 Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels)
 377
 378 =cut
 379
 380 sub isa_class {
 381   my ($class, $col) = @_;
 382   $class->_croak( "Need a column for isa_class." ) unless $col;
 383   my $isaclass;
 384   # class col is first found in is returned
 385   my $isa = $class->meta_info("is_a") || {};
 386   foreach ( keys %$isa ) {
 387     $isaclass = $isa->{$_}->foreign_class;
 388     return $isaclass if ($isaclass->find_column($col));
 389   }
 390   return 0;                     # col not in a is_a class
 391 }
 392
 393 =head2 accessor_classes
 394
 395 Returns hash ref of classes for accessors.
 396
 397 This is an attempt at a more efficient method than calling "related_class()"
 398 a bunch of times when you need it for many relations.
 399
 400 =cut
 401
 402 sub accessor_classes {
 403         my ($self, $class) = @_; # can pass a class arg to get accssor classes for
 404         $class ||= $self;
 405         my $meta = $class->meta_info;
 406         my %res;
 407         foreach my $rel (keys %$meta) {
 408                 my $rel_meta = $meta->{$rel};
 409                 %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
 410                                                    keys %$rel_meta );
 411         }
 412         return \%res;
 413
 414         # 2 liner to get class of accessor for $name
 415         #my $meta = $class->meta_info;
 416         #my ($isa) = map $_->foreign_class, grep defined,
 417         # map $meta->{$_}->{$name}, keys %$meta;
 418
 419 }
 420
 421
 422 =head2 stringify_column
 423
 424 =cut
 425
 426 sub stringify_column {
 427     my $class = shift;
 428     return (
 429         $class->columns("Stringify"),
 430         ( grep { /^(name|title)$/i } $class->columns ),
 431         ( grep { /(name|title)/i } $class->columns ),
 432         ( grep { !/id$/i } $class->primary_columns ),
 433     )[0];
 434 }
 435
 436 =head2 do_pager
 437
 438 =cut
 439
 440 sub do_pager {
 441     my ( $self, $r ) = @_;
 442     if ( my $rows = $r->config->rows_per_page ) {
 443         return $r->{template_args}{pager} =
 444           $self->pager( $rows, $r->query->{page} );
 445     }
 446     else { return $self }
 447 }
 448
 449
 450 =head2 order
 451
 452 =cut
 453
 454 sub order {
 455     my ( $self, $r ) = @_;
 456     my %ok_columns = map { $_ => 1 } $self->columns;
 457     my $q = $r->query;
 458     my $order = $q->{order};
 459     return unless $order and $ok_columns{$order};
 460     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 461     return $order;
 462 }
 463
 464 =head2 setup_database
 465
 466 =cut
 467
 468 sub setup_database {
 469     my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
 470     $dsn  ||= $config->dsn;
 471     $u    ||= $config->user;
 472     $p    ||= $config->pass;
 473     $opts ||= $config->opts;
 474     $config->dsn($dsn);
 475     warn "No DSN set in config" unless $dsn;
 476     $config->loader || $config->loader(
 477         Class::DBI::Loader->new(
 478             namespace => $namespace,
 479             dsn       => $dsn,
 480             user      => $u,
 481             password  => $p,
 482             %$opts,
 483         )
 484     );
 485     $config->{classes} = [ $config->{loader}->classes ];
 486     $config->{tables}  = [ $config->{loader}->tables ];
 487     warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
 488       if $namespace->debug;
 489 }
 490
 491 sub class_of {
 492     my ( $self, $r, $table ) = @_;
 493     return $r->config->loader->_table2class($table); # why not find_class ?
 494 }
 495
 496 sub fetch_objects {
 497     my ($class, $r)=@_;
 498     my @pcs = $class->primary_columns;
 499     if ( $#pcs ) {
 500     my %pks;
 501         @pks{@pcs}=(@{$r->{args}});
 502         return $class->retrieve( %pks );
 503     }
 504     return $class->retrieve( $r->{args}->[0] );
 505 }
 506
 507
 508 ###############################################################################
 509 # private / internal functions and classes
 510
 511 sub _column_info {
 512         my $class =  shift;
 513         $class = ref $class || $class;
 514         no strict 'refs';
 515         return ${$class . '::COLUMN_INFO'};
 516 }
 517
 518 1;