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