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       use Data::Dumper;
 120       $new->throw_exception("No such column $key on $class")
 121         unless $class->has_column($key);
 122       $new->store_column($key => $attrs->{$key});
 123     }
 124
 125     $new->{_relationship_data} = $related if $related;
 126     $new->{_inflated_column} = $inflated if $inflated;
 127   }
 128
 129   return $new;
 130 }
 131
 132 =head2 insert
 133
 134   $obj->insert;
 135
 136 Inserts an object into the database if it isn't already in
 137 there. Returns the object itself. Requires the object's result source to
 138 be set, or the class to have a result_source_instance method. To insert
 139 an entirely new object into the database, use C<create> (see
 140 L<DBIx::Class::ResultSet/create>).
 141
 142 This will also insert any uninserted, related objects held inside this
 143 one, see L<DBIx::Class::ResultSet/create> for more details.
 144
 145 =cut
 146
 147 sub insert {
 148   my ($self) = @_;
 149   return $self if $self->in_storage;
 150   my $source = $self->result_source;
 151   $source ||=  $self->result_source($self->result_source_instance)
 152     if $self->can('result_source_instance');
 153   $self->throw_exception("No result_source set on this object; can't insert")
 154     unless $source;
 155
 156   my $rollback_guard;
 157
 158   # Check if we stored uninserted relobjs here in new()
 159   my %related_stuff = (%{$self->{_relationship_data} || {}},
 160                        %{$self->{_inflated_column} || {}});
 161
 162   if(!$self->{_rel_in_storage}) {
 163     $source->storage->txn_begin;
 164
 165     # The guard will save us if we blow out of this scope via die
 166
 167     $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
 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     $source->storage->txn_commit;
 251     $rollback_guard->dismiss;
 252   }
 253
 254   $self->in_storage(1);
 255   $self->{_dirty_columns} = {};
 256   $self->{related_resultsets} = {};
 257   undef $self->{_orig_ident};
 258   return $self;
 259 }
 260
 261 =head2 in_storage
 262
 263   $obj->in_storage; # Get value
 264   $obj->in_storage(1); # Set value
 265
 266 Indicates whether the object exists as a row in the database or not
 267
 268 =cut
 269
 270 sub in_storage {
 271   my ($self, $val) = @_;
 272   $self->{_in_storage} = $val if @_ > 1;
 273   return $self->{_in_storage};
 274 }
 275
 276 =head2 update
 277
 278   $obj->update \%columns?;
 279
 280 Must be run on an object that is already in the database; issues an SQL
 281 UPDATE query to commit any changes to the object to the database if
 282 required.
 283
 284 Also takes an options hashref of C<< column_name => value> pairs >> to update
 285 first. But be aware that this hashref might be edited in place, so dont rely on
 286 it being the same after a call to C<update>. If you need to preserve the hashref,
 287 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
 288
 289 =cut
 290
 291 sub update {
 292   my ($self, $upd) = @_;
 293   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 294   my $ident_cond = $self->ident_condition;
 295   $self->throw_exception("Cannot safely update a row in a PK-less table")
 296     if ! keys %$ident_cond;
 297
 298   if ($upd) {
 299     foreach my $key (keys %$upd) {
 300       if (ref $upd->{$key}) {
 301         my $info = $self->relationship_info($key);
 302         if ($info && $info->{attrs}{accessor}
 303           && $info->{attrs}{accessor} eq 'single')
 304         {
 305           my $rel = delete $upd->{$key};
 306           $self->set_from_related($key => $rel);
 307           $self->{_relationship_data}{$key} = $rel;
 308         } elsif ($info && $info->{attrs}{accessor}
 309             && $info->{attrs}{accessor} eq 'multi'
 310             && ref $upd->{$key} eq 'ARRAY') {
 311             my $others = delete $upd->{$key};
 312             foreach my $rel_obj (@$others) {
 313               if(!Scalar::Util::blessed($rel_obj)) {
 314                 $rel_obj = $self->create_related($key, $rel_obj);
 315               }
 316             }
 317             $self->{_relationship_data}{$key} = $others;
 318 #            $related->{$key} = $others;
 319             next;
 320         }
 321         elsif ($self->has_column($key)
 322           && exists $self->column_info($key)->{_inflate_info})
 323         {
 324           $self->set_inflated_column($key, delete $upd->{$key});
 325         }
 326       }
 327     }
 328     $self->set_columns($upd);
 329   }
 330   my %to_update = $self->get_dirty_columns;
 331   return $self unless keys %to_update;
 332   my $rows = $self->result_source->storage->update(
 333                $self->result_source, \%to_update,
 334                $self->{_orig_ident} || $ident_cond
 335              );
 336   if ($rows == 0) {
 337     $self->throw_exception( "Can't update ${self}: row not found" );
 338   } elsif ($rows > 1) {
 339     $self->throw_exception("Can't update ${self}: updated more than one row");
 340   }
 341   $self->{_dirty_columns} = {};
 342   $self->{related_resultsets} = {};
 343   undef $self->{_orig_ident};
 344   return $self;
 345 }
 346
 347 =head2 delete
 348
 349   $obj->delete
 350
 351 Deletes the object from the database. The object is still perfectly
 352 usable, but C<< ->in_storage() >> will now return 0 and the object must
 353 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 354 on it. If you delete an object in a class with a C<has_many>
 355 relationship, all the related objects will be deleted as well. To turn
 356 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
 357 hashref. Any database-level cascade or restrict will take precedence
 358 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 359
 360 =cut
 361
 362 sub delete {
 363   my $self = shift;
 364   if (ref $self) {
 365     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 366     my $ident_cond = $self->ident_condition;
 367     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 368       if ! keys %$ident_cond;
 369     foreach my $column (keys %$ident_cond) {
 370             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 371               unless exists $self->{_column_data}{$column};
 372     }
 373     $self->result_source->storage->delete(
 374       $self->result_source, $ident_cond);
 375     $self->in_storage(undef);
 376   } else {
 377     $self->throw_exception("Can't do class delete without a ResultSource instance")
 378       unless $self->can('result_source_instance');
 379     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 380     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 381     $self->result_source_instance->resultset->search(@_)->delete;
 382   }
 383   return $self;
 384 }
 385
 386 =head2 get_column
 387
 388   my $val = $obj->get_column($col);
 389
 390 Gets a column value from a row object. Does not do any queries; the column
 391 must have already been fetched from the database and stored in the object. If
 392 there is an inflated value stored that has not yet been deflated, it is deflated
 393 when the method is invoked.
 394
 395 =cut
 396
 397 sub get_column {
 398   my ($self, $column) = @_;
 399   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 400   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 401   if (exists $self->{_inflated_column}{$column}) {
 402     return $self->store_column($column,
 403       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 404   }
 405   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 406   return undef;
 407 }
 408
 409 =head2 has_column_loaded
 410
 411   if ( $obj->has_column_loaded($col) ) {
 412      print "$col has been loaded from db";
 413   }
 414
 415 Returns a true value if the column value has been loaded from the
 416 database (or set locally).
 417
 418 =cut
 419
 420 sub has_column_loaded {
 421   my ($self, $column) = @_;
 422   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 423   return 1 if exists $self->{_inflated_column}{$column};
 424   return exists $self->{_column_data}{$column};
 425 }
 426
 427 =head2 get_columns
 428
 429   my %data = $obj->get_columns;
 430
 431 Does C<get_column>, for all column values at once.
 432
 433 =cut
 434
 435 sub get_columns {
 436   my $self = shift;
 437   if (exists $self->{_inflated_column}) {
 438     foreach my $col (keys %{$self->{_inflated_column}}) {
 439       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 440         unless exists $self->{_column_data}{$col};
 441     }
 442   }
 443   return %{$self->{_column_data}};
 444 }
 445
 446 =head2 get_dirty_columns
 447
 448   my %data = $obj->get_dirty_columns;
 449
 450 Identical to get_columns but only returns those that have been changed.
 451
 452 =cut
 453
 454 sub get_dirty_columns {
 455   my $self = shift;
 456   return map { $_ => $self->{_column_data}{$_} }
 457            keys %{$self->{_dirty_columns}};
 458 }
 459
 460 =head2 get_inflated_columns
 461
 462   my $inflated_data = $obj->get_inflated_columns;
 463
 464 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
 465
 466 =cut
 467
 468 sub get_inflated_columns {
 469   my $self = shift;
 470   return map {
 471     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 472     ($_ => $self->$accessor);
 473   } $self->columns;
 474 }
 475
 476 =head2 set_column
 477
 478   $obj->set_column($col => $val);
 479
 480 Sets a column value. If the new value is different from the old one,
 481 the column is marked as dirty for when you next call $obj->update.
 482
 483 =cut
 484
 485 sub set_column {
 486   my $self = shift;
 487   my ($column) = @_;
 488   $self->{_orig_ident} ||= $self->ident_condition;
 489   my $old = $self->get_column($column);
 490   my $ret = $self->store_column(@_);
 491   $self->{_dirty_columns}{$column} = 1
 492     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 493   return $ret;
 494 }
 495
 496 =head2 set_columns
 497
 498   my $copy = $orig->set_columns({ $col => $val, ... });
 499
 500 Sets more than one column value at once.
 501
 502 =cut
 503
 504 sub set_columns {
 505   my ($self,$data) = @_;
 506   foreach my $col (keys %$data) {
 507     $self->set_column($col,$data->{$col});
 508   }
 509   return $self;
 510 }
 511
 512 =head2 copy
 513
 514   my $copy = $orig->copy({ change => $to, ... });
 515
 516 Inserts a new row with the specified changes.
 517
 518 =cut
 519
 520 sub copy {
 521   my ($self, $changes) = @_;
 522   $changes ||= {};
 523   my $col_data = { %{$self->{_column_data}} };
 524   foreach my $col (keys %$col_data) {
 525     delete $col_data->{$col}
 526       if $self->result_source->column_info($col)->{is_auto_increment};
 527   }
 528
 529   my $new = { _column_data => $col_data };
 530   bless $new, ref $self;
 531
 532   $new->result_source($self->result_source);
 533   $new->set_columns($changes);
 534   $new->insert;
 535
 536   # Its possible we'll have 2 relations to the same Source. We need to make
 537   # sure we don't try to insert the same row twice esle we'll violate unique
 538   # constraints
 539   my $rels_copied = {};
 540
 541   foreach my $rel ($self->result_source->relationships) {
 542     my $rel_info = $self->result_source->relationship_info($rel);
 543
 544     next unless $rel_info->{attrs}{cascade_copy};
 545
 546     my $resolved = $self->result_source->resolve_condition(
 547       $rel_info->{cond}, $rel, $new
 548     );
 549
 550     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 551     foreach my $related ($self->search_related($rel)) {
 552       my $id_str = join("\0", $related->id);
 553       next if $copied->{$id_str};
 554       $copied->{$id_str} = 1;
 555       my $rel_copy = $related->copy($resolved);
 556     }
 557
 558   }
 559   return $new;
 560 }
 561
 562 =head2 store_column
 563
 564   $obj->store_column($col => $val);
 565
 566 Sets a column value without marking it as dirty.
 567
 568 =cut
 569
 570 sub store_column {
 571   my ($self, $column, $value) = @_;
 572   $self->throw_exception( "No such column '${column}'" )
 573     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 574   $self->throw_exception( "set_column called for ${column} without value" )
 575     if @_ < 3;
 576   return $self->{_column_data}{$column} = $value;
 577 }
 578
 579 =head2 inflate_result
 580
 581   Class->inflate_result($result_source, \%me, \%prefetch?)
 582
 583 Called by ResultSet to inflate a result from storage
 584
 585 =cut
 586
 587 sub inflate_result {
 588   my ($class, $source, $me, $prefetch) = @_;
 589
 590   my ($source_handle) = $source;
 591
 592   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 593       $source = $source_handle->resolve
 594   } else {
 595       $source_handle = $source->handle
 596   }
 597
 598   my $new = {
 599     _source_handle => $source_handle,
 600     _column_data => $me,
 601     _in_storage => 1
 602   };
 603   bless $new, (ref $class || $class);
 604
 605   my $schema;
 606   foreach my $pre (keys %{$prefetch||{}}) {
 607     my $pre_val = $prefetch->{$pre};
 608     my $pre_source = $source->related_source($pre);
 609     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 610       unless $pre_source;
 611     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 612       my @pre_objects;
 613       foreach my $pre_rec (@$pre_val) {
 614         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 615            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 616           next;
 617         }
 618         push(@pre_objects, $pre_source->result_class->inflate_result(
 619                              $pre_source, @{$pre_rec}));
 620       }
 621       $new->related_resultset($pre)->set_cache(\@pre_objects);
 622     } elsif (defined $pre_val->[0]) {
 623       my $fetched;
 624       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 625          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 626       {
 627         $fetched = $pre_source->result_class->inflate_result(
 628                       $pre_source, @{$pre_val});
 629       }
 630       $new->related_resultset($pre)->set_cache([ $fetched ]);
 631       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 632       $class->throw_exception("No accessor for prefetched $pre")
 633        unless defined $accessor;
 634       if ($accessor eq 'single') {
 635         $new->{_relationship_data}{$pre} = $fetched;
 636       } elsif ($accessor eq 'filter') {
 637         $new->{_inflated_column}{$pre} = $fetched;
 638       } else {
 639        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 640       }
 641     }
 642   }
 643   return $new;
 644 }
 645
 646 =head2 update_or_insert
 647
 648   $obj->update_or_insert
 649
 650 Updates the object if it's already in the db, else inserts it.
 651
 652 =head2 insert_or_update
 653
 654   $obj->insert_or_update
 655
 656 Alias for L</update_or_insert>
 657
 658 =cut
 659
 660 *insert_or_update = \&update_or_insert;
 661 sub update_or_insert {
 662   my $self = shift;
 663   return ($self->in_storage ? $self->update : $self->insert);
 664 }
 665
 666 =head2 is_changed
 667
 668   my @changed_col_names = $obj->is_changed();
 669   if ($obj->is_changed()) { ... }
 670
 671 In array context returns a list of columns with uncommited changes, or
 672 in scalar context returns a true value if there are uncommitted
 673 changes.
 674
 675 =cut
 676
 677 sub is_changed {
 678   return keys %{shift->{_dirty_columns} || {}};
 679 }
 680
 681 =head2 is_column_changed
 682
 683   if ($obj->is_column_changed('col')) { ... }
 684
 685 Returns a true value if the column has uncommitted changes.
 686
 687 =cut
 688
 689 sub is_column_changed {
 690   my( $self, $col ) = @_;
 691   return exists $self->{_dirty_columns}->{$col};
 692 }
 693
 694 =head2 result_source
 695
 696   my $resultsource = $object->result_source;
 697
 698 Accessor to the ResultSource this object was created from
 699
 700 =cut
 701
 702 sub result_source {
 703     my $self = shift;
 704
 705     if (@_) {
 706         $self->_source_handle($_[0]->handle);
 707     } else {
 708         $self->_source_handle->resolve;
 709     }
 710 }
 711
 712 =head2 register_column
 713
 714   $column_info = { .... };
 715   $class->register_column($column_name, $column_info);
 716
 717 Registers a column on the class. If the column_info has an 'accessor'
 718 key, creates an accessor named after the value if defined; if there is
 719 no such key, creates an accessor with the same name as the column
 720
 721 The column_info attributes are described in
 722 L<DBIx::Class::ResultSource/add_columns>
 723
 724 =cut
 725
 726 sub register_column {
 727   my ($class, $col, $info) = @_;
 728   my $acc = $col;
 729   if (exists $info->{accessor}) {
 730     return unless defined $info->{accessor};
 731     $acc = [ $info->{accessor}, $col ];
 732   }
 733   $class->mk_group_accessors('column' => $acc);
 734 }
 735
 736
 737 =head2 throw_exception
 738
 739 See Schema's throw_exception.
 740
 741 =cut
 742
 743 sub throw_exception {
 744   my $self=shift;
 745   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 746     $self->result_source->schema->throw_exception(@_);
 747   } else {
 748     croak(@_);
 749   }
 750 }
 751
 752 1;
 753
 754 =head1 AUTHORS
 755
 756 Matt S. Trout <mst@shadowcatsystems.co.uk>
 757
 758 =head1 LICENSE
 759
 760 You may distribute this code under the same terms as Perl itself.
 761
 762 =cut