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