lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Scalar::Util ();
   9 use Scope::Guard;
  10
  11 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Row - Basic row methods
  16
  17 =head1 SYNOPSIS
  18
  19 =head1 DESCRIPTION
  20
  21 This class is responsible for defining and doing basic operations on rows
  22 derived from L<DBIx::Class::ResultSource> objects.
  23
  24 =head1 METHODS
  25
  26 =head2 new
  27
  28   my $obj = My::Class->new($attrs);
  29
  30 Creates a new row object from column => value mappings passed as a hash ref
  31
  32 Passing an object, or an arrayref of objects as a value will call
  33 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
  34 passed a hashref or an arrayref of hashrefs as the value, these will
  35 be turned into objects via new_related, and treated as if you had
  36 passed objects.
  37
  38 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
  39
  40 =cut
  41
  42 ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
  43 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
  44 ## When doing the later insert, we need to make sure the PKs are set.
  45 ## using _relationship_data in new and funky ways..
  46 ## check Relationship::CascadeActions and Relationship::Accessor for compat
  47 ## tests!
  48
  49 sub __new_related_find_or_new_helper {
  50   my ($self, $relname, $data) = @_;
  51   if ($self->__their_pk_needs_us($relname, $data)) {
  52     return $self->result_source
  53                 ->related_source($relname)
  54                 ->resultset
  55                 ->new_result($data);
  56   }
  57   if ($self->result_source->pk_depends_on($relname, $data)) {
  58     return $self->result_source
  59                 ->related_source($relname)
  60                 ->resultset
  61                 ->find_or_new($data);
  62   }
  63   return $self->find_or_new_related($relname, $data);
  64 }
  65
  66 sub __their_pk_needs_us { # this should maybe be in resultsource.
  67   my ($self, $relname, $data) = @_;
  68   my $source = $self->result_source;
  69   my $reverse = $source->reverse_relationship_info($relname);
  70   my $rel_source = $source->related_source($relname);
  71   my $us = { $self->get_columns };
  72   foreach my $key (keys %$reverse) {
  73     # if their primary key depends on us, then we have to
  74     # just create a result and we'll fill it out afterwards
  75     return 1 if $rel_source->pk_depends_on($key, $us);
  76   }
  77   return 0;
  78 }
  79
  80 sub new {
  81   my ($class, $attrs) = @_;
  82   $class = ref $class if ref $class;
  83
  84   my $new = {
  85       _column_data          => {},
  86   };
  87   bless $new, $class;
  88
  89   if (my $handle = delete $attrs->{-source_handle}) {
  90     $new->_source_handle($handle);
  91   }
  92
  93   my $source;
  94   if ($source = delete $attrs->{-result_source}) {
  95     $new->result_source($source);
  96   }
  97
  98   if ($attrs) {
  99     $new->throw_exception("attrs must be a hashref")
 100       unless ref($attrs) eq 'HASH';
 101
 102     my ($related,$inflated);
 103     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
 104     $new->{_rel_in_storage} = 1;
 105
 106     foreach my $key (keys %$attrs) {
 107       if (ref $attrs->{$key}) {
 108         ## Can we extract this lot to use with update(_or .. ) ?
 109         confess "Can't do multi-create without result source" unless $source;
 110         my $info = $source->relationship_info($key);
 111         if ($info && $info->{attrs}{accessor}
 112           && $info->{attrs}{accessor} eq 'single')
 113         {
 114           my $rel_obj = delete $attrs->{$key};
 115           if(!Scalar::Util::blessed($rel_obj)) {
 116             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 117           }
 118
 119           $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
 120
 121           $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
 122           $related->{$key} = $rel_obj;
 123           next;
 124         } elsif ($info && $info->{attrs}{accessor}
 125             && $info->{attrs}{accessor} eq 'multi'
 126             && ref $attrs->{$key} eq 'ARRAY') {
 127           my $others = delete $attrs->{$key};
 128           foreach my $rel_obj (@$others) {
 129             if(!Scalar::Util::blessed($rel_obj)) {
 130               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 131             }
 132
 133             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
 134             $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
 135           }
 136           $related->{$key} = $others;
 137           next;
 138         } elsif ($info && $info->{attrs}{accessor}
 139           && $info->{attrs}{accessor} eq 'filter')
 140         {
 141           ## 'filter' should disappear and get merged in with 'single' above!
 142           my $rel_obj = delete $attrs->{$key};
 143           if(!Scalar::Util::blessed($rel_obj)) {
 144             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 145           }
 146           $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
 147           $inflated->{$key} = $rel_obj;
 148           next;
 149         } elsif ($class->has_column($key)
 150             && $class->column_info($key)->{_inflate_info}) {
 151           $inflated->{$key} = $attrs->{$key};
 152           next;
 153         }
 154       }
 155       $new->throw_exception("No such column $key on $class")
 156         unless $class->has_column($key);
 157       $new->store_column($key => $attrs->{$key});
 158     }
 159
 160     $new->{_relationship_data} = $related if $related;
 161     $new->{_inflated_column} = $inflated if $inflated;
 162   }
 163
 164   return $new;
 165 }
 166
 167 =head2 insert
 168
 169   $obj->insert;
 170
 171 Inserts an object into the database if it isn't already in
 172 there. Returns the object itself. Requires the object's result source to
 173 be set, or the class to have a result_source_instance method. To insert
 174 an entirely new object into the database, use C<create> (see
 175 L<DBIx::Class::ResultSet/create>).
 176
 177 To fetch an uninserted row object, call
 178 L<new|DBIx::Class::ResultSet/new> on a resultset.
 179
 180 This will also insert any uninserted, related objects held inside this
 181 one, see L<DBIx::Class::ResultSet/create> for more details.
 182
 183 =cut
 184
 185 sub insert {
 186   my ($self) = @_;
 187   return $self if $self->in_storage;
 188   my $source = $self->result_source;
 189   $source ||=  $self->result_source($self->result_source_instance)
 190     if $self->can('result_source_instance');
 191   $self->throw_exception("No result_source set on this object; can't insert")
 192     unless $source;
 193
 194   my $rollback_guard;
 195
 196   # Check if we stored uninserted relobjs here in new()
 197   my %related_stuff = (%{$self->{_relationship_data} || {}},
 198                        %{$self->{_inflated_column} || {}});
 199
 200   if(!$self->{_rel_in_storage}) {
 201
 202     # The guard will save us if we blow out of this scope via die
 203     $rollback_guard = $source->storage->txn_scope_guard;
 204
 205     ## Should all be in relationship_data, but we need to get rid of the
 206     ## 'filter' reltype..
 207     ## These are the FK rels, need their IDs for the insert.
 208
 209     my @pri = $self->primary_columns;
 210
 211     REL: foreach my $relname (keys %related_stuff) {
 212
 213       my $rel_obj = $related_stuff{$relname};
 214
 215       next REL unless (Scalar::Util::blessed($rel_obj)
 216                        && $rel_obj->isa('DBIx::Class::Row'));
 217
 218       next REL unless $source->pk_depends_on(
 219                         $relname, { $rel_obj->get_columns }
 220                       );
 221
 222       $rel_obj->insert();
 223       $self->set_from_related($relname, $rel_obj);
 224       delete $related_stuff{$relname};
 225     }
 226   }
 227
 228   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
 229   $self->set_columns($updated_cols);
 230
 231   ## PK::Auto
 232   my @auto_pri = grep {
 233                    !defined $self->get_column($_) ||
 234                    ref($self->get_column($_)) eq 'SCALAR'
 235                  } $self->primary_columns;
 236
 237   if (@auto_pri) {
 238     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
 239     #  if defined $too_many;
 240
 241     my $storage = $self->result_source->storage;
 242     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
 243       unless $storage->can('last_insert_id');
 244     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
 245     $self->throw_exception( "Can't get last insert id" )
 246       unless (@ids == @auto_pri);
 247     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
 248   }
 249
 250   $self->{_dirty_columns} = {};
 251   $self->{related_resultsets} = {};
 252
 253   if(!$self->{_rel_in_storage}) {
 254     ## Now do the has_many rels, that need $selfs ID.
 255     foreach my $relname (keys %related_stuff) {
 256       my $rel_obj = $related_stuff{$relname};
 257       my @cands;
 258       if (Scalar::Util::blessed($rel_obj)
 259           && $rel_obj->isa('DBIx::Class::Row')) {
 260         @cands = ($rel_obj);
 261       } elsif (ref $rel_obj eq 'ARRAY') {
 262         @cands = @$rel_obj;
 263       }
 264       if (@cands) {
 265         my $reverse = $source->reverse_relationship_info($relname);
 266         foreach my $obj (@cands) {
 267           $obj->set_from_related($_, $self) for keys %$reverse;
 268           my $them = { $obj->get_columns };
 269           if ($self->__their_pk_needs_us($relname, $them)) {
 270             $obj = $self->find_or_create_related($relname, $them);
 271           } else {
 272             $obj->insert();
 273           }
 274         }
 275       }
 276     }
 277     $rollback_guard->commit;
 278   }
 279
 280   $self->in_storage(1);
 281   undef $self->{_orig_ident};
 282   return $self;
 283 }
 284
 285 =head2 in_storage
 286
 287   $obj->in_storage; # Get value
 288   $obj->in_storage(1); # Set value
 289
 290 Indicates whether the object exists as a row in the database or
 291 not. This is set to true when L<DBIx::Class::ResultSet/find>,
 292 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
 293 are used.
 294
 295 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
 296 L</delete> on one, sets it to false.
 297
 298 =cut
 299
 300 sub in_storage {
 301   my ($self, $val) = @_;
 302   $self->{_in_storage} = $val if @_ > 1;
 303   return $self->{_in_storage};
 304 }
 305
 306 =head2 update
 307
 308   $obj->update \%columns?;
 309
 310 Must be run on an object that is already in the database; issues an SQL
 311 UPDATE query to commit any changes to the object to the database if
 312 required.
 313
 314 Also takes an options hashref of C<< column_name => value> pairs >> to update
 315 first. But be aware that the hashref will be passed to
 316 C<set_inflated_columns>, which might edit it in place, so dont rely on it being
 317 the same after a call to C<update>.  If you need to preserve the hashref, it is
 318 sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
 319
 320 If the values passed or any of the column values set on the object
 321 contain scalar references, eg:
 322
 323   $obj->last_modified(\'NOW()');
 324   # OR
 325   $obj->update({ last_modified => \'NOW()' });
 326
 327 The update will pass the values verbatim into SQL. (See
 328 L<SQL::Abstract> docs).  The values in your Row object will NOT change
 329 as a result of the update call, if you want the object to be updated
 330 with the actual values from the database, call L</discard_changes>
 331 after the update.
 332
 333   $obj->update()->discard_changes();
 334
 335 =cut
 336
 337 sub update {
 338   my ($self, $upd) = @_;
 339   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 340   my $ident_cond = $self->ident_condition;
 341   $self->throw_exception("Cannot safely update a row in a PK-less table")
 342     if ! keys %$ident_cond;
 343
 344   $self->set_inflated_columns($upd) if $upd;
 345   my %to_update = $self->get_dirty_columns;
 346   return $self unless keys %to_update;
 347   my $rows = $self->result_source->storage->update(
 348                $self->result_source, \%to_update,
 349                $self->{_orig_ident} || $ident_cond
 350              );
 351   if ($rows == 0) {
 352     $self->throw_exception( "Can't update ${self}: row not found" );
 353   } elsif ($rows > 1) {
 354     $self->throw_exception("Can't update ${self}: updated more than one row");
 355   }
 356   $self->{_dirty_columns} = {};
 357   $self->{related_resultsets} = {};
 358   undef $self->{_orig_ident};
 359   return $self;
 360 }
 361
 362 =head2 delete
 363
 364   $obj->delete
 365
 366 Deletes the object from the database. The object is still perfectly
 367 usable, but C<< ->in_storage() >> will now return 0 and the object must
 368 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 369 on it. If you delete an object in a class with a C<has_many>
 370 relationship, all the related objects will be deleted as well. To turn
 371 this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
 372 hashref. Any database-level cascade or restrict will take precedence
 373 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 374
 375 =cut
 376
 377 sub delete {
 378   my $self = shift;
 379   if (ref $self) {
 380     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 381     my $ident_cond = $self->ident_condition;
 382     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 383       if ! keys %$ident_cond;
 384     foreach my $column (keys %$ident_cond) {
 385             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 386               unless exists $self->{_column_data}{$column};
 387     }
 388     $self->result_source->storage->delete(
 389       $self->result_source, $ident_cond);
 390     $self->in_storage(undef);
 391   } else {
 392     $self->throw_exception("Can't do class delete without a ResultSource instance")
 393       unless $self->can('result_source_instance');
 394     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 395     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 396     $self->result_source_instance->resultset->search(@_)->delete;
 397   }
 398   return $self;
 399 }
 400
 401 =head2 get_column
 402
 403   my $val = $obj->get_column($col);
 404
 405 Returns a raw column value from the row object, if it has already
 406 been fetched from the database or set by an accessor.
 407
 408 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
 409 will be deflated and returned.
 410
 411 =cut
 412
 413 sub get_column {
 414   my ($self, $column) = @_;
 415   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 416   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 417   if (exists $self->{_inflated_column}{$column}) {
 418     return $self->store_column($column,
 419       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 420   }
 421   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 422   return undef;
 423 }
 424
 425 =head2 has_column_loaded
 426
 427   if ( $obj->has_column_loaded($col) ) {
 428      print "$col has been loaded from db";
 429   }
 430
 431 Returns a true value if the column value has been loaded from the
 432 database (or set locally).
 433
 434 =cut
 435
 436 sub has_column_loaded {
 437   my ($self, $column) = @_;
 438   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 439   return 1 if exists $self->{_inflated_column}{$column};
 440   return exists $self->{_column_data}{$column};
 441 }
 442
 443 =head2 get_columns
 444
 445   my %data = $obj->get_columns;
 446
 447 Does C<get_column>, for all loaded column values at once.
 448
 449 =cut
 450
 451 sub get_columns {
 452   my $self = shift;
 453   if (exists $self->{_inflated_column}) {
 454     foreach my $col (keys %{$self->{_inflated_column}}) {
 455       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 456         unless exists $self->{_column_data}{$col};
 457     }
 458   }
 459   return %{$self->{_column_data}};
 460 }
 461
 462 =head2 get_dirty_columns
 463
 464   my %data = $obj->get_dirty_columns;
 465
 466 Identical to get_columns but only returns those that have been changed.
 467
 468 =cut
 469
 470 sub get_dirty_columns {
 471   my $self = shift;
 472   return map { $_ => $self->{_column_data}{$_} }
 473            keys %{$self->{_dirty_columns}};
 474 }
 475
 476 =head2 make_column_dirty
 477
 478 Marks a column dirty regardless if it has really changed.  Throws an
 479 exception if the column does not exist.
 480
 481 =cut
 482 sub make_column_dirty {
 483   my ($self, $column) = @_;
 484
 485   $self->throw_exception( "No such column '${column}'" )
 486     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 487   $self->{_dirty_columns}{$column} = 1;
 488 }
 489
 490 =head2 get_inflated_columns
 491
 492   my %inflated_data = $obj->get_inflated_columns;
 493
 494 Similar to get_columns but objects are returned for inflated columns
 495 instead of their raw non-inflated values.
 496
 497 =cut
 498
 499 sub get_inflated_columns {
 500   my $self = shift;
 501   return map {
 502     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 503     ($_ => $self->$accessor);
 504   } $self->columns;
 505 }
 506
 507 =head2 set_column
 508
 509   $obj->set_column($col => $val);
 510
 511 Sets a raw column value. If the new value is different from the old one,
 512 the column is marked as dirty for when you next call $obj->update.
 513
 514 If passed an object or reference, this will happily attempt store the
 515 value, and a later insert/update will try and stringify/numify as
 516 appropriate.
 517
 518 =cut
 519
 520 sub set_column {
 521   my $self = shift;
 522   my ($column) = @_;
 523   $self->{_orig_ident} ||= $self->ident_condition;
 524   my $old = $self->get_column($column);
 525   my $ret = $self->store_column(@_);
 526   $self->{_dirty_columns}{$column} = 1
 527     if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
 528
 529   # XXX clear out the relation cache for this column
 530   delete $self->{related_resultsets}{$column};
 531
 532   return $ret;
 533 }
 534
 535 =head2 set_columns
 536
 537   my $copy = $orig->set_columns({ $col => $val, ... });
 538
 539 Sets more than one column value at once.
 540
 541 =cut
 542
 543 sub set_columns {
 544   my ($self,$data) = @_;
 545   foreach my $col (keys %$data) {
 546     $self->set_column($col,$data->{$col});
 547   }
 548   return $self;
 549 }
 550
 551 =head2 set_inflated_columns
 552
 553   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
 554
 555 Sets more than one column value at once, taking care to respect inflations and
 556 relationships if relevant. Be aware that this hashref might be edited in place,
 557 so dont rely on it being the same after a call to C<set_inflated_columns>. If
 558 you need to preserve the hashref, it is sufficient to pass a shallow copy to
 559 C<set_inflated_columns>, e.g. ( { %{ $href } } )
 560
 561 =cut
 562
 563 sub set_inflated_columns {
 564   my ( $self, $upd ) = @_;
 565   foreach my $key (keys %$upd) {
 566     if (ref $upd->{$key}) {
 567       my $info = $self->relationship_info($key);
 568       if ($info && $info->{attrs}{accessor}
 569         && $info->{attrs}{accessor} eq 'single')
 570       {
 571         my $rel = delete $upd->{$key};
 572         $self->set_from_related($key => $rel);
 573         $self->{_relationship_data}{$key} = $rel;
 574       } elsif ($info && $info->{attrs}{accessor}
 575         && $info->{attrs}{accessor} eq 'multi'
 576         && ref $upd->{$key} eq 'ARRAY') {
 577         my $others = delete $upd->{$key};
 578         foreach my $rel_obj (@$others) {
 579           if(!Scalar::Util::blessed($rel_obj)) {
 580             $rel_obj = $self->create_related($key, $rel_obj);
 581           }
 582         }
 583         $self->{_relationship_data}{$key} = $others;
 584 #            $related->{$key} = $others;
 585         next;
 586       }
 587       elsif ($self->has_column($key)
 588         && exists $self->column_info($key)->{_inflate_info})
 589       {
 590         $self->set_inflated_column($key, delete $upd->{$key});
 591       }
 592     }
 593   }
 594   $self->set_columns($upd);
 595 }
 596
 597 =head2 copy
 598
 599   my $copy = $orig->copy({ change => $to, ... });
 600
 601 Inserts a new row with the specified changes. If the row has related
 602 objects in a C<has_many> then those objects may be copied too depending
 603 on the C<cascade_copy> relationship attribute.
 604
 605 =cut
 606
 607 sub copy {
 608   my ($self, $changes) = @_;
 609   $changes ||= {};
 610   my $col_data = { %{$self->{_column_data}} };
 611   foreach my $col (keys %$col_data) {
 612     delete $col_data->{$col}
 613       if $self->result_source->column_info($col)->{is_auto_increment};
 614   }
 615
 616   my $new = { _column_data => $col_data };
 617   bless $new, ref $self;
 618
 619   $new->result_source($self->result_source);
 620   $new->set_inflated_columns($changes);
 621   $new->insert;
 622
 623   # Its possible we'll have 2 relations to the same Source. We need to make
 624   # sure we don't try to insert the same row twice esle we'll violate unique
 625   # constraints
 626   my $rels_copied = {};
 627
 628   foreach my $rel ($self->result_source->relationships) {
 629     my $rel_info = $self->result_source->relationship_info($rel);
 630
 631     next unless $rel_info->{attrs}{cascade_copy};
 632
 633     my $resolved = $self->result_source->resolve_condition(
 634       $rel_info->{cond}, $rel, $new
 635     );
 636
 637     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 638     foreach my $related ($self->search_related($rel)) {
 639       my $id_str = join("\0", $related->id);
 640       next if $copied->{$id_str};
 641       $copied->{$id_str} = 1;
 642       my $rel_copy = $related->copy($resolved);
 643     }
 644
 645   }
 646   return $new;
 647 }
 648
 649 =head2 store_column
 650
 651   $obj->store_column($col => $val);
 652
 653 Sets a column value without marking it as dirty.
 654
 655 =cut
 656
 657 sub store_column {
 658   my ($self, $column, $value) = @_;
 659   $self->throw_exception( "No such column '${column}'" )
 660     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 661   $self->throw_exception( "set_column called for ${column} without value" )
 662     if @_ < 3;
 663   return $self->{_column_data}{$column} = $value;
 664 }
 665
 666 =head2 inflate_result
 667
 668   Class->inflate_result($result_source, \%me, \%prefetch?)
 669
 670 Called by ResultSet to inflate a result from storage
 671
 672 =cut
 673
 674 sub inflate_result {
 675   my ($class, $source, $me, $prefetch) = @_;
 676
 677   my ($source_handle) = $source;
 678
 679   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 680       $source = $source_handle->resolve
 681   } else {
 682       $source_handle = $source->handle
 683   }
 684
 685   my $new = {
 686     _source_handle => $source_handle,
 687     _column_data => $me,
 688     _in_storage => 1
 689   };
 690   bless $new, (ref $class || $class);
 691
 692   my $schema;
 693   foreach my $pre (keys %{$prefetch||{}}) {
 694     my $pre_val = $prefetch->{$pre};
 695     my $pre_source = $source->related_source($pre);
 696     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 697       unless $pre_source;
 698     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 699       my @pre_objects;
 700       foreach my $pre_rec (@$pre_val) {
 701         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 702            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 703           next;
 704         }
 705         push(@pre_objects, $pre_source->result_class->inflate_result(
 706                              $pre_source, @{$pre_rec}));
 707       }
 708       $new->related_resultset($pre)->set_cache(\@pre_objects);
 709     } elsif (defined $pre_val->[0]) {
 710       my $fetched;
 711       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 712          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 713       {
 714         $fetched = $pre_source->result_class->inflate_result(
 715                       $pre_source, @{$pre_val});
 716       }
 717       $new->related_resultset($pre)->set_cache([ $fetched ]);
 718       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 719       $class->throw_exception("No accessor for prefetched $pre")
 720        unless defined $accessor;
 721       if ($accessor eq 'single') {
 722         $new->{_relationship_data}{$pre} = $fetched;
 723       } elsif ($accessor eq 'filter') {
 724         $new->{_inflated_column}{$pre} = $fetched;
 725       } else {
 726        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 727       }
 728     }
 729   }
 730   return $new;
 731 }
 732
 733 =head2 update_or_insert
 734
 735   $obj->update_or_insert
 736
 737 Updates the object if it's already in the database, according to
 738 L</in_storage>, else inserts it.
 739
 740 =head2 insert_or_update
 741
 742   $obj->insert_or_update
 743
 744 Alias for L</update_or_insert>
 745
 746 =cut
 747
 748 sub insert_or_update { shift->update_or_insert(@_) }
 749
 750 sub update_or_insert {
 751   my $self = shift;
 752   return ($self->in_storage ? $self->update : $self->insert);
 753 }
 754
 755 =head2 is_changed
 756
 757   my @changed_col_names = $obj->is_changed();
 758   if ($obj->is_changed()) { ... }
 759
 760 In array context returns a list of columns with uncommited changes, or
 761 in scalar context returns a true value if there are uncommitted
 762 changes.
 763
 764 =cut
 765
 766 sub is_changed {
 767   return keys %{shift->{_dirty_columns} || {}};
 768 }
 769
 770 =head2 is_column_changed
 771
 772   if ($obj->is_column_changed('col')) { ... }
 773
 774 Returns a true value if the column has uncommitted changes.
 775
 776 =cut
 777
 778 sub is_column_changed {
 779   my( $self, $col ) = @_;
 780   return exists $self->{_dirty_columns}->{$col};
 781 }
 782
 783 =head2 result_source
 784
 785   my $resultsource = $object->result_source;
 786
 787 Accessor to the ResultSource this object was created from
 788
 789 =cut
 790
 791 sub result_source {
 792     my $self = shift;
 793
 794     if (@_) {
 795         $self->_source_handle($_[0]->handle);
 796     } else {
 797         $self->_source_handle->resolve;
 798     }
 799 }
 800
 801 =head2 register_column
 802
 803   $column_info = { .... };
 804   $class->register_column($column_name, $column_info);
 805
 806 Registers a column on the class. If the column_info has an 'accessor'
 807 key, creates an accessor named after the value if defined; if there is
 808 no such key, creates an accessor with the same name as the column
 809
 810 The column_info attributes are described in
 811 L<DBIx::Class::ResultSource/add_columns>
 812
 813 =cut
 814
 815 sub register_column {
 816   my ($class, $col, $info) = @_;
 817   my $acc = $col;
 818   if (exists $info->{accessor}) {
 819     return unless defined $info->{accessor};
 820     $acc = [ $info->{accessor}, $col ];
 821   }
 822   $class->mk_group_accessors('column' => $acc);
 823 }
 824
 825 =head2 get_from_storage ($attrs)
 826
 827 Returns a new Row which is whatever the Storage has for the currently created
 828 Row object.  You can use this to see if the storage has become inconsistent with
 829 whatever your Row object is.
 830
 831 $attrs is expected to be a hashref of attributes suitable for passing as the
 832 second argument to $resultset->search($cond, $attrs);
 833
 834 =cut
 835
 836 sub get_from_storage {
 837     my $self = shift @_;
 838     my $attrs = shift @_;
 839     my @primary_columns = map { $self->$_ } $self->primary_columns;
 840     my $resultset = $self->result_source->resultset;
 841
 842     if(defined $attrs) {
 843         $resultset = $resultset->search(undef, $attrs);
 844     }
 845
 846     return $resultset->find(@primary_columns);
 847 }
 848
 849 =head2 throw_exception
 850
 851 See Schema's throw_exception.
 852
 853 =cut
 854
 855 sub throw_exception {
 856   my $self=shift;
 857   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 858     $self->result_source->schema->throw_exception(@_);
 859   } else {
 860     croak(@_);
 861   }
 862 }
 863
 864 =head2 id
 865
 866 Returns the primary key(s) for a row. Can't be called as a class method.
 867 Actually implemented in L<DBIx::Class::PK>
 868
 869 =head2 discard_changes
 870
 871 Re-selects the row from the database, losing any changes that had
 872 been made.
 873
 874 This method can also be used to refresh from storage, retrieving any
 875 changes made since the row was last read from storage. Actually
 876 implemented in L<DBIx::Class::PK>
 877
 878 =cut
 879
 880 1;
 881
 882 =head1 AUTHORS
 883
 884 Matt S. Trout <mst@shadowcatsystems.co.uk>
 885
 886 =head1 LICENSE
 887
 888 You may distribute this code under the same terms as Perl itself.
 889
 890 =cut