#!/usr/bin/perl -c
use 5.006;
our $VERSION = '0.2501';
BEGIN {
eval {
Symbol::qualify_to_ref('Symbol::qualify_to_ref');
};
if (not $@) {
*_qualify_to_ref = \*Symbol::qualify_to_ref;
}
else {
*_qualify_to_ref = sub ($;) { no strict 'refs'; \*{ $_[0] } };
};
};
BEGIN {
eval {
my $ref = \1;
Scalar::Util::weaken($ref);
};
if (not $@) {
*_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 1 };
}
else {
*_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 0 };
};
};
BEGIN {
my %OVERLOADS = (fallback => 1);
$OVERLOADS{'bool'} = 'to_bool';
$OVERLOADS{'0+'} = 'to_number';
$OVERLOADS{'""'} = 'to_string';
$OVERLOADS{'~~'} = 'matches' if ($] >= 5.010);
overload->import(%OVERLOADS);
};
use constant _RE_NUM_INT => qr/^[+-]?\d+$/;
BEGIN {
my %ATTRS = ();
$ATTRS{message} = { is => 'rw', default => 'Unknown exception' };
$ATTRS{value} = { is => 'rw', default => 0 };
$ATTRS{verbosity} = { is => 'rw', default => 2 };
$ATTRS{ignore_package} = { is => 'rw', default => [ ] };
$ATTRS{ignore_class} = { is => 'rw', default => [ ] };
$ATTRS{ignore_level} = { is => 'rw', default => 0 };
$ATTRS{time} = { is => 'ro' };
$ATTRS{pid} = { is => 'ro' };
$ATTRS{tid} = { is => 'ro' };
$ATTRS{uid} = { is => 'ro' };
$ATTRS{euid} = { is => 'ro' };
$ATTRS{gid} = { is => 'ro' };
$ATTRS{egid} = { is => 'ro' };
$ATTRS{caller_stack} = { is => 'ro' };
$ATTRS{propagated_stack} = { is => 'ro' };
$ATTRS{max_arg_len} = { is => 'rw', default => 64 };
$ATTRS{max_arg_nums} = { is => 'rw', default => 8 };
$ATTRS{max_eval_len} = { is => 'rw', default => 0 };
$ATTRS{defaults} = { };
$ATTRS{default_attribute} = { default => 'message' };
$ATTRS{numeric_attribute} = { default => 'value' };
$ATTRS{eval_attribute} = { default => 'message' };
$ATTRS{string_attributes} = { default => [ 'message' ] };
*ATTRS = sub () { \%ATTRS };
};
my %Class_Attributes;
my %Class_Defaults;
my %Isa_Package;
sub import {
my $class = shift;
while (defined $_[0]) {
my $name = shift @_;
if ($name eq ':all') {
}
elsif ($name =~ /^([+-]?)([a-z0-9_]+)$/) {
my ($modifier, $key) = ($1, $2);
my $value = shift;
$class->_modify_default($key, $value, $modifier);
}
else {
my $param = {};
$param = shift @_ if defined $_[0] and ref $_[0] eq 'HASH';
my $version = defined $param->{version} ? $param->{version} : 0;
if (caller ne $name) {
next if eval { $name->VERSION($version) };
{
local $SIG{__DIE__};
eval {
$class->_load_package($name, $version);
};
};
if ($@) {
if ($@ !~ /Can\'t locate/) {
Exception::Base->throw(
message => ["Can not load available %s class: %s", $name, $@],
verbosity => 1
);
};
}
else {
next;
};
};
next if $name eq __PACKAGE__;
if ($class ne __PACKAGE__) {
Exception::Base->throw(
message => ["Exceptions can only be created with %s class", __PACKAGE__],
verbosity => 1
);
};
$class->_make_exception($name, $version, $param);
}
}
return $class;
};
sub new {
my ($self, %args) = @_;
my $class = ref $self || $self;
my $attributes;
my $defaults;
if (not defined $Class_Attributes{$class}) {
$attributes = $Class_Attributes{$class} = $class->ATTRS;
$defaults = $Class_Defaults{$class} = {
map { $_ => $attributes->{$_}->{default} }
grep { defined $attributes->{$_}->{default} }
(keys %$attributes)
};
}
else {
$attributes = $Class_Attributes{$class};
$defaults = $Class_Defaults{$class};
};
my $e = {};
no warnings 'uninitialized';
foreach my $key (keys %args) {
if ($attributes->{$key}->{is} eq 'rw') {
$e->{$key} = $args{$key};
};
};
$e->{defaults} = { %$defaults };
bless $e => $class;
$e->_collect_system_data;
return $e;
};
sub throw {
my $self = shift;
my $class = ref $self || $self;
my $old_e;
if (not ref $self) {
if (not ref $_[0]) {
if (scalar @_ % 2 == 0) {
die $self->new(@_);
}
else {
my $argument = shift;
my $e = $self->new(@_);
my $default_attribute = $e->{defaults}->{default_attribute};
$e->{$default_attribute} = $argument if not defined $e->{$default_attribute};
die $e;
};
}
else {
$old_e = shift;
};
}
else {
$old_e = $self;
};
no warnings 'uninitialized';
my %args = @_;
my $attrs = $old_e->ATTRS;
foreach my $key (keys %args) {
if ($attrs->{$key}->{is} eq 'rw') {
$old_e->{$key} = $args{$key};
};
};
$old_e->PROPAGATE;
if (ref $old_e ne $class) {
bless $old_e => $class;
};
die $old_e;
};
sub catch {
my ($self) = @_;
my $class = ref $self || $self;
my $e;
my $new_e;
if (@_ > 1) {
$e = $_[1];
}
else {
$e = $@;
$@ = '';
};
if (ref $e and do { local $@; local $SIG{__DIE__}; eval { $e->isa(__PACKAGE__) } }) {
$new_e = $e;
}
elsif ($e eq '') {
$new_e = undef;
}
else {
while ($e =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { };
$e =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s;
$new_e = $class->new;
my $eval_attribute = $new_e->{defaults}->{eval_attribute};
$new_e->{$eval_attribute} = $e;
};
return $new_e;
};
sub matches {
my ($self, $that) = @_;
my @args;
my $default_attribute = $self->{defaults}->{default_attribute};
my $numeric_attribute = $self->{defaults}->{numeric_attribute};
if (ref $that eq 'ARRAY') {
@args = ( '-isa' => $that );
}
elsif (ref $that eq 'HASH') {
@args = %$that;
}
elsif (ref $that eq 'Regexp' or ref $that eq 'CODE' or not defined $that) {
@args = ( $that );
}
elsif (ref $that) {
return '';
}
elsif ($that =~ _RE_NUM_INT) {
@args = ( $numeric_attribute => $that );
}
else {
@args = ( $that );
};
return '' unless @args;
if (scalar @args % 2 == 1) {
my $val = shift @args;
if (ref $val eq 'ARRAY') {
my $arrret = 0;
foreach my $arrval (@{ $val }) {
if (not defined $arrval) {
$arrret = 1 if not $self->_string_attributes;
}
elsif (not ref $arrval and $arrval =~ _RE_NUM_INT) {
no warnings 'numeric', 'uninitialized';
$arrret = 1 if $self->{$numeric_attribute} == $arrval;
}
elsif (not $self->_string_attributes) {
next;
}
else {
local $_ = join ': ', $self->_string_attributes;
if (ref $arrval eq 'CODE') {
$arrret = 1 if $arrval->();
}
elsif (ref $arrval eq 'Regexp') {
$arrret = 1 if /$arrval/;
}
else {
$arrret = 1 if $_ eq $arrval;
};
};
last if $arrret;
};
return '' if not $arrret;
}
elsif (not defined $val) {
return '' if $self->_string_attributes;
}
elsif (not ref $val and $val =~ _RE_NUM_INT) {
no warnings 'numeric', 'uninitialized';
return '' if $self->{$numeric_attribute} != $val;
}
elsif (not $self->_string_attributes) {
return '';
}
else {
local $_ = join ': ', $self->_string_attributes;
if (ref $val eq 'CODE') {
return '' if not $val->();
}
elsif (ref $val eq 'Regexp') {
return '' if not /$val/;
}
else {
return '' if $_ ne $val;
};
};
return 1 unless @args;
};
my %args = @args;
while (my($key,$val) = each %args) {
if ($key eq '-default') {
$key = $default_attribute;
};
if ($key eq '-isa') {
if (ref $val eq 'ARRAY') {
my $arrret = 0;
foreach my $arrval (@{ $val }) {
next if not defined $arrval;
$arrret = 1 if $self->isa($arrval);
last if $arrret;
};
return '' if not $arrret;
}
else {
return '' if not $self->isa($val);
};
}
elsif ($key eq '-has') {
if (ref $val eq 'ARRAY') {
my $arrret = 0;
foreach my $arrval (@{ $val }) {
next if not defined $arrval;
$arrret = 1 if exists $self->ATTRS->{$arrval};
last if $arrret;
};
return '' if not $arrret;
}
else {
return '' if not $self->ATTRS->{$val};
};
}
elsif (ref $val eq 'ARRAY') {
my $arrret = 0;
foreach my $arrval (@{ $val }) {
if (not defined $arrval) {
$arrret = 1 if not defined $self->{$key};
}
elsif (not defined $self->{$key}) {
next;
}
else {
local $_ = ref $self->{$key} eq 'ARRAY'
? sprintf(
@{$self->{$key}}[0],
@{$self->{$key}}[1..$
)
: $self->{$key};
if (ref $arrval eq 'CODE') {
$arrret = 1 if $arrval->();
}
elsif (ref $arrval eq 'Regexp') {
$arrret = 1 if /$arrval/;
}
else {
$arrret = 1 if $_ eq $arrval;
};
};
last if $arrret;
};
return '' if not $arrret;
}
elsif (not defined $val) {
return '' if exists $self->{$key} && defined $self->{$key};
}
elsif (not ref $val and $val =~ _RE_NUM_INT) {
no warnings 'numeric', 'uninitialized';
return '' if $self->{$key} != $val;
}
elsif (not defined $self->{$key}) {
return '';
}
else {
local $_ = ref $self->{$key} eq 'ARRAY'
? sprintf(
@{$self->{$key}}[0],
@{$self->{$key}}[1..$
)
: $self->{$key};
if (ref $val eq 'CODE') {
return '' if not $val->();
}
elsif (ref $val eq 'Regexp') {
return '' if not /$val/;
}
else {
return '' if $_ ne $val;
};
};
};
return 1;
}
sub to_string {
my ($self) = @_;
my $verbosity = defined $self->{verbosity}
? $self->{verbosity}
: $self->{defaults}->{verbosity};
my $message = join ': ', $self->_string_attributes;
if ($message eq '') {
foreach (reverse @{ $self->{defaults}->{string_attributes} }) {
$message = $self->{defaults}->{$_};
last if defined $message;
};
};
if ($verbosity == 1) {
return $message if $message =~ /\n$/;
return $message . "\n";
}
elsif ($verbosity == 2) {
return $message if $message =~ /\n$/;
my @stacktrace = $self->get_caller_stacktrace;
return $message . $stacktrace[0] . ".\n";
}
elsif ($verbosity >= 3) {
return ref($self) . ': ' . $message . $self->get_caller_stacktrace;
};
return '';
};
sub to_number {
my ($self) = @_;
my $numeric_attribute = $self->{defaults}->{numeric_attribute};
no warnings 'numeric';
return 0+ $self->{$numeric_attribute} if defined $self->{$numeric_attribute};
return 0+ $self->{defaults}->{$numeric_attribute} if defined $self->{defaults}->{$numeric_attribute};
return 0;
};
sub to_bool {
return !! 1;
};
sub get_caller_stacktrace {
my ($self) = @_;
my @stacktrace;
my $tid_msg = '';
$tid_msg = ' thread ' . $self->{tid} if $self->{tid};
my $verbosity = defined $self->{verbosity}
? $self->{verbosity}
: $self->{defaults}->{verbosity};
my $ignore_level = defined $self->{ignore_level}
? $self->{ignore_level}
: defined $self->{defaults}->{ignore_level}
? $self->{defaults}->{ignore_level}
: 0;
my $level = 0;
while (my %c = $self->_caller_info($level++)) {
next if $self->_skip_ignored_package($c{package});
if ($ignore_level > 0) {
--$ignore_level;
next;
};
push @stacktrace, sprintf " at %s line %s%s",
defined $c{file} && $c{file} ne '' ? $c{file} : 'unknown',
$c{line} || 0,
$tid_msg;
last;
};
if (not @stacktrace) {
my %c = $self->_caller_info(0);
push @stacktrace, sprintf " at %s line %s%s",
defined $c{file} && $c{file} ne '' ? $c{file} : 'unknown',
$c{line} || 0,
$tid_msg;
};
if ($verbosity >= 3) {
if ($verbosity >= 4) {
$level = 0;
};
while (my %c = $self->_caller_info($level++)) {
next if $verbosity == 3 and $self->_skip_ignored_package($c{package});
push @stacktrace, "\t$c{wantarray}$c{sub_name} called in package $c{package} at $c{file} line $c{line}";
};
foreach (@{ $self->{propagated_stack} }) {
my ($package, $file, $line) = @$_;
next if $verbosity <= 3 and $self->_skip_ignored_package($package);
push @stacktrace, sprintf "\t...propagated in package %s at %s line %d.",
$package,
defined $file && $file ne '' ? $file : 'unknown',
$line || 0;
};
};
return wantarray ? @stacktrace : join("\n", @stacktrace) . "\n";
};
sub PROPAGATE {
my ($self) = @_;
my $level = 1;
while (my @c = caller($level++)) {
next if ! defined $Isa_Package{$c[0]}
? $Isa_Package{$c[0]} = do { local $@; local $SIG{__DIE__}; eval { $c[0]->isa(__PACKAGE__) } }
: $Isa_Package{$c[0]};
push @{ $self->{propagated_stack} }, [ @c[0..2] ];
last;
};
return $self;
};
sub _string_attributes {
my ($self) = @_;
return map { ref $_ eq 'ARRAY'
? sprintf(@$_[0], @$_[1..$#$_])
: $_ }
grep { defined $_ and (ref $_ or $_ ne '') }
map { $self->{$_} }
@{ $self->{defaults}->{string_attributes} };
};
sub _collect_system_data {
my ($self) = @_;
my $verbosity = defined $self->{verbosity} ? $self->{verbosity} : $self->{defaults}->{verbosity};
if ($verbosity >= 2) {
$self->{time} = CORE::time();
$self->{tid} = threads->tid if defined &threads::tid;
@{$self}{qw < pid uid euid gid egid >} =
( $$, $<, $>, $(, $) );
my @caller_stack;
my $level = 1;
while (my @c = do { package DB; caller($level++) }) {
next if ! defined $Isa_Package{$c[0]} ? $Isa_Package{$c[0]} = do { local $@; local $SIG{__DIE__}; eval { $c[0]->isa(__PACKAGE__) } } : $Isa_Package{$c[0]};
my @args = @DB::args;
if (_HAVE_SCALAR_UTIL_WEAKEN) {
foreach (@args) {
Scalar::Util::weaken($_) if ref $_;
};
};
my @stacktrace_element = ( @c[0 .. 7], @args );
push @caller_stack, \@stacktrace_element;
last if $verbosity == 2 and not $self->_skip_ignored_package($stacktrace_element[0]);
};
$self->{caller_stack} = \@caller_stack;
};
return $self;
};
sub _skip_ignored_package {
my ($self, $package) = @_;
my $ignore_package = defined $self->{ignore_package}
? $self->{ignore_package}
: $self->{defaults}->{ignore_package};
my $ignore_class = defined $self->{ignore_class}
? $self->{ignore_class}
: $self->{defaults}->{ignore_class};
if (defined $ignore_package) {
if (ref $ignore_package eq 'ARRAY') {
if (@{ $ignore_package }) {
do { return 1 if defined $_ and (ref $_ eq 'Regexp' and $package =~ $_ or ref $_ ne 'Regexp' and $package eq $_) } foreach @{ $ignore_package };
};
}
else {
return 1 if ref $ignore_package eq 'Regexp' ? $package =~ $ignore_package : $package eq $ignore_package;
};
}
if (defined $ignore_class) {
if (ref $ignore_class eq 'ARRAY') {
if (@{ $ignore_class }) {
return 1 if grep { do { local $@; local $SIG{__DIE__}; eval { $package->isa($_) } } } @{ $ignore_class };
};
}
else {
return 1 if do { local $@; local $SIG{__DIE__}; eval { $package->isa($ignore_class) } };
};
};
return '';
};
sub _caller_info {
my ($self, $i) = @_;
my %call_info;
my @call_info = ();
@call_info = @{ $self->{caller_stack}->[$i] }
if defined $self->{caller_stack} and defined $self->{caller_stack}->[$i];
@call_info{
qw{ package file line subroutine has_args wantarray evaltext is_require }
} = @call_info[0..7];
unless (defined $call_info{package}) {
return ();
};
my $sub_name = $self->_get_subname(\%call_info);
if ($call_info{has_args}) {
my @args = map {$self->_format_arg($_)} @call_info[8..$#call_info];
my $max_arg_nums = defined $self->{max_arg_nums} ? $self->{max_arg_nums} : $self->{defaults}->{max_arg_nums};
if ($max_arg_nums > 0 and $#args+1 > $max_arg_nums) {
$#args = $max_arg_nums - 2;
push @args, '...';
};
$sub_name .= '(' . join (', ', @args) . ')';
}
$call_info{file} = 'unknown' unless $call_info{file};
$call_info{line} = 0 unless $call_info{line};
$call_info{sub_name} = $sub_name;
$call_info{wantarray} = $call_info{wantarray} ? '@_ = ' : '$_ = ';
return wantarray() ? %call_info : \%call_info;
};
sub _get_subname {
my ($self, $info) = @_;
if (defined($info->{evaltext})) {
my $eval = $info->{evaltext};
if ($info->{is_require}) {
return "require $eval";
}
else {
$eval =~ s/([\\\'])/\\$1/g;
return
"eval '" .
$self->_str_len_trim($eval, defined $self->{max_eval_len} ? $self->{max_eval_len} : $self->{defaults}->{max_eval_len}) .
"'";
};
};
return ($info->{subroutine} eq '(eval)') ? 'eval {...}' : $info->{subroutine};
};
sub _format_arg {
my ($self, $arg) = @_;
return 'undef' if not defined $arg;
if (do { local $@; local $SIG{__DIE__}; eval { $arg->isa(__PACKAGE__) } } or ref $arg) {
return q{"} . overload::StrVal($arg) . q{"};
};
$arg =~ s/\\/\\\\/g;
$arg =~ s/"/\\"/g;
$arg =~ s/`/\\`/g;
$arg = $self->_str_len_trim($arg, defined $self->{max_arg_len} ? $self->{max_arg_len} : $self->{defaults}->{max_arg_len});
$arg = "\"$arg\"" unless $arg =~ /^-?[\d.]+\z/;
no warnings 'once', 'utf8';
if (not defined *utf8::is_utf{CODE} or utf8::is_utf8($arg)) {
$arg = join('', map { $_ > 255
? sprintf("\\x{%04x}", $_)
: chr($_) =~ /[[:cntrl:]]|[[:^ascii:]]/
? sprintf("\\x{%02x}", $_)
: chr($_)
} unpack("U*", $arg));
}
else {
$arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%02x}",ord($1))/eg;
};
return $arg;
};
sub _str_len_trim {
my (undef, $str, $max) = @_;
$max = 0 unless defined $max;
if ($max > 2 and $max < length($str)) {
substr($str, $max - 3) = '...';
};
return $str;
};
sub _modify_default {
my ($self, $key, $value, $modifier) = @_;
my $class = ref $self || $self;
my $attributes = $class->ATTRS;
if (not exists $attributes->{$key}->{default}) {
Exception::Base->throw(
message => ["%s class does not implement default value for `%s' attribute", $class, $key],
verbosity => 1
);
};
$attributes->{$key} = { %{ $attributes->{$key} } };
if ($modifier eq '+') {
my $old = $attributes->{$key}->{default};
if (ref $old eq 'ARRAY' or ref $value eq 'Regexp') {
my @new = ref $old eq 'ARRAY' ? @{ $old } : $old;
foreach my $v (ref $value eq 'ARRAY' ? @{ $value } : $value) {
next if grep { $v eq $_ } ref $old eq 'ARRAY' ? @{ $old } : $old;
push @new, $v;
};
$attributes->{$key}->{default} = [ @new ];
}
elsif ($old =~ /^\d+$/) {
$attributes->{$key}->{default} += $value;
}
else {
$attributes->{$key}->{default} .= $value;
};
}
elsif ($modifier eq '-') {
my $old = $attributes->{$key}->{default};
if (ref $old eq 'ARRAY' or ref $value eq 'Regexp') {
my @new = ref $old eq 'ARRAY' ? @{ $old } : $old;
foreach my $v (ref $value eq 'ARRAY' ? @{ $value } : $value) {
@new = grep { $v ne $_ } @new;
};
$attributes->{$key}->{default} = [ @new ];
}
elsif ($old =~ /^\d+$/) {
$attributes->{$key}->{default} -= $value;
}
else {
$attributes->{$key}->{default} = $value;
};
}
else {
$attributes->{$key}->{default} = $value;
};
{
no warnings 'redefine';
*{_qualify_to_ref("${class}::ATTRS")} = sub () {
+{ %$attributes };
};
};
%Class_Attributes = %Class_Defaults = ();
return $self;
};
sub _make_accessors {
my ($self) = @_;
my $class = ref $self || $self;
no warnings 'uninitialized';
my $attributes = $class->ATTRS;
foreach my $key (keys %{ $attributes }) {
next if ref $attributes->{$key} ne 'HASH';
if (not $class->can($key)) {
next if not defined $attributes->{$key}->{is};
if ($attributes->{$key}->{is} eq 'rw') {
*{_qualify_to_ref($class . '::' . $key)} = sub :lvalue {
@_ > 1 ? $_[0]->{$key} = $_[1]
: $_[0]->{$key};
};
}
else {
*{_qualify_to_ref($class . '::' . $key)} = sub {
$_[0]->{$key};
};
};
};
};
return $self;
};
sub _make_caller_info_accessors {
my ($self) = @_;
my $class = ref $self || $self;
foreach my $key (qw{ package file line subroutine }) {
if (not $class->can($key)) {
*{_qualify_to_ref($class . '::' . $key)} = sub {
my $self = shift;
my $ignore_level = defined $self->{ignore_level}
? $self->{ignore_level}
: defined $self->{defaults}->{ignore_level}
? $self->{defaults}->{ignore_level}
: 0;
my $level = 0;
while (my %c = $self->_caller_info($level++)) {
next if $self->_skip_ignored_package($c{package});
if ($ignore_level > 0) {
$ignore_level --;
next;
};
return $c{$key};
};
};
};
};
return $self;
};
sub _load_package {
my ($class, $package, $version) = @_;
return unless $package;
my $file = $package . '.pm';
$file =~ s{::}{/}g;
require $file;
if (defined $version and $version =~ m/^\d/) {
$package->VERSION($version);
};
return $class;
};
sub _make_exception {
my ($class, $package, $version, $param) = @_;
return unless $package;
my $isa = defined $param->{isa} ? $param->{isa} : __PACKAGE__;
$version = 0.01 if not $version;
my $has = defined $param->{has} ? $param->{has} : { rw => [ ], ro => [ ] };
if (ref $has eq 'ARRAY') {
$has = { rw => $has, ro => [ ] };
}
elsif (not ref $has) {
$has = { rw => [ $has ], ro => [ ] };
};
foreach my $mode ('rw', 'ro') {
if (not ref $has->{$mode}) {
$has->{$mode} = [ defined $has->{$mode} ? $has->{$mode} : () ];
};
};
if (not defined do { local $SIG{__DIE__}; eval { $isa->VERSION } }) {
eval {
$class->_load_package($isa);
};
if ($@) {
Exception::Base->throw(
message => ["Base class %s for class %s can not be found", $isa, $package],
verbosity => 1
);
};
};
my $attributes;
{
local $SIG{__DIE__};
eval {
$attributes = $isa->ATTRS;
};
};
if ($@) {
Exception::Base->throw(
message => ["%s class is based on %s class which does not implement ATTRS", $package, $isa],
verbosity => 1
);
};
my %overridden_attributes;
foreach my $mode ('rw', 'ro') {
foreach my $attribute (@{ $has->{$mode} }) {
if ($attribute =~ /^(isa|version|has)$/ or $isa->can($attribute)) {
Exception::Base->throw(
message => ["Attribute name `%s' can not be defined for %s class", $attribute, $package],
);
};
$overridden_attributes{$attribute} = { is => $mode };
};
};
foreach my $attribute (keys %{ $param }) {
next if $attribute =~ /^(isa|version|has)$/;
if (not exists $attributes->{$attribute}->{default}
and not exists $overridden_attributes{$attribute})
{
Exception::Base->throw(
message => ["%s class does not implement default value for `%s' attribute", $isa, $attribute],
verbosity => 1
);
};
$overridden_attributes{$attribute} = {};
$overridden_attributes{$attribute}->{default} = $param->{$attribute};
foreach my $property (keys %{ $attributes->{$attribute} }) {
next if $property eq 'default';
$overridden_attributes{$attribute}->{$property} = $attributes->{$attribute}->{$property};
};
};
*{_qualify_to_ref("${package}::VERSION")} = \$version;
*{_qualify_to_ref("${package}::ISA")} = [ $isa ];
*{_qualify_to_ref("${package}::ATTRS")} = sub () {
+{ %{ $isa->ATTRS }, %overridden_attributes };
};
$package->_make_accessors;
return $class;
};
BEGIN {
__PACKAGE__->_make_accessors;
__PACKAGE__->_make_caller_info_accessors;
};
1;
=begin plantuml
class Exception::Base <<exception>> {
+ignore_class : ArrayRef = []
+ignore_level : Int = 0
+ignore_package : ArrayRef = []
+max_arg_len : Int = 64
+max_arg_nums : Int = 8
+max_eval_len : Int = 0
+message : Str|ArrayRef[Str] = "Unknown exception"
+value : Int = 0
+verbosity : Int = 2
..
+caller_stack : ArrayRef
+egid : Int
+euid : Int
+gid : Int
+pid : Int
+propagated_stack : ArrayRef
+tid : Int
+time : Int
+uid : Int
..
==
+new( args : Hash ) <<create>>
+throw( args : Hash = undef ) <<create>>
+throw( message : Str, args : Hash = undef ) <<create>>
..
+catch() : Exception::Base
+catch( variable : Any ) : Exception::Base
+matches( that : Any ) : Bool {overload="~~"}
+to_string() : Str {overload='""'}
+to_number() : Num {overload="0+"}
+to_bool() : Bool {overload="bool"}
+get_caller_stacktrace() : Array[Str]|Str
+PROPAGATE()
..
+ATTRS() : HashRef <<constant>>
..
}
=end plantuml
=head1 SEE ALSO
There are more implementation of exception objects available on CPAN. Please
note that Perl has built-in implementation of pseudo-exceptions:
eval { die { message => "Pseudo-exception", package => __PACKAGE__,
file => __FILE__, line => __LINE__ };
};
if ($@) {
print $@->{message}, " at ", $@->{file}, " in line ", $@->{line}, ".\n";
}
The more complex implementation of exception mechanism provides more features.
=over
=item L<Error>
Complete implementation of try/catch/finally/otherwise mechanism. Uses nested
closures with a lot of syntactic sugar. It is slightly faster than
C<Exception::Base> module for failure scenario and is much slower for success
scenario. It doesn't provide a simple way to create user defined exceptions.
It doesn't collect system data and stack trace on error.
=item L<Exception::Class>
More Perlish way to do OO exceptions. It is similar to C<Exception::Base>
module and provides similar features but it is 10x slower for failure
scenario.
=item L<Exception::Class::TryCatch>
Additional try/catch mechanism for L<Exception::Class>. It is 15x slower for
success scenario.
=item L<Class::Throwable>
Elegant OO exceptions similar to L<Exception::Class> and C<Exception::Base>.
It might be missing some features found in C<Exception::Base> and
L<Exception::Class>.
=item L<Exceptions>
Not recommended. Abandoned. Modifies C<%SIG> handlers.
=item L<TryCatch>
A module which gives new try/catch keywords without source filter.
=item L<Try::Tiny>
Smaller, simpler and slower version of L<TryCatch> module.
=back
The C<Exception::Base> does not depend on other modules like
L<Exception::Class> and it is more powerful than L<Class::Throwable>. Also it
does not use closures as L<Error> and does not pollute namespace asL<Exception::Class::TryCatch>. It is also much faster than
L<Exception::Class::TryCatch> and L<Error> for success scenario.
The C<Exception::Base> is compatible with syntax sugar modules like
L<TryCatch> and L<Try::Tiny>.
The C<Exception::Base> is also a base class for enhanced classes:
=over
=item L<Exception::System>
The exception class for system or library calls which modifies C<$!> variable.
=item L<Exception::Died>
The exception class for eval blocks with simple L<perlfunc/die>. It can also
handle L<$SIG{__DIE__}|perlvar/%SIG> hook and convert simple L<perlfunc/die>
into an exception object.
=item L<Exception::Warning>
The exception class which handle L<$SIG{__WARN__}|pervar/%SIG> hook and
convert simple L<perlfunc/warn> into an exception object.
=back
=head1 EXAMPLES
=head2 New exception classes
The C<Exception::Base> module allows to create new exception classes easily.
You can use L<perlfunc/import> interface or L<base> module to do it.The L<perlfunc/import> interface allows to create new class with new
read-write attributes.
has => qw{ reason method },
string_attributes => qw{ message reason method },
};
For more complex exceptions you can redefine C<ATTRS> constant.
%{ Exception::Base->ATTRS },
hostname => { is => 'ro' },
string_attributes => qw{ hostname message },
};
sub _collect_system_data {
my $self = shift;
my $hostname = `hostname`;
chomp $hostname;
$self->{hostname} = $hostname;
return $self->SUPER::_collect_system_data(@_);
}
=head1 PERFORMANCE
There are two scenarios for L<perlfunc/eval> block: success or failure.
Success scenario should have no penalty on speed. Failure scenario is usually
more complex to handle and can be significantly slower.
Any other code than simple C<if ($@)> is really slow and shouldn't be used if
speed is important. It means that any module which provides try/catch syntax
sugar should be avoided: L<Error>, L<Exception::Class::TryCatch>, L<TryCatch>,
L<Try::Tiny>. Be careful because simple C<if ($@)> has many gotchas which are
described in L<Try::Tiny>'s documentation.
The C<Exception::Base> module was benchmarked with other implementations for
simple try/catch scenario. The results
(Perl 5.10.1 x86_64-linux-thread-multi) are following:
-----------------------------------------------------------------------
| Module | Success sub/s | Failure sub/s |
-----------------------------------------------------------------------
| eval/die string | 3715708 | 408951 |
-----------------------------------------------------------------------
| eval/die object | 4563524 | 191664 |
-----------------------------------------------------------------------
| Exception::Base eval/if | 4903857 | 11291 |
-----------------------------------------------------------------------
| Exception::Base eval/if verbosity=1 | 4790762 | 18833 |
-----------------------------------------------------------------------
| Error | 117475 | 26694 |
-----------------------------------------------------------------------
| Class::Throwable | 4618545 | 12678 |
-----------------------------------------------------------------------
| Exception::Class | 643901 | 3493 |
-----------------------------------------------------------------------
| Exception::Class::TryCatch | 307825 | 3439 |
-----------------------------------------------------------------------
| TryCatch | 690784 | 294802 |
-----------------------------------------------------------------------
| Try::Tiny | 268780 | 158383 |
-----------------------------------------------------------------------
The C<Exception::Base> module was written to be as fast as it is
possible. It does not use internally i.e. accessor functions which areslower about 6 times than standard variables. It is slower than pure
die/eval for success scenario because it is uses OO mechanisms which are slow
in Perl. It can be a little faster if some features are disables, i.e. the
stack trace and higher verbosity.
You can find the benchmark script in this package distribution.=head1 BUGS
If you find the bug or want to implement new features, please report it at
The code repository is available at
=for readme continue
=head1 AUTHOR
Piotr Roszatycki <dexter@cpan.org>
=head1 LICENSE
Copyright (c) 2007-2015 Piotr Roszatycki <dexter@cpan.org>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.