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