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. If the row has related
 551 objects in a C<has_many> then those objects may be copied too depending
 552 on the C<cascade_copy> relationship attribute.
 553
 554 =cut
 555
 556 sub copy {
 557   my ($self, $changes) = @_;
 558   $changes ||= {};
 559   my $col_data = { %{$self->{_column_data}} };
 560   foreach my $col (keys %$col_data) {
 561     delete $col_data->{$col}
 562       if $self->result_source->column_info($col)->{is_auto_increment};
 563   }
 564
 565   my $new = { _column_data => $col_data };
 566   bless $new, ref $self;
 567
 568   $new->result_source($self->result_source);
 569   $new->set_inflated_columns($changes);
 570   $new->insert;
 571
 572   # Its possible we'll have 2 relations to the same Source. We need to make
 573   # sure we don't try to insert the same row twice esle we'll violate unique
 574   # constraints
 575   my $rels_copied = {};
 576
 577   foreach my $rel ($self->result_source->relationships) {
 578     my $rel_info = $self->result_source->relationship_info($rel);
 579
 580     next unless $rel_info->{attrs}{cascade_copy};
 581
 582     my $resolved = $self->result_source->resolve_condition(
 583       $rel_info->{cond}, $rel, $new
 584     );
 585
 586     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 587     foreach my $related ($self->search_related($rel)) {
 588       my $id_str = join("\0", $related->id);
 589       next if $copied->{$id_str};
 590       $copied->{$id_str} = 1;
 591       my $rel_copy = $related->copy($resolved);
 592     }
 593
 594   }
 595   return $new;
 596 }
 597
 598 =head2 store_column
 599
 600   $obj->store_column($col => $val);
 601
 602 Sets a column value without marking it as dirty.
 603
 604 =cut
 605
 606 sub store_column {
 607   my ($self, $column, $value) = @_;
 608   $self->throw_exception( "No such column '${column}'" )
 609     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 610   $self->throw_exception( "set_column called for ${column} without value" )
 611     if @_ < 3;
 612   return $self->{_column_data}{$column} = $value;
 613 }
 614
 615 =head2 inflate_result
 616
 617   Class->inflate_result($result_source, \%me, \%prefetch?)
 618
 619 Called by ResultSet to inflate a result from storage
 620
 621 =cut
 622
 623 sub inflate_result {
 624   my ($class, $source, $me, $prefetch) = @_;
 625
 626   my ($source_handle) = $source;
 627
 628   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 629       $source = $source_handle->resolve
 630   } else {
 631       $source_handle = $source->handle
 632   }
 633
 634   my $new = {
 635     _source_handle => $source_handle,
 636     _column_data => $me,
 637     _in_storage => 1
 638   };
 639   bless $new, (ref $class || $class);
 640
 641   my $schema;
 642   foreach my $pre (keys %{$prefetch||{}}) {
 643     my $pre_val = $prefetch->{$pre};
 644     my $pre_source = $source->related_source($pre);
 645     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 646       unless $pre_source;
 647     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 648       my @pre_objects;
 649       foreach my $pre_rec (@$pre_val) {
 650         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 651            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 652           next;
 653         }
 654         push(@pre_objects, $pre_source->result_class->inflate_result(
 655                              $pre_source, @{$pre_rec}));
 656       }
 657       $new->related_resultset($pre)->set_cache(\@pre_objects);
 658     } elsif (defined $pre_val->[0]) {
 659       my $fetched;
 660       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 661          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 662       {
 663         $fetched = $pre_source->result_class->inflate_result(
 664                       $pre_source, @{$pre_val});
 665       }
 666       $new->related_resultset($pre)->set_cache([ $fetched ]);
 667       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 668       $class->throw_exception("No accessor for prefetched $pre")
 669        unless defined $accessor;
 670       if ($accessor eq 'single') {
 671         $new->{_relationship_data}{$pre} = $fetched;
 672       } elsif ($accessor eq 'filter') {
 673         $new->{_inflated_column}{$pre} = $fetched;
 674       } else {
 675        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 676       }
 677     }
 678   }
 679   return $new;
 680 }
 681
 682 =head2 update_or_insert
 683
 684   $obj->update_or_insert
 685
 686 Updates the object if it's already in the database, according to
 687 L</in_storage>, else inserts it.
 688
 689 =head2 insert_or_update
 690
 691   $obj->insert_or_update
 692
 693 Alias for L</update_or_insert>
 694
 695 =cut
 696
 697 *insert_or_update = \&update_or_insert;
 698 sub update_or_insert {
 699   my $self = shift;
 700   return ($self->in_storage ? $self->update : $self->insert);
 701 }
 702
 703 =head2 is_changed
 704
 705   my @changed_col_names = $obj->is_changed();
 706   if ($obj->is_changed()) { ... }
 707
 708 In array context returns a list of columns with uncommited changes, or
 709 in scalar context returns a true value if there are uncommitted
 710 changes.
 711
 712 =cut
 713
 714 sub is_changed {
 715   return keys %{shift->{_dirty_columns} || {}};
 716 }
 717
 718 =head2 is_column_changed
 719
 720   if ($obj->is_column_changed('col')) { ... }
 721
 722 Returns a true value if the column has uncommitted changes.
 723
 724 =cut
 725
 726 sub is_column_changed {
 727   my( $self, $col ) = @_;
 728   return exists $self->{_dirty_columns}->{$col};
 729 }
 730
 731 =head2 result_source
 732
 733   my $resultsource = $object->result_source;
 734
 735 Accessor to the ResultSource this object was created from
 736
 737 =cut
 738
 739 sub result_source {
 740     my $self = shift;
 741
 742     if (@_) {
 743         $self->_source_handle($_[0]->handle);
 744     } else {
 745         $self->_source_handle->resolve;
 746     }
 747 }
 748
 749 =head2 register_column
 750
 751   $column_info = { .... };
 752   $class->register_column($column_name, $column_info);
 753
 754 Registers a column on the class. If the column_info has an 'accessor'
 755 key, creates an accessor named after the value if defined; if there is
 756 no such key, creates an accessor with the same name as the column
 757
 758 The column_info attributes are described in
 759 L<DBIx::Class::ResultSource/add_columns>
 760
 761 =cut
 762
 763 sub register_column {
 764   my ($class, $col, $info) = @_;
 765   my $acc = $col;
 766   if (exists $info->{accessor}) {
 767     return unless defined $info->{accessor};
 768     $acc = [ $info->{accessor}, $col ];
 769   }
 770   $class->mk_group_accessors('column' => $acc);
 771 }
 772
 773
 774 =head2 throw_exception
 775
 776 See Schema's throw_exception.
 777
 778 =cut
 779
 780 sub throw_exception {
 781   my $self=shift;
 782   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 783     $self->result_source->schema->throw_exception(@_);
 784   } else {
 785     croak(@_);
 786   }
 787 }
 788
 789 =head2 id
 790
 791 Returns the primary key(s) for a row. Can't be called as a class method.
 792 Actually implemented in L<DBIx::Class::PK>
 793
 794 =head2 discard_changes
 795
 796 Re-selects the row from the database, losing any changes that had
 797 been made.
 798
 799 This method can also be used to refresh from storage, retrieving any
 800 changes made since the row was last read from storage. Actually
 801 implemented in L<DBIx::Class::PK>
 802
 803 =cut
 804
 805 1;
 806
 807 =head1 AUTHORS
 808
 809 Matt S. Trout <mst@shadowcatsystems.co.uk>
 810
 811 =head1 LICENSE
 812
 813 You may distribute this code under the same terms as Perl itself.
 814
 815 =cut