exception objects to make stacktrace work right (!!)

diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm
new file mode 100644 (file)
index 0000000..83e0255
--- /dev/null
+++ b/lib/DBIx/Class/Exception.pm
@@ -0,0 +1,81 @@
+package DBIx::Class::Exception;
+
+use strict;
+use warnings;
+
+use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util qw/blessed/;
+
+use overload
+    '""' => sub { shift->{msg} },
+    fallback => 1;
+
+=head1 NAME
+
+DBIx::Class::Exception - Exception objects for DBIx::Class
+
+=head1 DESCRIPTION
+
+Exception objects of this class are used in internally by
+he default error handling of L<DBIx::Class::Schema/throw_exception>
+to prevent confusing and/or redundant re-application of L<Carp>'s
+stack trace information.
+
+These objects stringify to the contained error message, and use
+overload fallback to give natural boolean/numeric values.
+
+=head1 METHODS
+
+=head2 throw
+
+=over 4
+
+=item Arguments: $exception_scalar, $stacktrace
+
+=back
+
+This is meant for internal use by L<DBIx::Class>'s C<throw_exception>
+code, and shouldn't be used directly elsewhere.
+
+Expects a scalar exception message.  The optional argument
+C<$stacktrace> tells it to use L<Carp/longmess> instead of
+L<Carp::Clan/croak>.
+
+  DBIx::Class::Exception->throw('Foo');
+  eval { ... }; DBIx::Class::Exception->throw($@) if $@;
+
+=cut
+
+sub throw {
+    my ($class, $msg, $stacktrace) = @_;
+
+    # Don't re-encapsulate multiple times
+    die $msg if blessed($msg) && $msg->isa('DBIx::Class::Exception');
+
+    # use Carp::Clan's croak if we're not stack tracing
+    if(!$stacktrace) {
+        local $@;
+        eval { croak $msg };
+        $msg = $@
+    }
+    else {
+        $msg = Carp::longmess($msg);
+    }
+    
+    my $self = { msg => $msg };
+    bless $self => $class;
+
+    die $self;
+}
+
+=head1 AUTHORS
+
+Brandon L. Black <blblack@gmail.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index fa26110..e53d115 100644 (file)
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -3,6 +3,7 @@ package DBIx::Class::Schema;
 use strict;
 use warnings;
 
+use DBIx::Class::Exception;
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util qw/weaken/;
 use File::Spec;
@@ -894,9 +895,8 @@ Example:
 
 =back
 
-This alters the behavior of the default L</throw_exception> action.  It
-uses C<croak> if C<stacktrace> is false, or C<confess> if C<stacktrace>
-is true.  The default is false.
+Whether L</throw_exception> should include stack trace information.
+Defaults to false.
 
 =head2 throw_exception
 
@@ -909,15 +909,15 @@ is true.  The default is false.
 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 user's perspective.  See L</exception_action> for details on overriding
 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>
-will use C<confess> instead of C<croak>.
+will provide a detailed stack trace.
 
 =cut
 
 sub throw_exception {
   my $self = shift;
-  if(!$self->exception_action || !$self->exception_action->(@_)) {
-    $self->stacktrace ? confess @_ : croak @_;
-  }
+
+  DBIx::Class::Exception->throw($_[0], $self->stacktrace)
+    if !$self->exception_action || !$self->exception_action->(@_);
 }
 
 =head2 deploy (EXPERIMENTAL)