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