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