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