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