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