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() if(!$obj->in_storage);
 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   foreach my $rel ($self->result_source->relationships) {
 536     my $rel_info = $self->result_source->relationship_info($rel);
 537     if ($rel_info->{attrs}{cascade_copy}) {
 538       my $resolved = $self->result_source->resolve_condition(
 539        $rel_info->{cond}, $rel, $new);
 540       foreach my $related ($self->search_related($rel)) {
 541         $related->copy($resolved);
 542       }
 543     }
 544   }
 545   return $new;
 546 }
 547
 548 =head2 store_column
 549
 550   $obj->store_column($col => $val);
 551
 552 Sets a column value without marking it as dirty.
 553
 554 =cut
 555
 556 sub store_column {
 557   my ($self, $column, $value) = @_;
 558   $self->throw_exception( "No such column '${column}'" )
 559     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 560   $self->throw_exception( "set_column called for ${column} without value" )
 561     if @_ < 3;
 562   return $self->{_column_data}{$column} = $value;
 563 }
 564
 565 =head2 inflate_result
 566
 567   Class->inflate_result($result_source, \%me, \%prefetch?)
 568
 569 Called by ResultSet to inflate a result from storage
 570
 571 =cut
 572
 573 sub inflate_result {
 574   my ($class, $source, $me, $prefetch) = @_;
 575
 576   my ($source_handle) = $source;
 577
 578   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 579       $source = $source_handle->resolve
 580   } else {
 581       $source_handle = $source->handle
 582   }
 583
 584   my $new = {
 585     _source_handle => $source_handle,
 586     _column_data => $me,
 587     _in_storage => 1
 588   };
 589   bless $new, (ref $class || $class);
 590
 591   my $schema;
 592   foreach my $pre (keys %{$prefetch||{}}) {
 593     my $pre_val = $prefetch->{$pre};
 594     my $pre_source = $source->related_source($pre);
 595     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 596       unless $pre_source;
 597     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 598       my @pre_objects;
 599       foreach my $pre_rec (@$pre_val) {
 600         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 601            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 602           next;
 603         }
 604         push(@pre_objects, $pre_source->result_class->inflate_result(
 605                              $pre_source, @{$pre_rec}));
 606       }
 607       $new->related_resultset($pre)->set_cache(\@pre_objects);
 608     } elsif (defined $pre_val->[0]) {
 609       my $fetched;
 610       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 611          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 612       {
 613         $fetched = $pre_source->result_class->inflate_result(
 614                       $pre_source, @{$pre_val});
 615       }
 616       $new->related_resultset($pre)->set_cache([ $fetched ]);
 617       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 618       $class->throw_exception("No accessor for prefetched $pre")
 619        unless defined $accessor;
 620       if ($accessor eq 'single') {
 621         $new->{_relationship_data}{$pre} = $fetched;
 622       } elsif ($accessor eq 'filter') {
 623         $new->{_inflated_column}{$pre} = $fetched;
 624       } else {
 625        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 626       }
 627     }
 628   }
 629   return $new;
 630 }
 631
 632 =head2 update_or_insert
 633
 634   $obj->update_or_insert
 635
 636 Updates the object if it's already in the db, else inserts it.
 637
 638 =head2 insert_or_update
 639
 640   $obj->insert_or_update
 641
 642 Alias for L</update_or_insert>
 643
 644 =cut
 645
 646 *insert_or_update = \&update_or_insert;
 647 sub update_or_insert {
 648   my $self = shift;
 649   return ($self->in_storage ? $self->update : $self->insert);
 650 }
 651
 652 =head2 is_changed
 653
 654   my @changed_col_names = $obj->is_changed();
 655   if ($obj->is_changed()) { ... }
 656
 657 In array context returns a list of columns with uncommited changes, or
 658 in scalar context returns a true value if there are uncommitted
 659 changes.
 660
 661 =cut
 662
 663 sub is_changed {
 664   return keys %{shift->{_dirty_columns} || {}};
 665 }
 666
 667 =head2 is_column_changed
 668
 669   if ($obj->is_column_changed('col')) { ... }
 670
 671 Returns a true value if the column has uncommitted changes.
 672
 673 =cut
 674
 675 sub is_column_changed {
 676   my( $self, $col ) = @_;
 677   return exists $self->{_dirty_columns}->{$col};
 678 }
 679
 680 =head2 result_source
 681
 682   my $resultsource = $object->result_source;
 683
 684 Accessor to the ResultSource this object was created from
 685
 686 =cut
 687
 688 sub result_source {
 689     my $self = shift;
 690
 691     if (@_) {
 692         $self->_source_handle($_[0]->handle);
 693     } else {
 694         $self->_source_handle->resolve;
 695     }
 696 }
 697
 698 =head2 register_column
 699
 700   $column_info = { .... };
 701   $class->register_column($column_name, $column_info);
 702
 703 Registers a column on the class. If the column_info has an 'accessor'
 704 key, creates an accessor named after the value if defined; if there is
 705 no such key, creates an accessor with the same name as the column
 706
 707 The column_info attributes are described in
 708 L<DBIx::Class::ResultSource/add_columns>
 709
 710 =cut
 711
 712 sub register_column {
 713   my ($class, $col, $info) = @_;
 714   my $acc = $col;
 715   if (exists $info->{accessor}) {
 716     return unless defined $info->{accessor};
 717     $acc = [ $info->{accessor}, $col ];
 718   }
 719   $class->mk_group_accessors('column' => $acc);
 720 }
 721
 722
 723 =head2 throw_exception
 724
 725 See Schema's throw_exception.
 726
 727 =cut
 728
 729 sub throw_exception {
 730   my $self=shift;
 731   if (ref $self && ref $self->result_source && $self->result_source->schema) {
 732     $self->result_source->schema->throw_exception(@_);
 733   } else {
 734     croak(@_);
 735   }
 736 }
 737
 738 1;
 739
 740 =head1 AUTHORS
 741
 742 Matt S. Trout <mst@shadowcatsystems.co.uk>
 743
 744 =head1 LICENSE
 745
 746 You may distribute this code under the same terms as Perl itself.
 747
 748 =cut