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