Throw/lib/Throw.pm
package Throw;
use strict;
use warnings;
require 5.8.8;
use overload '""' => \&_str, fallback => 1;
=head1 NAME
Throw - Simple exceptions that do the right things in multiple contexts
=cut
our (@EXPORT, $trace, $level, $pretty, $js, $jp) = ('throw');
our $VERSION = '0.13'; #VERSION
sub import {
no strict 'refs'; ## no critic
my ($me, $you, $f, $l) = (shift, caller); @_ = @{"$me\::EXPORT"} if !@_;
defined &{"$me\::$_"} ? *{"$you\::$_"} = \&{"$me\::$_"} : die "Cannot export $_ from $me to $you at $f line $l.\n" for @_;
}
sub throw {
my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
$args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
die bless $args, __PACKAGE__;
}
sub new {
my $class = shift;
my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
$args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
return bless $args, $class;
}
sub croak { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(1, ($_[2]||0)+1); die bless $a, __PACKAGE__ }
sub carp { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(1, ($_[2]||0)+1); warn bless $a, __PACKAGE__ }
sub confess { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(2, $_[2]); die bless $a, __PACKAGE__ }
sub cluck { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(2, $_[2]); warn bless $a, __PACKAGE__ }
sub _str {
my $self = shift;
my $err = $self->{'error'} || "Something happened";
my $p = defined($pretty) ? $pretty : $self->{'_pretty'};
local @$self{'error','_pretty'}; delete @$self{'error','_pretty'};
return "$err\n" if !scalar keys %$self;
require JSON;
my $j = $p ? $jp ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical->pretty
: $js ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical;
return "$err: ".$j->encode({%$self}).($p ? '' : "\n");
}
sub caller_trace {
my $args = ref($_[0]) ? $_[0] : (!$_[0] || $_[0] !~ /^[123]$/) ? return $_[0]: {verbose => $_[0], level => $_[1]};
my $i = ($level || $_[1] || $args->{'level'} || 0) + 1;
return sprintf "Called from %s at %s line %s", (caller $i+1)[3]||'main', map{(my$s=$_)=~s|^(?:.+/)?lib/||;$s} (caller $i)[1,2] if $args->{'verbose'} && $args->{'verbose'} eq '1';
my ($m1, $m2, $m3, $nv, @trace) = (0, 0, 0, eval {require 5.014} ? ($args->{'verbose'} || '') ne '3' : 1);
while (1) {
my ($pkg, $file, $line, $sub, $sargs) = $nv ? ((caller $i++)[0..3], [])
: do { package DB; local $DB::args[0] = \$nv; ((caller $i++)[0..3], ($DB::args[0]||'') ne \$nv ? [@DB::args] : []) };
last if ! $sargs;
$sub =~ s/.*://; $file =~ s|^(?:.+/)?lib/||;
next if ($file eq __FILE__) || $args->{'skip'}->{$file} || $args->{'skip'}->{$pkg} || $args->{'skip'}->{$sub};
splice @$sargs, $args->{'max_args'}, -1, '...' if @$sargs > ($args->{'max_args'} ||= 5);
my $args = (!@$sargs || $i==2 && $sub eq 'throw') ? ''
: ' ('.join(', ',map{
my$d=!defined($_)?'undef':ref($_)||!/\D/?$_:do{(my$c=$_)=~s|([\'/])|\\$1|g;"'$c'"};
substr($d,0,$args->{'max_arg_len'}||20)
} @$sargs).')';
$m1 = length $sub if length($sub) > $m1;
$m2 = length $file if length($file) > $m2;
$m3 = length $line if length($line) > $m3;
push @trace, [$sub, $file, $line, $args];
}
return join "\n", map {sprintf "%-${m1}s at %-${m2}s line %${m3}s%s", @$_} @trace;
}
sub TO_JSON { return {%{$_[0]}} }
sub classify {
my ($err, $ref) = @_;
$ref = {$ref => 1} if ! ref $ref;
my $type = !ref($err) ? 'undef.flat' : defined($err->{'type'}) ? $err->{'type'} : 'undef.none';
my @keys = grep {$_ ne 'default'} keys %$ref;
@keys = sort {length($b) <=> length($a) || $a cmp $b} @keys if @keys > 1;
foreach my $key (@keys) {
next if $type !~ /^\Q$key\E\b(?:$|\.)/;
my $val = $ref->{$key};
return ref($val) ? $val->($err, $key) : $val;
}
return if ! exists $ref->{'default'};
my $val = $ref->{'default'};
return ref($val) ? $val->($err, 'default') : $val;
}
1;
__END__
=head1 SYNOPSIS
use Throw qw(throw);
throw "Hey";
throw "Hey", {info => "This is why"};
throw "Hey", {trace => 1}; # simple trace
throw "Hey", {trace => 2}; # full trace without args
throw "Hey", {trace => 3}; # full trace with args
use Throw qw(croak confess carp);
croak "Hey"; # same as throw with {trace => 1}, 1
confess "Hey"; # same as throw with {trace => 2}
carp "Hey"; # warns from perspective of caller
warn Throw->new("Hey"); # useful for some cases
use Throw qw(throw classify);
if (classify my $err = $@, "io") {
throw "Got a disk error", {msg => $err};
}
=head1 DESCRIPTION
Throw allows for light weight exceptions that can hold more
information than just the error message. These exceptions do the
right thing when thrown on the commandline, or when consumed by
javascript based APIs.
=head1 METHODS
=over 4
=item throw
Takes an error message, an error message and extra arguments, or a
hashref.
If a hashref is passed, it should contain a key named error
representing the error. If not, a string "Something happened" will be
used instead. If an arguments hashref is passed, the error message
will be added to it. If just an error message is passed, a hashref
will be created with the error as the single key.
In all cases, throw returns an hashref based object blessed into the
Throw class. When an error message is passed independently.
If a key of "trace" is passed, its value will be passed to the
caller_trace subroutine and the result will be stored as the value of
trace.
An optional 3rd parameter can be passed which will be used as the "level"
for any stack traces performed.
=item new
Similar to throw call. Useful for some cases.
=item croak
Gives a trace from the perspective of the caller.
Similar to throw - but with trace => 1 instead. (passing a single hashref is not allowed)
Single level stack trace.
=item confess
Similar to throw - but with trace => 2 instead. (passing a single hashref is not allowed)
Full stack trace.
=item carp
Gives a trace from the perspective of the caller.
Similar to throw but only warns with trace => 1.
=item cluck
Similar to throw but only warns with trace => 2.
=item caller_trace
Returns stack traces. Takes parameters in a few different ways.
caller_trace(); # {level => 0, verbose => 2}
caller_trace(1); # {level => 0, verbose => 1}
caller_trace(2); # {level => 0, verbose => 2}
caller_trace(3); # {level => 0, verbose => 3}
caller_trace(undef, 3); # {level => 3, verbose => 1}
caller_trace(1, 4); # {level => 4, verbose => 1}
caller_trace(2, 2); # {level => 2, verbose => 2}
caller_trace({level => 1}); # {level => 1, verbose => 2}
caller_trace({level => 1, verbose => 3}); # {level => 1, verbose => 3}
The "level" argument represents how many stack frames to skip
backwards.
The "verbose" argument can be one of 1, 2, or 3. Default 2. At level
1 you get a single line of trace. With level 2 you get the full stack
trace. With level 3 you get the full stack trace with function
arguments.
The "max_args" argument shows how many parameters to each level will
be represented. If there are more an "..." will be shown. Default is
5.
The "max_arg_len" argument shows where parameters will be truncated.
Default is 20.
The "skip" argument can be a hashref with keys of packages, files, or
subs that should be excluded from the trace.
=item classify
Allows for cleanly and safely classifying the types of errors received
assuming you use {type => 'error_type'} for specifying your error
hierarchy. Classify takes an error (such as from $@), and a hashref
used to classify the error. Each of the keys of the hashref will be
checked against the type of the error. The classification keys are
checked based on hierarchy - so a key of "foo" will match an error
type of "foo" as well as "foo.bar", "foo.baz", and "foo.bar.baz". A
key of "foo.bar" would match "foo.bar" and "foo.bar.baz" but not
"foo".
You may also pass a key named "default" to handle any cases not
matched by other keys.
Some errors passed to classify may not have been given a type
property, and some may not even have been blessed or come from the
Throw system. Any unblessed errors will receive use a type of
"undef.flat" and any other errors that do not have a type attribute
will use "undef.none" for the type.
use Throw qw(throw classify);
use Try::Tiny qw(try catch);
try {
throw "No-no", {type => 'foo.bar'};
} catch {
classify $_, {
foo => sub { print "I got foo\n" },
'foo.bar' => sub { print "I got foo.bar\n" },
default => sub { throw "Don't know what I got", {msg => $_[0]} }
};
}
# also
if (classify $@, "foo") {
print "I got a foo\n";
}
=back
=head1 GLOBALS
There are also a few package globals that can make tracking down culprits easier.
=over 4
=item $trace
Turn on traces globally - can be any of the normal values passed to trace
=item $level
Set the level at which to trace.
=item $pretty
Allow all json error stringification to use pretty. You can also set _pretty => 1 in
individual errors, but sometimes you won't have access to the error object before
it stringifies.
=item TO_JSON
JSONifies the error.
=back
=head1 AUTHORS
Paul Seamons <rhandom@cpan.org>, Jason Terry <oaxlin@cpan.org>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2013, 2014, Bluehost.com.
This module is free software; you can redistribute it and/or modify it under the same terms as
Perl itself, either version 5.8.1 or any later version. See L<perlartistic|perlartistic>
and L<perlgpl|perlgpl>.
The full text of the license can be found in the LICENSE file included with this module.