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