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_create($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_inflated_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->{_orig_ident} || $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, $column, $new_value) = @_;
 522
 523   $self->{_orig_ident} ||= $self->ident_condition;
 524   my $old_value = $self->get_column($column);
 525
 526   $self->store_column($column, $new_value);
 527   $self->{_dirty_columns}{$column} = 1
 528     if (defined $old_value xor defined $new_value) || (defined $old_value && $old_value ne $new_value);
 529
 530   # XXX clear out the relation cache for this column
 531   delete $self->{related_resultsets}{$column};
 532
 533   return $new_value;
 534 }
 535
 536 =head2 set_columns
 537
 538   my $copy = $orig->set_columns({ $col => $val, ... });
 539
 540 Sets more than one column value at once.
 541
 542 =cut
 543
 544 sub set_columns {
 545   my ($self,$data) = @_;
 546   foreach my $col (keys %$data) {
 547     $self->set_column($col,$data->{$col});
 548   }
 549   return $self;
 550 }
 551
 552 =head2 set_inflated_columns
 553
 554   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
 555
 556 Sets more than one column value at once, taking care to respect inflations and
 557 relationships if relevant. Be aware that this hashref might be edited in place,
 558 so dont rely on it being the same after a call to C<set_inflated_columns>. If
 559 you need to preserve the hashref, it is sufficient to pass a shallow copy to
 560 C<set_inflated_columns>, e.g. ( { %{ $href } } )
 561
 562 =cut
 563
 564 sub set_inflated_columns {
 565   my ( $self, $upd ) = @_;
 566   foreach my $key (keys %$upd) {
 567     if (ref $upd->{$key}) {
 568       my $info = $self->relationship_info($key);
 569       if ($info && $info->{attrs}{accessor}
 570         && $info->{attrs}{accessor} eq 'single')
 571       {
 572         my $rel = delete $upd->{$key};
 573         $self->set_from_related($key => $rel);
 574         $self->{_relationship_data}{$key} = $rel;
 575       } elsif ($info && $info->{attrs}{accessor}
 576         && $info->{attrs}{accessor} eq 'multi'
 577         && ref $upd->{$key} eq 'ARRAY') {
 578         my $others = delete $upd->{$key};
 579         foreach my $rel_obj (@$others) {
 580           if(!Scalar::Util::blessed($rel_obj)) {
 581             $rel_obj = $self->create_related($key, $rel_obj);
 582           }
 583         }
 584         $self->{_relationship_data}{$key} = $others;
 585 #            $related->{$key} = $others;
 586         next;
 587       }
 588       elsif ($self->has_column($key)
 589         && exists $self->column_info($key)->{_inflate_info})
 590       {
 591         $self->set_inflated_column($key, delete $upd->{$key});
 592       }
 593     }
 594   }
 595   $self->set_columns($upd);
 596 }
 597
 598 =head2 copy
 599
 600   my $copy = $orig->copy({ change => $to, ... });
 601
 602 Inserts a new row with the specified changes. If the row has related
 603 objects in a C<has_many> then those objects may be copied too depending
 604 on the C<cascade_copy> relationship attribute.
 605
 606 =cut
 607
 608 sub copy {
 609   my ($self, $changes) = @_;
 610   $changes ||= {};
 611   my $col_data = { %{$self->{_column_data}} };
 612   foreach my $col (keys %$col_data) {
 613     delete $col_data->{$col}
 614       if $self->result_source->column_info($col)->{is_auto_increment};
 615   }
 616
 617   my $new = { _column_data => $col_data };
 618   bless $new, ref $self;
 619
 620   $new->result_source($self->result_source);
 621   $new->set_inflated_columns($changes);
 622   $new->insert;
 623
 624   # Its possible we'll have 2 relations to the same Source. We need to make
 625   # sure we don't try to insert the same row twice esle we'll violate unique
 626   # constraints
 627   my $rels_copied = {};
 628
 629   foreach my $rel ($self->result_source->relationships) {
 630     my $rel_info = $self->result_source->relationship_info($rel);
 631
 632     next unless $rel_info->{attrs}{cascade_copy};
 633
 634     my $resolved = $self->result_source->resolve_condition(
 635       $rel_info->{cond}, $rel, $new
 636     );
 637
 638     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 639     foreach my $related ($self->search_related($rel)) {
 640       my $id_str = join("\0", $related->id);
 641       next if $copied->{$id_str};
 642       $copied->{$id_str} = 1;
 643       my $rel_copy = $related->copy($resolved);
 644     }
 645
 646   }
 647   return $new;
 648 }
 649
 650 =head2 store_column
 651
 652   $obj->store_column($col => $val);
 653
 654 Sets a column value without marking it as dirty.
 655
 656 =cut
 657
 658 sub store_column {
 659   my ($self, $column, $value) = @_;
 660   $self->throw_exception( "No such column '${column}'" )
 661     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 662   $self->throw_exception( "set_column called for ${column} without value" )
 663     if @_ < 3;
 664   return $self->{_column_data}{$column} = $value;
 665 }
 666
 667 =head2 inflate_result
 668
 669   Class->inflate_result($result_source, \%me, \%prefetch?)
 670
 671 Called by ResultSet to inflate a result from storage
 672
 673 =cut
 674
 675 sub inflate_result {
 676   my ($class, $source, $me, $prefetch) = @_;
 677
 678   my ($source_handle) = $source;
 679
 680   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 681       $source = $source_handle->resolve
 682   } else {
 683       $source_handle = $source->handle
 684   }
 685
 686   my $new = {
 687     _source_handle => $source_handle,
 688     _column_data => $me,
 689     _in_storage => 1
 690   };
 691   bless $new, (ref $class || $class);
 692
 693   my $schema;
 694   foreach my $pre (keys %{$prefetch||{}}) {
 695     my $pre_val = $prefetch->{$pre};
 696     my $pre_source = $source->related_source($pre);
 697     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 698       unless $pre_source;
 699     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 700       my @pre_objects;
 701       foreach my $pre_rec (@$pre_val) {
 702         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 703            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 704           next;
 705         }
 706         push(@pre_objects, $pre_source->result_class->inflate_result(
 707                              $pre_source, @{$pre_rec}));
 708       }
 709       $new->related_resultset($pre)->set_cache(\@pre_objects);
 710     } elsif (defined $pre_val->[0]) {
 711       my $fetched;
 712       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 713          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 714       {
 715         $fetched = $pre_source->result_class->inflate_result(
 716                       $pre_source, @{$pre_val});
 717       }
 718       $new->related_resultset($pre)->set_cache([ $fetched ]);
 719       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 720       $class->throw_exception("No accessor for prefetched $pre")
 721        unless defined $accessor;
 722       if ($accessor eq 'single') {
 723         $new->{_relationship_data}{$pre} = $fetched;
 724       } elsif ($accessor eq 'filter') {
 725         $new->{_inflated_column}{$pre} = $fetched;
 726       } else {
 727        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 728       }
 729     }
 730   }
 731   return $new;
 732 }
 733
 734 =head2 update_or_insert
 735
 736   $obj->update_or_insert
 737
 738 Updates the object if it's already in the database, according to
 739 L</in_storage>, else inserts it.
 740
 741 =head2 insert_or_update
 742
 743   $obj->insert_or_update
 744
 745 Alias for L</update_or_insert>
 746
 747 =cut
 748
 749 sub insert_or_update { shift->update_or_insert(@_) }
 750
 751 sub update_or_insert {
 752   my $self = shift;
 753   return ($self->in_storage ? $self->update : $self->insert);
 754 }
 755
 756 =head2 is_changed
 757
 758   my @changed_col_names = $obj->is_changed();
 759   if ($obj->is_changed()) { ... }
 760
 761 In array context returns a list of columns with uncommited changes, or
 762 in scalar context returns a true value if there are uncommitted
 763 changes.
 764
 765 =cut
 766
 767 sub is_changed {
 768   return keys %{shift->{_dirty_columns} || {}};
 769 }
 770
 771 =head2 is_column_changed
 772
 773   if ($obj->is_column_changed('col')) { ... }
 774
 775 Returns a true value if the column has uncommitted changes.
 776
 777 =cut
 778
 779 sub is_column_changed {
 780   my( $self, $col ) = @_;
 781   return exists $self->{_dirty_columns}->{$col};
 782 }
 783
 784 =head2 result_source
 785
 786   my $resultsource = $object->result_source;
 787
 788 Accessor to the ResultSource this object was created from
 789
 790 =cut
 791
 792 sub result_source {
 793     my $self = shift;
 794
 795     if (@_) {
 796         $self->_source_handle($_[0]->handle);
 797     } else {
 798         $self->_source_handle->resolve;
 799     }
 800 }
 801
 802 =head2 register_column
 803
 804   $column_info = { .... };
 805   $class->register_column($column_name, $column_info);
 806
 807 Registers a column on the class. If the column_info has an 'accessor'
 808 key, creates an accessor named after the value if defined; if there is
 809 no such key, creates an accessor with the same name as the column
 810
 811 The column_info attributes are described in
 812 L<DBIx::Class::ResultSource/add_columns>
 813
 814 =cut
 815
 816 sub register_column {
 817   my ($class, $col, $info) = @_;
 818   my $acc = $col;
 819   if (exists $info->{accessor}) {
 820     return unless defined $info->{accessor};
 821     $acc = [ $info->{accessor}, $col ];
 822   }
 823   $class->mk_group_accessors('column' => $acc);
 824 }
 825
 826 =head2 get_from_storage ($attrs)
 827
 828 Returns a new Row which is whatever the Storage has for the currently created
 829 Row object.  You can use this to see if the storage has become inconsistent with
 830 whatever your Row object is.
 831
 832 $attrs is expected to be a hashref of attributes suitable for passing as the
 833 second argument to $resultset->search($cond, $attrs);
 834
 835 =cut
 836
 837 sub get_from_storage {
 838     my $self = shift @_;
 839     my $attrs = shift @_;
 840     my $resultset = $self->result_source->resultset;
 841
 842     if(defined $attrs) {
 843         $resultset = $resultset->search(undef, $attrs);
 844     }
 845
 846     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
 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