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