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