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 get_inflated_columns
 455
 456   my %inflated_data = $obj->get_inflated_columns;
 457
 458 Similar to get_columns but objects are returned for inflated columns
 459 instead of their raw non-inflated values.
 460
 461 =cut
 462
 463 sub get_inflated_columns {
 464   my $self = shift;
 465   return map {
 466     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 467     ($_ => $self->$accessor);
 468   } $self->columns;
 469 }
 470
 471 =head2 set_column
 472
 473   $obj->set_column($col => $val);
 474
 475 Sets a raw column value. If the new value is different from the old one,
 476 the column is marked as dirty for when you next call $obj->update.
 477
 478 If passed an object or reference, this will happily attempt store the
 479 value, and a later insert/update will try and stringify/numify as
 480 appropriate.
 481
 482 =cut
 483
 484 sub set_column {
 485   my $self = shift;
 486   my ($column) = @_;
 487   $self->{_orig_ident} ||= $self->ident_condition;
 488   my $old = $self->get_column($column);
 489   my $ret = $self->store_column(@_);
 490   $self->{_dirty_columns}{$column} = 1
 491     if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
 492
 493   # XXX clear out the relation cache for this column
 494   delete $self->{related_resultsets}{$column};
 495
 496   return $ret;
 497 }
 498
 499 =head2 set_columns
 500
 501   my $copy = $orig->set_columns({ $col => $val, ... });
 502
 503 Sets more than one column value at once.
 504
 505 =cut
 506
 507 sub set_columns {
 508   my ($self,$data) = @_;
 509   foreach my $col (keys %$data) {
 510     $self->set_column($col,$data->{$col});
 511   }
 512   return $self;
 513 }
 514
 515 =head2 set_inflated_columns
 516
 517   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
 518
 519 Sets more than one column value at once, taking care to respect inflations and
 520 relationships if relevant. Be aware that this hashref might be edited in place,
 521 so dont rely on it being the same after a call to C<set_inflated_columns>. If
 522 you need to preserve the hashref, it is sufficient to pass a shallow copy to
 523 C<set_inflated_columns>, e.g. ( { %{ $href } } )
 524
 525 =cut
 526
 527 sub set_inflated_columns {
 528   my ( $self, $upd ) = @_;
 529   foreach my $key (keys %$upd) {
 530     if (ref $upd->{$key}) {
 531       my $info = $self->relationship_info($key);
 532       if ($info && $info->{attrs}{accessor}
 533         && $info->{attrs}{accessor} eq 'single')
 534       {
 535         my $rel = delete $upd->{$key};
 536         $self->set_from_related($key => $rel);
 537         $self->{_relationship_data}{$key} = $rel;
 538       } elsif ($info && $info->{attrs}{accessor}
 539         && $info->{attrs}{accessor} eq 'multi'
 540         && ref $upd->{$key} eq 'ARRAY') {
 541         my $others = delete $upd->{$key};
 542         foreach my $rel_obj (@$others) {
 543           if(!Scalar::Util::blessed($rel_obj)) {
 544             $rel_obj = $self->create_related($key, $rel_obj);
 545           }
 546         }
 547         $self->{_relationship_data}{$key} = $others;
 548 #            $related->{$key} = $others;
 549         next;
 550       }
 551       elsif ($self->has_column($key)
 552         && exists $self->column_info($key)->{_inflate_info})
 553       {
 554         $self->set_inflated_column($key, delete $upd->{$key});
 555       }
 556     }
 557   }
 558   $self->set_columns($upd);
 559 }
 560
 561 =head2 copy
 562
 563   my $copy = $orig->copy({ change => $to, ... });
 564
 565 Inserts a new row with the specified changes. If the row has related
 566 objects in a C<has_many> then those objects may be copied too depending
 567 on the C<cascade_copy> relationship attribute.
 568
 569 =cut
 570
 571 sub copy {
 572   my ($self, $changes) = @_;
 573   $changes ||= {};
 574   my $col_data = { %{$self->{_column_data}} };
 575   foreach my $col (keys %$col_data) {
 576     delete $col_data->{$col}
 577       if $self->result_source->column_info($col)->{is_auto_increment};
 578   }
 579
 580   my $new = { _column_data => $col_data };
 581   bless $new, ref $self;
 582
 583   $new->result_source($self->result_source);
 584   $new->set_inflated_columns($changes);
 585   $new->insert;
 586
 587   # Its possible we'll have 2 relations to the same Source. We need to make
 588   # sure we don't try to insert the same row twice esle we'll violate unique
 589   # constraints
 590   my $rels_copied = {};
 591
 592   foreach my $rel ($self->result_source->relationships) {
 593     my $rel_info = $self->result_source->relationship_info($rel);
 594
 595     next unless $rel_info->{attrs}{cascade_copy};
 596
 597     my $resolved = $self->result_source->resolve_condition(
 598       $rel_info->{cond}, $rel, $new
 599     );
 600
 601     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 602     foreach my $related ($self->search_related($rel)) {
 603       my $id_str = join("\0", $related->id);
 604       next if $copied->{$id_str};
 605       $copied->{$id_str} = 1;
 606       my $rel_copy = $related->copy($resolved);
 607     }
 608
 609   }
 610   return $new;
 611 }
 612
 613 =head2 store_column
 614
 615   $obj->store_column($col => $val);
 616
 617 Sets a column value without marking it as dirty.
 618
 619 =cut
 620
 621 sub store_column {
 622   my ($self, $column, $value) = @_;
 623   $self->throw_exception( "No such column '${column}'" )
 624     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 625   $self->throw_exception( "set_column called for ${column} without value" )
 626     if @_ < 3;
 627   return $self->{_column_data}{$column} = $value;
 628 }
 629
 630 =head2 inflate_result
 631
 632   Class->inflate_result($result_source, \%me, \%prefetch?)
 633
 634 Called by ResultSet to inflate a result from storage
 635
 636 =cut
 637
 638 sub inflate_result {
 639   my ($class, $source, $me, $prefetch) = @_;
 640
 641   my ($source_handle) = $source;
 642
 643   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 644       $source = $source_handle->resolve
 645   } else {
 646       $source_handle = $source->handle
 647   }
 648
 649   my $new = {
 650     _source_handle => $source_handle,
 651     _column_data => $me,
 652     _in_storage => 1
 653   };
 654   bless $new, (ref $class || $class);
 655
 656   my $schema;
 657   foreach my $pre (keys %{$prefetch||{}}) {
 658     my $pre_val = $prefetch->{$pre};
 659     my $pre_source = $source->related_source($pre);
 660     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 661       unless $pre_source;
 662     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 663       my @pre_objects;
 664       foreach my $pre_rec (@$pre_val) {
 665         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 666            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 667           next;
 668         }
 669         push(@pre_objects, $pre_source->result_class->inflate_result(
 670                              $pre_source, @{$pre_rec}));
 671       }
 672       $new->related_resultset($pre)->set_cache(\@pre_objects);
 673     } elsif (defined $pre_val->[0]) {
 674       my $fetched;
 675       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 676          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 677       {
 678         $fetched = $pre_source->result_class->inflate_result(
 679                       $pre_source, @{$pre_val});
 680       }
 681       $new->related_resultset($pre)->set_cache([ $fetched ]);
 682       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 683       $class->throw_exception("No accessor for prefetched $pre")
 684        unless defined $accessor;
 685       if ($accessor eq 'single') {
 686         $new->{_relationship_data}{$pre} = $fetched;
 687       } elsif ($accessor eq 'filter') {
 688         $new->{_inflated_column}{$pre} = $fetched;
 689       } else {
 690        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 691       }
 692     }
 693   }
 694   return $new;
 695 }
 696
 697 =head2 update_or_insert
 698
 699   $obj->update_or_insert
 700
 701 Updates the object if it's already in the database, according to
 702 L</in_storage>, else inserts it.
 703
 704 =head2 insert_or_update
 705
 706   $obj->insert_or_update
 707
 708 Alias for L</update_or_insert>
 709
 710 =cut
 711
 712 *insert_or_update = \&update_or_insert;
 713 sub update_or_insert {
 714   my $self = shift;
 715   return ($self->in_storage ? $self->update : $self->insert);
 716 }
 717
 718 =head2 is_changed
 719
 720   my @changed_col_names = $obj->is_changed();
 721   if ($obj->is_changed()) { ... }
 722
 723 In array context returns a list of columns with uncommited changes, or
 724 in scalar context returns a true value if there are uncommitted
 725 changes.
 726
 727 =cut
 728
 729 sub is_changed {
 730   return keys %{shift->{_dirty_columns} || {}};
 731 }
 732
 733 =head2 is_column_changed
 734
 735   if ($obj->is_column_changed('col')) { ... }
 736
 737 Returns a true value if the column has uncommitted changes.
 738
 739 =cut
 740
 741 sub is_column_changed {
 742   my( $self, $col ) = @_;
 743   return exists $self->{_dirty_columns}->{$col};
 744 }
 745
 746 =head2 result_source
 747
 748   my $resultsource = $object->result_source;
 749
 750 Accessor to the ResultSource this object was created from
 751
 752 =cut
 753
 754 sub result_source {
 755     my $self = shift;
 756
 757     if (@_) {
 758         $self->_source_handle($_[0]->handle);
 759     } else {
 760         $self->_source_handle->resolve;
 761     }
 762 }
 763
 764 =head2 register_column
 765
 766   $column_info = { .... };
 767   $class->register_column($column_name, $column_info);
 768
 769 Registers a column on the class. If the column_info has an 'accessor'
 770 key, creates an accessor named after the value if defined; if there is
 771 no such key, creates an accessor with the same name as the column
 772
 773 The column_info attributes are described in
 774 L<DBIx::Class::ResultSource/add_columns>
 775
 776 =cut
 777
 778 sub register_column {
 779   my ($class, $col, $info) = @_;
 780   my $acc = $col;
 781   if (exists $info->{accessor}) {
 782     return unless defined $info->{accessor};
 783     $acc = [ $info->{accessor}, $col ];
 784   }
 785   $class->mk_group_accessors('column' => $acc);
 786 }
 787
 788
 789 =head2 throw_exception
 790
 791 See Schema's throw_exception.
 792
 793 =cut
 794
 795 sub throw_exception {
 796   my $self=shift;
 797   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 798     $self->result_source->schema->throw_exception(@_);
 799   } else {
 800     croak(@_);
 801   }
 802 }
 803
 804 =head2 id
 805
 806 Returns the primary key(s) for a row. Can't be called as a class method.
 807 Actually implemented in L<DBIx::Class::PK>
 808
 809 =head2 discard_changes
 810
 811 Re-selects the row from the database, losing any changes that had
 812 been made.
 813
 814 This method can also be used to refresh from storage, retrieving any
 815 changes made since the row was last read from storage. Actually
 816 implemented in L<DBIx::Class::PK>
 817
 818 =cut
 819
 820 1;
 821
 822 =head1 AUTHORS
 823
 824 Matt S. Trout <mst@shadowcatsystems.co.uk>
 825
 826 =head1 LICENSE
 827
 828 You may distribute this code under the same terms as Perl itself.
 829
 830 =cut