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