package Exception::Class::Base;

use strict;

use warnings;

our $VERSION = '1.44';

use Class::Data::Inheritable 0.02;

use Devel::StackTrace 2.00;

use Scalar::Util qw( blessed );

use base qw(Class::Data::Inheritable);

BEGIN {

    __PACKAGE__->mk_classdata('Trace');

    __PACKAGE__->mk_classdata('UnsafeRefCapture');

    __PACKAGE__->mk_classdata('NoContextInfo');

    __PACKAGE__->NoContextInfo(0);

    __PACKAGE__->mk_classdata('RespectOverload');

    __PACKAGE__->RespectOverload(0);

    __PACKAGE__->mk_classdata('MaxArgLength');

    __PACKAGE__->MaxArgLength(0);

    sub NoRefs {

        my $self = shift;

        if (@_) {

            my $val = shift;

            return $self->UnsafeRefCapture( !$val );

        }

        else {

            return $self->UnsafeRefCapture;

        }

    }

    sub Fields { () }

}

use overload

    # an exception is always true

    bool => sub {1}, '""' => 'as_string', fallback => 1;

# Create accessor routines

BEGIN {

    my @fields = qw( message pid uid euid gid egid time trace );

    foreach my $f (@fields) {

        my $sub = sub { my $s = shift; return $s->{$f}; };

        ## no critic (TestingAndDebugging::ProhibitNoStrict)

        no strict 'refs';

        *{$f} = $sub;

    }

    *error = \&message;

    my %trace_fields = (

        package => 'package',

        file    => 'filename',

        line    => 'line',

    );

    while ( my ( $f, $m ) = each %trace_fields ) {

        my $sub = sub {

            my $s = shift;

            return $s->{$f} if exists $s->{$f};

            my $frame = $s->trace->frame(0);

            return $s->{$f} = $frame ? $frame->$m : undef;

        };

        ## no critic (TestingAndDebugging::ProhibitNoStrict)

        no strict 'refs';

        *{$f} = $sub;

    }

}

sub Classes { Exception::Class::Classes() }

sub throw {

    my $proto = shift;

    $proto->rethrow if ref $proto;

    die $proto->new(@_);

}

sub rethrow {

    my $self = shift;

    die $self;

}

sub new {

    my $proto = shift;

    my $class = ref $proto || $proto;

    my $self = bless {}, $class;

    $self->_initialize(@_);

    return $self;

}

sub _initialize {

    my $self = shift;

    my %p = @_ == 1 ? ( error => $_[0] ) : @_;

    $self->{message} = $p{message} || $p{error} || q{};

    $self->{show_trace} = $p{show_trace} if exists $p{show_trace};

    if ( $self->NoContextInfo ) {

        $self->{show_trace} = 0;

        $self->{package} = $self->{file} = $self->{line} = undef;

    }

    else {

        # CORE::time is important to fix an error with some versions of

        # Perl

        $self->{time} = CORE::time();

        $self->{pid}  = $$;

        $self->{uid}  = $<;

        $self->{euid} = $>;

        $self->{gid}  = $(;

        $self->{egid} = $);

        my @ignore_class   = (__PACKAGE__);

        my @ignore_package = 'Exception::Class';

        if ( my $i = delete $p{ignore_class} ) {

            push @ignore_class, ( ref($i) eq 'ARRAY' ? @$i : $i );

        }

        if ( my $i = delete $p{ignore_package} ) {

            push @ignore_package, ( ref($i) eq 'ARRAY' ? @$i : $i );

        }

        $self->{trace} = Devel::StackTrace->new(

            ignore_class       => \@ignore_class,

            ignore_package     => \@ignore_package,

            unsafe_ref_capture => $self->UnsafeRefCapture,

            respect_overload   => $self->RespectOverload,

            max_arg_length     => $self->MaxArgLength,

            map { $p{$_} ? ( $_ => delete $p{$_} ) : () } qw(

                frame_filter

                filter_frames_early

                skip_frames

                ),

        );

    }

    my %fields = map { $_ => 1 } $self->Fields;

    while ( my ( $key, $value ) = each %p ) {

        next if $key =~ /^(?:error|message|show_trace)$/;

        if ( $fields{$key} ) {

            $self->{$key} = $value;

        }

        else {

            Exception::Class::Base->throw(

                error => "unknown field $key passed to constructor for class "

                    . ref $self );

        }

    }

}

sub context_hash {

    my $self = shift;

    return {

        time => $self->{time},

        pid  => $self->{pid},

        uid  => $self->{uid},

        euid => $self->{euid},

        gid  => $self->{gid},

        egid => $self->{egid},

    };

}

sub field_hash {

    my $self = shift;

    my $hash = {};

    for my $field ( $self->Fields ) {

        $hash->{$field} = $self->$field;

    }

    return $hash;

}

sub description {

    return 'Generic exception';

}

sub show_trace {

    my $self = shift;

    return 0 unless $self->{trace};

    if (@_) {

        $self->{show_trace} = shift;

    }

    return exists $self->{show_trace} ? $self->{show_trace} : $self->Trace;

}

sub as_string {

    my $self = shift;

    my $str = $self->full_message;

    unless ( defined $str && length $str ) {

        my $desc = $self->description;

        $str = defined $desc

            && length $desc ? "[$desc]" : '[Generic exception]';

    }

    $str .= "\n\n" . $self->trace->as_string

        if $self->show_trace;

    return $str;

}

sub full_message { $_[0]->message }

#

# The %seen bit protects against circular inheritance.

#

## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)

eval <<'EOF' if $] == 5.006;

sub isa {

    my ( $inheritor, $base ) = @_;

    $inheritor = ref($inheritor) if ref($inheritor);

    my %seen;

    no strict 'refs';

    my @parents = ( $inheritor, @{"$inheritor\::ISA"} );

    while ( my $class = shift @parents ) {

        return 1 if $class eq $base;

        push @parents, grep { !$seen{$_}++ } @{"$class\::ISA"};

    }

    return 0;

}

EOF

sub caught {

    my $class = shift;

    my $e = $@;

    return unless defined $e && blessed($e) && $e->isa($class);

    return $e;

}

1;

# ABSTRACT: A base class for exception objects

__END__

=pod

=encoding UTF-8

=head1 NAME

Exception::Class::Base - A base class for exception objects

=head1 VERSION

version 1.44

=head1 SYNOPSIS

  use Exception::Class 'MyException';

  eval { MyException->throw( error => 'I feel funny.' ) };

  print $@->error;

=head1 DESCRIPTION

This class is the base class for all exceptions created by

L<Exception::Class>. It provides a number of methods for getting information

about the exception.

=for Pod::Coverage     Classes

    caught

    NoRefs

=head1 METHODS

=head2 MyException->Trace($boolean)

Each C<Exception::Class::Base> subclass can be set individually to include a

stacktrace when the C<as_string> method is called. The default is to not

include a stacktrace. Calling this method with a value changes this

behavior. It always returns the current value (after any change is applied).

This value is inherited by any subclasses. However, if this value is set for a

subclass, it will thereafter be independent of the value in

C<Exception::Class::Base>.

Do not call this on the C<Exception::Class::Base> class directly or you'll

change it for all exception classes that use L<Exception::Class>, including

ones created in modules you don't control.

This is a class method, not an object method.

=head2 MyException->UnsafeRefCapture($boolean)

When a C<Devel::StackTrace> object is created, it walks through the stack and

stores the arguments which were passed to each subroutine on the stack. If any

of these arguments are references, then that means that the

C<Devel::StackTrace> ends up increasing the ref count of these references,

delaying their destruction.

Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this

method provides a way to tell C<Devel::StackTrace> not to store these

references. Instead, C<Devel::StackTrace> replaces references with their

stringified representation.

This method defaults to false. As with C<Trace>, it is inherited by subclasses

but setting it in a subclass makes it independent thereafter.

Do not call this on the C<Exception::Class::Base> class directly or you'll

change it for all exception classes that use L<Exception::Class>, including

ones created in modules you don't control.

=head2 MyException->RespectOverload($boolean)

When a C<Devel::StackTrace> object stringifies, by default it ignores

stringification overloading on any objects being dealt with.

Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this

method provides a way to tell C<Devel::StackTrace> to respect overloading.

This method defaults to false. As with C<Trace>, it is inherited by subclasses

but setting it in a subclass makes it independent thereafter.

Do not call this on the C<Exception::Class::Base> class directly or you'll

change it for all exception classes that use L<Exception::Class>, including

ones created in modules you don't control.

=head2 MyException->MaxArgLength($boolean)

When a C<Devel::StackTrace> object stringifies, by default it displays the

full argument for each function. This parameter can be used to limit the

maximum length of each argument.

Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this

method provides a way to tell C<Devel::StackTrace> to limit the length of

arguments.

This method defaults to 0. As with C<Trace>, it is inherited by subclasses but

setting it in a subclass makes it independent thereafter.

Do not call this on the C<Exception::Class::Base> class directly or you'll

change it for all exception classes that use L<Exception::Class>, including

ones created in modules you don't control.

=head2 MyException->Fields

This method returns the extra fields defined for the given class, as a list.

Do not call this on the C<Exception::Class::Base> class directly or you'll

change it for all exception classes that use L<Exception::Class>, including

ones created in modules you don't control.

=head2 MyException->throw( $message )

=head2 MyException->throw( message => $message )

=head2 MyException->throw( error => $error )

This method creates a new object with the given error message. If no error

message is given, this will be an empty string. It then dies with this object

as its argument.

This method also takes a C<show_trace> parameter which indicates whether or

not the particular exception object being created should show a stacktrace

when its C<as_string> method is called. This overrides the value of C<Trace>

for this class if it is given.

The frames included in the trace can be controlled by the C<ignore_class> and

C<ignore_package> parameters. These are passed directly to Devel::Stacktrace's

constructor. See C<Devel::Stacktrace> for more details. This class B<always>

passes C<__PACKAGE__> for C<ignore_class> and C<'Exception::Class'> for

C<ignore_package>, in addition to any arguments you provide.

If only a single value is given to the constructor it is assumed to be the

message parameter.

Additional keys corresponding to the fields defined for the particular

exception subclass will also be accepted.

=head2 MyException->new(...)

This method takes the same parameters as C<throw>, but instead of dying simply

returns a new exception object.

This method is always called when constructing a new exception object via the

C<throw> method.

=head2 MyException->description

Returns the description for the given C<Exception::Class::Base> subclass. The

C<Exception::Class::Base> class's description is "Generic exception" (this may

change in the future). This is also an object method.

=head2 $exception->rethrow

Simply dies with the object as its sole argument. It's just syntactic

sugar. This does not change any of the object's attribute values.  However, it

will cause C<caller> to report the die as coming from within the

C<Exception::Class::Base> class rather than where rethrow was called.

Of course, you always have access to the original stacktrace for the exception

object.

=head2 $exception->message

=head2 $exception->error

Returns the error/message associated with the exception.

=head2 $exception->pid

Returns the pid at the time the exception was thrown.

=head2 $exception->uid

Returns the real user id at the time the exception was thrown.

=head2 $exception->gid

Returns the real group id at the time the exception was thrown.

=head2 $exception->euid

Returns the effective user id at the time the exception was thrown.

=head2 $exception->egid

Returns the effective group id at the time the exception was thrown.

=head2 $exception->time

Returns the time in seconds since the epoch at the time the exception was

thrown.

=head2 $exception->package

Returns the package from which the exception was thrown.

=head2 $exception->file

Returns the file within which the exception was thrown.

=head2 $exception->line

Returns the line where the exception was thrown.

=head2 $exception->context_hash

Returns a hash reference with the following keys:

=over 4

=item * time

=item * pid

=item * uid

=item * euid

=item * gid

=item * egid

=back

=head2 $exception->field_hash

Returns a hash reference where the keys are any fields defined for the

exception class and the values are the values associated with the field in the

given object.

=head2 $exception->trace

Returns the trace object associated with the object.

=head2 $exception->show_trace($boolean)

This method can be used to set whether or not a stack trace is included when

the as_string method is called or the object is stringified.

=head2 $exception->as_string

Returns a string form of the error message (something like what you'd expect

from die). If the class or object is set to show traces then then the full

trace is also included. The result looks like C<Carp::confess>.

=head2 $exception->full_message

Called by the C<as_string> method to get the message. By default, this is the

same as calling the C<message> method, but may be overridden by a

subclass. See below for details.

=head1 LIGHTWEIGHT EXCEPTIONS

A lightweight exception is one which records no information about its context

when it is created. This can be achieved by setting C<< $class->NoContextInfo

>> to a true value.

You can make this the default for a class of exceptions by setting it after

creating the class:

  use Exception::Class (

      'LightWeight',

      'HeavyWeight',

  );

  LightWeight->NoContextInfo(1);

A lightweight exception does have a stack trace object, nor does it record the

time, pid, uid, euid, gid, or egid. It only has a message.

=head1 OVERLOADING

C<Exception::Class::Base> objects are overloaded so that stringification

produces a normal error message. This just calls the C<< $exception->as_string

>> method described above. This means that you can just C<print $@> after an

C<eval> and not worry about whether or not its an actual object. It also means

an application or module could do this:

  $SIG{__DIE__} = sub { Exception::Class::Base->throw( error => join '', @_ ); };

and this would probably not break anything (unless someone was expecting a

different type of exception object from C<die>).

=head1 OVERRIDING THE as_string METHOD

By default, the C<as_string> method simply returns the value C<message> or

C<error> param plus a stack trace, if the class's C<Trace> method returns a

true value or C<show_trace> was set when creating the exception.

However, once you add new fields to a subclass, you may want to include those

fields in the stringified error.

Inside the C<as_string> method, the message (non-stack trace) portion of the

error is generated by calling the C<full_message> method. This can be easily

overridden. For example:

  sub full_message {

      my $self = shift;

      my $msg = $self->message;

      $msg .= " and foo was " . $self->foo;

      return $msg;

  }

=head1 SUPPORT

Bugs may be submitted at L<https://github.com/houseabsolute/Exception-Class/issues>.

I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.

=head1 SOURCE

The source code repository for Exception-Class can be found at L<https://github.com/houseabsolute/Exception-Class>.

=head1 AUTHOR

Dave Rolsky <autarch@urth.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Dave Rolsky.

This is free software; you can redistribute it and/or modify it under

the same terms as the Perl 5 programming language system itself.

The full text of the license can be found in the

F<LICENSE> file included with this distribution.

=cut