lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Scalar::Util ();
   9 use Scope::Guard;
  10
  11 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Row - Basic row methods
  16
  17 =head1 SYNOPSIS
  18
  19 =head1 DESCRIPTION
  20
  21 This class is responsible for defining and doing basic operations on rows
  22 derived from L<DBIx::Class::ResultSource> objects.
  23
  24 =head1 METHODS
  25
  26 =head2 new
  27
  28   my $obj = My::Class->new($attrs);
  29
  30 Creates a new row object from column => value mappings passed as a hash ref
  31
  32 Passing an object, or an arrayref of objects as a value will call
  33 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
  34 passed a hashref or an arrayref of hashrefs as the value, these will
  35 be turned into objects via new_related, and treated as if you had
  36 passed objects.
  37
  38 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
  39
  40 =cut
  41
  42 ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
  43 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
  44 ## When doing the later insert, we need to make sure the PKs are set.
  45 ## using _relationship_data in new and funky ways..
  46 ## check Relationship::CascadeActions and Relationship::Accessor for compat
  47 ## tests!
  48
  49 sub new {
  50   my ($class, $attrs) = @_;
  51   $class = ref $class if ref $class;
  52
  53   my $new = { _column_data => {} };
  54   bless $new, $class;
  55
  56   if (my $handle = delete $attrs->{-source_handle}) {
  57     $new->_source_handle($handle);
  58   }
  59   if (my $source = delete $attrs->{-result_source}) {
  60     $new->result_source($source);
  61   }
  62
  63   if ($attrs) {
  64     $new->throw_exception("attrs must be a hashref")
  65       unless ref($attrs) eq 'HASH';
  66
  67     my ($related,$inflated);
  68     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
  69     $new->{_rel_in_storage} = 1;
  70
  71     foreach my $key (keys %$attrs) {
  72       if (ref $attrs->{$key}) {
  73         ## Can we extract this lot to use with update(_or .. ) ?
  74         my $info = $class->relationship_info($key);
  75         if ($info && $info->{attrs}{accessor}
  76           && $info->{attrs}{accessor} eq 'single')
  77         {
  78           my $rel_obj = delete $attrs->{$key};
  79           if(!Scalar::Util::blessed($rel_obj)) {
  80             $rel_obj = $new->find_or_new_related($key, $rel_obj);
  81           }
  82
  83           $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
  84
  85           $new->set_from_related($key, $rel_obj);
  86           $related->{$key} = $rel_obj;
  87           next;
  88         } elsif ($info && $info->{attrs}{accessor}
  89             && $info->{attrs}{accessor} eq 'multi'
  90             && ref $attrs->{$key} eq 'ARRAY') {
  91           my $others = delete $attrs->{$key};
  92           foreach my $rel_obj (@$others) {
  93             if(!Scalar::Util::blessed($rel_obj)) {
  94               $rel_obj = $new->new_related($key, $rel_obj);
  95               $new->{_rel_in_storage} = 0;
  96             }
  97
  98             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
  99           }
 100           $related->{$key} = $others;
 101           next;
 102         } elsif ($info && $info->{attrs}{accessor}
 103           && $info->{attrs}{accessor} eq 'filter')
 104         {
 105           ## 'filter' should disappear and get merged in with 'single' above!
 106           my $rel_obj = delete $attrs->{$key};
 107           if(!Scalar::Util::blessed($rel_obj)) {
 108             $rel_obj = $new->find_or_new_related($key, $rel_obj);
 109             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
 110           }
 111           $inflated->{$key} = $rel_obj;
 112           next;
 113         } elsif ($class->has_column($key)
 114             && $class->column_info($key)->{_inflate_info}) {
 115           $inflated->{$key} = $attrs->{$key};
 116           next;
 117         }
 118       }
 119       $new->throw_exception("No such column $key on $class")
 120         unless $class->has_column($key);
 121       $new->store_column($key => $attrs->{$key});
 122     }
 123
 124     $new->{_relationship_data} = $related if $related;
 125     $new->{_inflated_column} = $inflated if $inflated;
 126   }
 127
 128   return $new;
 129 }
 130
 131 =head2 insert
 132
 133   $obj->insert;
 134
 135 Inserts an object into the database if it isn't already in
 136 there. Returns the object itself. Requires the object's result source to
 137 be set, or the class to have a result_source_instance method. To insert
 138 an entirely new object into the database, use C<create> (see
 139 L<DBIx::Class::ResultSet/create>).
 140
 141 This will also insert any uninserted, related objects held inside this
 142 one, see L<DBIx::Class::ResultSet/create> for more details.
 143
 144 =cut
 145
 146 sub insert {
 147   my ($self) = @_;
 148   return $self if $self->in_storage;
 149   my $source = $self->result_source;
 150   $source ||=  $self->result_source($self->result_source_instance)
 151     if $self->can('result_source_instance');
 152   $self->throw_exception("No result_source set on this object; can't insert")
 153     unless $source;
 154
 155   my $rollback_guard;
 156
 157   # Check if we stored uninserted relobjs here in new()
 158   my %related_stuff = (%{$self->{_relationship_data} || {}},
 159                        %{$self->{_inflated_column} || {}});
 160
 161   if(!$self->{_rel_in_storage}) {
 162     $source->storage->txn_begin;
 163
 164     # The guard will save us if we blow out of this scope via die
 165
 166     $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
 167
 168     ## Should all be in relationship_data, but we need to get rid of the
 169     ## 'filter' reltype..
 170     ## These are the FK rels, need their IDs for the insert.
 171
 172     my @pri = $self->primary_columns;
 173
 174     REL: foreach my $relname (keys %related_stuff) {
 175
 176       my $rel_obj = $related_stuff{$relname};
 177
 178       next REL unless (Scalar::Util::blessed($rel_obj)
 179                        && $rel_obj->isa('DBIx::Class::Row'));
 180
 181       my $cond = $source->relationship_info($relname)->{cond};
 182
 183       next REL unless ref($cond) eq 'HASH';
 184
 185       # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
 186
 187       my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
 188
 189       # assume anything that references our PK probably is dependent on us
 190       # rather than vice versa, unless the far side is (a) defined or (b)
 191       # auto-increment
 192
 193       foreach my $p (@pri) {
 194         if (exists $keyhash->{$p}) {
 195           unless (defined($rel_obj->get_column($keyhash->{$p}))
 196                   || $rel_obj->column_info($keyhash->{$p})
 197                              ->{is_auto_increment}) {
 198             next REL;
 199           }
 200         }
 201       }
 202
 203       $rel_obj->insert();
 204       $self->set_from_related($relname, $rel_obj);
 205       delete $related_stuff{$relname};
 206     }
 207   }
 208
 209   $source->storage->insert($source, { $self->get_columns });
 210
 211   ## PK::Auto
 212   my @auto_pri = grep {
 213                    !defined $self->get_column($_) ||
 214                    ref($self->get_column($_)) eq 'SCALAR'
 215                  } $self->primary_columns;
 216
 217   if (@auto_pri) {
 218     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
 219     #  if defined $too_many;
 220
 221     my $storage = $self->result_source->storage;
 222     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
 223       unless $storage->can('last_insert_id');
 224     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
 225     $self->throw_exception( "Can't get last insert id" )
 226       unless (@ids == @auto_pri);
 227     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
 228   }
 229
 230   if(!$self->{_rel_in_storage}) {
 231     ## Now do the has_many rels, that need $selfs ID.
 232     foreach my $relname (keys %related_stuff) {
 233       my $rel_obj = $related_stuff{$relname};
 234       my @cands;
 235       if (Scalar::Util::blessed($rel_obj)
 236           && $rel_obj->isa('DBIx::Class::Row')) {
 237         @cands = ($rel_obj);
 238       } elsif (ref $rel_obj eq 'ARRAY') {
 239         @cands = @$rel_obj;
 240       }
 241       if (@cands) {
 242         my $reverse = $source->reverse_relationship_info($relname);
 243         foreach my $obj (@cands) {
 244           $obj->set_from_related($_, $self) for keys %$reverse;
 245           $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
 246         }
 247       }
 248     }
 249     $source->storage->txn_commit;
 250     $rollback_guard->dismiss;
 251   }
 252
 253   $self->in_storage(1);
 254   $self->{_dirty_columns} = {};
 255   $self->{related_resultsets} = {};
 256   undef $self->{_orig_ident};
 257   return $self;
 258 }
 259
 260 =head2 in_storage
 261
 262   $obj->in_storage; # Get value
 263   $obj->in_storage(1); # Set value
 264
 265 Indicates whether the object exists as a row in the database or not
 266
 267 =cut
 268
 269 sub in_storage {
 270   my ($self, $val) = @_;
 271   $self->{_in_storage} = $val if @_ > 1;
 272   return $self->{_in_storage};
 273 }
 274
 275 =head2 update
 276
 277   $obj->update \%columns?;
 278
 279 Must be run on an object that is already in the database; issues an SQL
 280 UPDATE query to commit any changes to the object to the database if
 281 required.
 282
 283 Also takes an options hashref of C<< column_name => value> pairs >> to update
 284 first. But be aware that this hashref might be edited in place, so dont rely on
 285 it being the same after a call to C<update>. If you need to preserve the hashref,
 286 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
 287
 288 =cut
 289
 290 sub update {
 291   my ($self, $upd) = @_;
 292   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 293   my $ident_cond = $self->ident_condition;
 294   $self->throw_exception("Cannot safely update a row in a PK-less table")
 295     if ! keys %$ident_cond;
 296
 297   if ($upd) {
 298     foreach my $key (keys %$upd) {
 299       if (ref $upd->{$key}) {
 300         my $info = $self->relationship_info($key);
 301         if ($info && $info->{attrs}{accessor}
 302           && $info->{attrs}{accessor} eq 'single')
 303         {
 304           my $rel = delete $upd->{$key};
 305           $self->set_from_related($key => $rel);
 306           $self->{_relationship_data}{$key} = $rel;
 307         } elsif ($info && $info->{attrs}{accessor}
 308             && $info->{attrs}{accessor} eq 'multi'
 309             && ref $upd->{$key} eq 'ARRAY') {
 310             my $others = delete $upd->{$key};
 311             foreach my $rel_obj (@$others) {
 312               if(!Scalar::Util::blessed($rel_obj)) {
 313                 $rel_obj = $self->create_related($key, $rel_obj);
 314               }
 315             }
 316             $self->{_relationship_data}{$key} = $others;
 317 #            $related->{$key} = $others;
 318             next;
 319         }
 320         elsif ($self->has_column($key)
 321           && exists $self->column_info($key)->{_inflate_info})
 322         {
 323           $self->set_inflated_column($key, delete $upd->{$key});
 324         }
 325       }
 326     }
 327     $self->set_columns($upd);
 328   }
 329   my %to_update = $self->get_dirty_columns;
 330   return $self unless keys %to_update;
 331   my $rows = $self->result_source->storage->update(
 332                $self->result_source, \%to_update,
 333                $self->{_orig_ident} || $ident_cond
 334              );
 335   if ($rows == 0) {
 336     $self->throw_exception( "Can't update ${self}: row not found" );
 337   } elsif ($rows > 1) {
 338     $self->throw_exception("Can't update ${self}: updated more than one row");
 339   }
 340   $self->{_dirty_columns} = {};
 341   $self->{related_resultsets} = {};
 342   undef $self->{_orig_ident};
 343   return $self;
 344 }
 345
 346 =head2 delete
 347
 348   $obj->delete
 349
 350 Deletes the object from the database. The object is still perfectly
 351 usable, but C<< ->in_storage() >> will now return 0 and the object must
 352 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 353 on it. If you delete an object in a class with a C<has_many>
 354 relationship, all the related objects will be deleted as well. To turn
 355 this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
 356 hashref. Any database-level cascade or restrict will take precedence
 357 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 358
 359 =cut
 360
 361 sub delete {
 362   my $self = shift;
 363   if (ref $self) {
 364     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 365     my $ident_cond = $self->ident_condition;
 366     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 367       if ! keys %$ident_cond;
 368     foreach my $column (keys %$ident_cond) {
 369             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 370               unless exists $self->{_column_data}{$column};
 371     }
 372     $self->result_source->storage->delete(
 373       $self->result_source, $ident_cond);
 374     $self->in_storage(undef);
 375   } else {
 376     $self->throw_exception("Can't do class delete without a ResultSource instance")
 377       unless $self->can('result_source_instance');
 378     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 379     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 380     $self->result_source_instance->resultset->search(@_)->delete;
 381   }
 382   return $self;
 383 }
 384
 385 =head2 get_column
 386
 387   my $val = $obj->get_column($col);
 388
 389 Gets a column value from a row object. Does not do any queries; the column
 390 must have already been fetched from the database and stored in the object. If
 391 there is an inflated value stored that has not yet been deflated, it is deflated
 392 when the method is invoked.
 393
 394 =cut
 395
 396 sub get_column {
 397   my ($self, $column) = @_;
 398   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 399   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 400   if (exists $self->{_inflated_column}{$column}) {
 401     return $self->store_column($column,
 402       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 403   }
 404   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 405   return undef;
 406 }
 407
 408 =head2 has_column_loaded
 409
 410   if ( $obj->has_column_loaded($col) ) {
 411      print "$col has been loaded from db";
 412   }
 413
 414 Returns a true value if the column value has been loaded from the
 415 database (or set locally).
 416
 417 =cut
 418
 419 sub has_column_loaded {
 420   my ($self, $column) = @_;
 421   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 422   return 1 if exists $self->{_inflated_column}{$column};
 423   return exists $self->{_column_data}{$column};
 424 }
 425
 426 =head2 get_columns
 427
 428   my %data = $obj->get_columns;
 429
 430 Does C<get_column>, for all column values at once.
 431
 432 =cut
 433
 434 sub get_columns {
 435   my $self = shift;
 436   if (exists $self->{_inflated_column}) {
 437     foreach my $col (keys %{$self->{_inflated_column}}) {
 438       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 439         unless exists $self->{_column_data}{$col};
 440     }
 441   }
 442   return %{$self->{_column_data}};
 443 }
 444
 445 =head2 get_dirty_columns
 446
 447   my %data = $obj->get_dirty_columns;
 448
 449 Identical to get_columns but only returns those that have been changed.
 450
 451 =cut
 452
 453 sub get_dirty_columns {
 454   my $self = shift;
 455   return map { $_ => $self->{_column_data}{$_} }
 456            keys %{$self->{_dirty_columns}};
 457 }
 458
 459 =head2 get_inflated_columns
 460
 461   my $inflated_data = $obj->get_inflated_columns;
 462
 463 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
 464
 465 =cut
 466
 467 sub get_inflated_columns {
 468   my $self = shift;
 469   return map {
 470     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 471     ($_ => $self->$accessor);
 472   } $self->columns;
 473 }
 474
 475 =head2 set_column
 476
 477   $obj->set_column($col => $val);
 478
 479 Sets a column value. If the new value is different from the old one,
 480 the column is marked as dirty for when you next call $obj->update.
 481
 482 =cut
 483
 484 sub set_column {
 485   my $self = shift;
 486   my ($column) = @_;
 487   $self->{_orig_ident} ||= $self->ident_condition;
 488   my $old = $self->get_column($column);
 489   my $ret = $self->store_column(@_);
 490   $self->{_dirty_columns}{$column} = 1
 491     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 492   return $ret;
 493 }
 494
 495 =head2 set_columns
 496
 497   my $copy = $orig->set_columns({ $col => $val, ... });
 498
 499 Sets more than one column value at once.
 500
 501 =cut
 502
 503 sub set_columns {
 504   my ($self,$data) = @_;
 505   foreach my $col (keys %$data) {
 506     $self->set_column($col,$data->{$col});
 507   }
 508   return $self;
 509 }
 510
 511 =head2 copy
 512
 513   my $copy = $orig->copy({ change => $to, ... });
 514
 515 Inserts a new row with the specified changes.
 516
 517 =cut
 518
 519 sub copy {
 520   my ($self, $changes) = @_;
 521   $changes ||= {};
 522   my $col_data = { %{$self->{_column_data}} };
 523   foreach my $col (keys %$col_data) {
 524     delete $col_data->{$col}
 525       if $self->result_source->column_info($col)->{is_auto_increment};
 526   }
 527
 528   my $new = { _column_data => $col_data };
 529   bless $new, ref $self;
 530
 531   $new->result_source($self->result_source);
 532   $new->set_columns($changes);
 533   $new->insert;
 534
 535   # Its possible we'll have 2 relations to the same Source. We need to make
 536   # sure we don't try to insert the same row twice esle we'll violate unique
 537   # constraints
 538   my $rels_copied = {};
 539
 540   foreach my $rel ($self->result_source->relationships) {
 541     my $rel_info = $self->result_source->relationship_info($rel);
 542
 543     next unless $rel_info->{attrs}{cascade_copy};
 544
 545     my $resolved = $self->result_source->resolve_condition(
 546       $rel_info->{cond}, $rel, $new
 547     );
 548
 549     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 550     foreach my $related ($self->search_related($rel)) {
 551       my $id_str = join("\0", $related->id);
 552       next if $copied->{$id_str};
 553       $copied->{$id_str} = 1;
 554       my $rel_copy = $related->copy($resolved);
 555     }
 556
 557   }
 558   return $new;
 559 }
 560
 561 =head2 store_column
 562
 563   $obj->store_column($col => $val);
 564
 565 Sets a column value without marking it as dirty.
 566
 567 =cut
 568
 569 sub store_column {
 570   my ($self, $column, $value) = @_;
 571   $self->throw_exception( "No such column '${column}'" )
 572     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 573   $self->throw_exception( "set_column called for ${column} without value" )
 574     if @_ < 3;
 575   return $self->{_column_data}{$column} = $value;
 576 }
 577
 578 =head2 inflate_result
 579
 580   Class->inflate_result($result_source, \%me, \%prefetch?)
 581
 582 Called by ResultSet to inflate a result from storage
 583
 584 =cut
 585
 586 sub inflate_result {
 587   my ($class, $source, $me, $prefetch) = @_;
 588
 589   my ($source_handle) = $source;
 590
 591   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 592       $source = $source_handle->resolve
 593   } else {
 594       $source_handle = $source->handle
 595   }
 596
 597   my $new = {
 598     _source_handle => $source_handle,
 599     _column_data => $me,
 600     _in_storage => 1
 601   };
 602   bless $new, (ref $class || $class);
 603
 604   my $schema;
 605   foreach my $pre (keys %{$prefetch||{}}) {
 606     my $pre_val = $prefetch->{$pre};
 607     my $pre_source = $source->related_source($pre);
 608     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 609       unless $pre_source;
 610     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 611       my @pre_objects;
 612       foreach my $pre_rec (@$pre_val) {
 613         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 614            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 615           next;
 616         }
 617         push(@pre_objects, $pre_source->result_class->inflate_result(
 618                              $pre_source, @{$pre_rec}));
 619       }
 620       $new->related_resultset($pre)->set_cache(\@pre_objects);
 621     } elsif (defined $pre_val->[0]) {
 622       my $fetched;
 623       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 624          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 625       {
 626         $fetched = $pre_source->result_class->inflate_result(
 627                       $pre_source, @{$pre_val});
 628       }
 629       $new->related_resultset($pre)->set_cache([ $fetched ]);
 630       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 631       $class->throw_exception("No accessor for prefetched $pre")
 632        unless defined $accessor;
 633       if ($accessor eq 'single') {
 634         $new->{_relationship_data}{$pre} = $fetched;
 635       } elsif ($accessor eq 'filter') {
 636         $new->{_inflated_column}{$pre} = $fetched;
 637       } else {
 638        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 639       }
 640     }
 641   }
 642   return $new;
 643 }
 644
 645 =head2 update_or_insert
 646
 647   $obj->update_or_insert
 648
 649 Updates the object if it's already in the db, else inserts it.
 650
 651 =head2 insert_or_update
 652
 653   $obj->insert_or_update
 654
 655 Alias for L</update_or_insert>
 656
 657 =cut
 658
 659 *insert_or_update = \&update_or_insert;
 660 sub update_or_insert {
 661   my $self = shift;
 662   return ($self->in_storage ? $self->update : $self->insert);
 663 }
 664
 665 =head2 is_changed
 666
 667   my @changed_col_names = $obj->is_changed();
 668   if ($obj->is_changed()) { ... }
 669
 670 In array context returns a list of columns with uncommited changes, or
 671 in scalar context returns a true value if there are uncommitted
 672 changes.
 673
 674 =cut
 675
 676 sub is_changed {
 677   return keys %{shift->{_dirty_columns} || {}};
 678 }
 679
 680 =head2 is_column_changed
 681
 682   if ($obj->is_column_changed('col')) { ... }
 683
 684 Returns a true value if the column has uncommitted changes.
 685
 686 =cut
 687
 688 sub is_column_changed {
 689   my( $self, $col ) = @_;
 690   return exists $self->{_dirty_columns}->{$col};
 691 }
 692
 693 =head2 result_source
 694
 695   my $resultsource = $object->result_source;
 696
 697 Accessor to the ResultSource this object was created from
 698
 699 =cut
 700
 701 sub result_source {
 702     my $self = shift;
 703
 704     if (@_) {
 705         $self->_source_handle($_[0]->handle);
 706     } else {
 707         $self->_source_handle->resolve;
 708     }
 709 }
 710
 711 =head2 register_column
 712
 713   $column_info = { .... };
 714   $class->register_column($column_name, $column_info);
 715
 716 Registers a column on the class. If the column_info has an 'accessor'
 717 key, creates an accessor named after the value if defined; if there is
 718 no such key, creates an accessor with the same name as the column
 719
 720 The column_info attributes are described in
 721 L<DBIx::Class::ResultSource/add_columns>
 722
 723 =cut
 724
 725 sub register_column {
 726   my ($class, $col, $info) = @_;
 727   my $acc = $col;
 728   if (exists $info->{accessor}) {
 729     return unless defined $info->{accessor};
 730     $acc = [ $info->{accessor}, $col ];
 731   }
 732   $class->mk_group_accessors('column' => $acc);
 733 }
 734
 735
 736 =head2 throw_exception
 737
 738 See Schema's throw_exception.
 739
 740 =cut
 741
 742 sub throw_exception {
 743   my $self=shift;
 744   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 745     $self->result_source->schema->throw_exception(@_);
 746   } else {
 747     croak(@_);
 748   }
 749 }
 750
 751 1;
 752
 753 =head1 AUTHORS
 754
 755 Matt S. Trout <mst@shadowcatsystems.co.uk>
 756
 757 =head1 LICENSE
 758
 759 You may distribute this code under the same terms as Perl itself.
 760
 761 =cut