Exception::Base - Lightweight exceptions

  # Use module and create needed exceptions
  use Exception::Base
     'Exception::Runtime',              # create new module
     'Exception::System',               # load existing module
     'Exception::IO',          => {
         isa => 'Exception::System' },  # create new based on existing
     'Exception::FileNotFound' => {
         isa => 'Exception::IO',        # create new based on previous
         message => 'File not found',   # override default message
         has => [ 'filename' ],         # define new rw attribute
         string_attributes => [ 'message', 'filename' ],
     };                                 # output message and filename

  # eval is used as "try" block
  eval {
    open my $file, '/etc/passwd'
      or Exception::FileNotFound->throw(
            message=>'Something wrong',
            filename=>'/etc/passwd');
  };
  # syntax for Perl >= 5.10
  use feature 'switch';
  if ($@) {
    given (my $e = Exception::Base->catch) {
      when ($e->isa('Exception::IO')) { warn "IO problem"; }
      when ($e->isa('Exception::Eval')) { warn "eval died"; }
      when ($e->isa('Exception::Runtime')) { warn "some runtime was caught"; }
      when ($e->matches({value=>9})) { warn "something happened"; }
      when ($e->matches(qr/^Error/)) { warn "some error based on regex"; }
      default { $e->throw; } # rethrow the exception
    }
  }
  # standard syntax for older Perl
  if ($@) {
    my $e = Exception::Base->catch;   # convert $@ into exception
    if ($e->isa('Exception::IO')) { warn "IO problem"; }
    elsif ($e->isa('Exception::Eval')) { warn "eval died"; }
    elsif ($e->isa('Exception::Runtime')) { warn "some runtime was caught"; }
    elsif ($e->matches({value=>9})) { warn "something happened"; }
    elsif ($e->matches(qr/^Error/)) { warn "some error based on regex"; }
    else { $e->throw; } # rethrow the exception
  }

  # $@ has to be recovered ASAP!
  eval { die "this die will be caught" };
  my $e = Exception::Base->catch;
  eval { die "this die will be ignored" };
  if ($e) {
     (...)
  }

  # the exception can be thrown later
  my $e = Exception::Base->new;
  # (...)
  $e->throw;

  # ignore our package in stack trace
  package My::Package;
  use Exception::Base '+ignore_package' => __PACKAGE__;

  # define new exception in separate module
  package Exception::My;
  use Exception::Base (__PACKAGE__) => {
      has => ['myattr'],
  };

  # run Perl with changed verbosity for debugging purposes
  $ perl -MException::Base=verbosity,4 script.pl

  eval { die { message => "Pseudo-exception", package => __PACKAGE__,
               file => __FILE__, line => __LINE__ };
  };
  if ($@) {
    print $@->{message}, " at ", $@->{file}, " in line ", $@->{line}, ".\n";
  }

  package Exception::Simple;
  use Exception::Base (__PACKAGE__) => {
    has => qw{ reason method },
    string_attributes => qw{ message reason method },
  };

  package Exception::Complex;
  use base 'Exception::Base';
  use constant ATTRS => {
    %{ Exception::Base->ATTRS },     # SUPER::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(@_);
  }

  -----------------------------------------------------------------------
  | 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 |
  -----------------------------------------------------------------------

#!/usr/bin/perl -c

package Exception::Base;

use 5.006;

use strict;
use warnings;

our $VERSION = '0.2401';

use utf8;


## no critic qw(ProhibitConstantPragma RequireArgUnpacking RequireCarping RequireCheckingReturnValueOfEval RequireInitializationForLocalVars)

# Safe operations on symbol stash
BEGIN {
    eval {
        require Symbol;
        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] } };
    };
};


# Use weaken ref on stack if available
BEGIN {
    eval {
        require Scalar::Util;
        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);

    use overload;
    overload->import(%OVERLOADS);
};


# Constant regexp for numerify value check
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 };
};


# Cache for class' ATTRS
my %Class_Attributes;


# Cache for class' defaults
my %Class_Defaults;


# Cache for $obj->isa(__PACKAGE__)
my %Isa_Package;

# Create additional exception packages
sub import {
    my $class = shift;

    while (defined $_[0]) {
        my $name = shift @_;
        if ($name eq ':all') {
            # do nothing for backward compatibility
        }
        elsif ($name =~ /^([+-]?)([a-z0-9_]+)$/) {
            # Lower case: change default
            my ($modifier, $key) = ($1, $2);
            my $value = shift;
            $class->_modify_default($key, $value, $modifier);
        }
        else {
            # Try to use external module
            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) };

                # Package is needed
                {
                    local $SIG{__DIE__};
                    eval {
                        $class->_load_package($name, $version);
                    };
                };
                if ($@) {
                    # Die unless can't load module
                    if ($@ !~ /Can\'t locate/) {
                        Exception::Base->throw(
                            message => ["Can not load available %s class: %s", $name, $@],
                            verbosity => 1
                        );
                    };
                }
                else {
                    # Module is loaded: go to next
                    next;
                };
            };

            next if $name eq __PACKAGE__;

            # Package not found so it have to be created
            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;
};

# Constructor
sub new {
    my ($self, %args) = @_;

    my $class = ref $self || $self;

    my $attributes;
    my $defaults;

    # Use cached value if available
    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 = {};

    # If the attribute is rw, initialize its value. Otherwise: ignore.
    no warnings 'uninitialized';
    foreach my $key (keys %args) {
        if ($attributes->{$key}->{is} eq 'rw') {
            $e->{$key} = $args{$key};
        };
    };

    # Defaults for this object
    $e->{defaults} = { %$defaults };

    bless $e => $class;

    # Collect system data and eval error
    $e->_collect_system_data;

    return $e;
};

# Create the exception and throw it or rethrow existing
sub throw {
    my $self = shift;

    my $class = ref $self || $self;

    my $old_e;

    if (not ref $self) {
        # CLASS->throw
        if (not ref $_[0]) {
            # Throw new exception
            if (scalar @_ % 2 == 0) {
                # Throw normal error
                die $self->new(@_);
            }
            else {
                # First argument is a default attribute; it can be overridden with normal args
                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 {
            # First argument is an old exception
            $old_e = shift;
        };
    }
    else {
        # $e->throw
        $old_e = $self;
    };

    # Rethrow old exception with replaced attributes
    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) {
        # Rebless old object for new class
        bless $old_e => $class;
    };

    die $old_e;
};

# Recover $@ variable and return exception object
sub catch {
    my ($self) = @_;

    my $class = ref $self || $self;

    my $e;
    my $new_e;


    if (@_ > 1) {
        # Recover exception from argument
        $e = $_[1];
    }
    else {
        # Recover exception from $@ and clear it
        ## no critic qw(RequireLocalizedPunctuationVars)
        $e = $@;
        $@ = '';
    };

    if (ref $e and do { local $@; local $SIG{__DIE__}; eval { $e->isa(__PACKAGE__) } }) {
        # Caught exception
        $new_e = $e;
    }
    elsif ($e eq '') {
        # No error in $@
        $new_e = undef;
    }
    else {
        # New exception based on error from $@. Clean up the message.
        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;
};

# Smart matching.
sub matches {   ## no critic qw(ProhibitExcessComplexity)
    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;

    # Odd number of arguments - first is default attribute
    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;
            };
            # Fail unless at least one condition is true
            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;
        };

        ## no critic qw(ProhibitCascadingIfElse)
        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}}]
                                 )
                               : $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}}]
                         )
                       : $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;
}

# Convert an exception to string
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 '';
};

# Convert an exception to number
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;
};

# Convert an exception to bool (always true)
sub to_bool {
    return !! 1;
};

# Stringify caller backtrace. Stolen from Carp
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;

    # Skip some packages for first line
    my $level = 0;
    while (my %c = $self->_caller_info($level++)) {
        next if $self->_skip_ignored_package($c{package});
        # Skip ignored levels
        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;
    };
    # First line have to be filled even if everything was skipped
    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) {
        # Reset the stack trace level only if needed
        if ($verbosity >= 4) {
            $level = 0;
        };
        # Dump the caller stack
        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}";
        };
        # Dump the propagated stack
        foreach (@{ $self->{propagated_stack} }) {
            my ($package, $file, $line) = @$_;
            # Skip ignored package
            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";
};

# Propagate exception if it is rethrown
sub PROPAGATE {
    my ($self) = @_;

    # Fill propagate stack
    my $level = 1;
    while (my @c = caller($level++)) {
            # Skip own package
            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]};
            # Collect the caller stack
            push @{ $self->{propagated_stack} }, [ @c[0..2] ];
            last;
    };

    return $self;
};


# Return a list of values of default string attributes
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} };
};

# Collect system data and fill the attributes and caller stack.
sub _collect_system_data {
    my ($self) = @_;

    # Collect system data only if verbosity is meaning
    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 >} =
                (     $$, $<, $>,  $(, $)    );

        # Collect stack info
        my @caller_stack;
        my $level = 1;

        ## no critic qw(ProhibitMultiplePackages ProhibitPackageVars)
        while (my @c = do { package DB; caller($level++) }) {
            # Skip own package
            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]};
            # Collect the caller stack
            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;
            # Collect only one entry if verbosity is lower than 3 and skip ignored packages
            last if $verbosity == 2 and not $self->_skip_ignored_package($stacktrace_element[0]);
        };
        $self->{caller_stack} = \@caller_stack;
    };

    return $self;
};


# Check if package should be ignored
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 '';
};


# Return info about caller. Stolen from Carp
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, '...';
        };
        # Push the args onto the subroutine
        $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;
};


# Figures out the name of the sub/require/eval. Stolen from Carp
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};
};


# Transform an argument to a function into a string. Stolen from Carp
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 critic qw(ProhibitNoWarnings)
    no warnings 'once', 'utf8';   # can't disable critic for 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;
};


# If a string is too long, trims it with ... . Stolen from Carp
sub _str_len_trim {
    my (undef, $str, $max) = @_;
    $max = 0 unless defined $max;
    if ($max > 2 and $max < length($str)) {
        ## no critic qw(ProhibitLvalueSubstr)
        substr($str, $max - 3) = '...';
    };

    return $str;
};


# Modify default values for ATTRS
sub _modify_default {
    my ($self, $key, $value, $modifier) = @_;

    my $class = ref $self || $self;

    # Modify entry in ATTRS constant. Its elements are not constant.
    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
        );
    };

    # Make a new anonymous hash reference for attribute
    $attributes->{$key} = { %{ $attributes->{$key} } };

    # Modify default value of attribute
    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;
    };

    # Redeclare constant
    {
        no warnings 'redefine';
        *{_qualify_to_ref("${class}::ATTRS")} = sub () {
            +{ %$attributes };
        };
    };

    # Reset cache
    %Class_Attributes = %Class_Defaults = ();

    return $self;
};

# Create accessors for this class
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;
};

# Create caller_info() accessors for this class
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});
                    # Skip ignored levels
                    if ($ignore_level > 0) {
                        $ignore_level --;
                        next;
                    };
                    return $c{$key};
                };
            };
        };
    };

    return $self;
};


# Load another module without eval q{}
sub _load_package {
    my ($class, $package, $version) = @_;

    return unless $package;

    my $file = $package . '.pm';
    $file =~ s{::}{/}g;

    require $file;

    # Check version if first element on list is a version number.
    if (defined $version and $version =~ m/^\d/) {
        $package->VERSION($version);
    };

    return $class;
};


# Create new exception 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} : () ];
        };
    };

    # Base class is needed
    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
            );
        };
    };

    # Handle defaults for object attributes
    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
        );
    };

    # Create the hash with overridden attributes
    my %overridden_attributes;
    # Class => { has => { rw => [ "attr1", "attr2", "attr3", ... ], ro => [ "attr4", ... ] } }
    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 };
        };
    };
    # Class => { message => "overridden default", ... }
    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};
        };
    };

    # Create the new package
    ## no critic qw(ProhibitCommaSeparatedStatements)
    *{_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;
};


# Module initialization
## no critic qw(ProtectPrivateSubs)
BEGIN {
    __PACKAGE__->_make_accessors;
    __PACKAGE__->_make_caller_info_accessors;
};


1;