lib/DBIx/Class/Row.pm

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