view release on metacpan or  search on metacpan

lib/Workflow/Exception.pm  view on Meta::CPAN

package Workflow::Exception;

use warnings;
use strict;
use v5.14.0;

# Declare some of our exceptions...

use Exception::Class (
    'Workflow::Exception::Configuration' => {
        isa         => 'Workflow::Exception',
        description => 'Configuration errors',
    },
    'Workflow::Exception::Persist' => {
        isa         => 'Workflow::Exception',
        description => 'Persistence errors',
    },
    'Workflow::Exception::Validation' => {
        isa         => 'Workflow::Exception',
        description => 'Validation errors',
        fields      => 'invalid_fields',
    },
);

use Log::Any;

my %TYPE_CLASSES = (
    configuration_error => 'Workflow::Exception::Configuration',
    persist_error       => 'Workflow::Exception::Persist',
    validation_error    => 'Workflow::Exception::Validation',
    workflow_error      => 'Workflow::Exception',
);
my %TYPE_LOGGING = (
    configuration_error => 'error',
    persist_error       => 'error',
    validation_error    => 'info',
    workflow_error      => 'error',
);


$Workflow::Exception::VERSION   = '2.09';
@Workflow::Exception::ISA       = qw( Exporter Exception::Class::Base );
@Workflow::Exception::EXPORT_OK = keys %TYPE_CLASSES;

# Exported shortcuts

sub _mythrow {
    my ( $type, @items ) = @_;

    my ( $msg, %params ) = _massage(@items);
    my $caller = caller;
    my $log = Log::Any->get_logger( category => $caller ); # log as if part of the package of the caller
    my ( $pkg, $line ) = (caller)[ 0, 2 ];
    my ( $prev_pkg, $prev_line ) = ( caller 1 )[ 0, 2 ];

    # Do not log condition errors
    my $method = $TYPE_LOGGING{$type};
    $log->$method(
        "$type exception thrown from [$pkg: $line; before: ",
        "$prev_pkg: $prev_line]: $msg"
    );

    goto &Exception::Class::Base::throw(
        $TYPE_CLASSES{$type},
        message => $msg,
        %params
    );
}

# Use 'goto' here to maintain the stack trace

sub configuration_error {
    unshift @_, 'configuration_error';
    goto &_mythrow;
}

sub persist_error {
    unshift @_, 'persist_error';
    goto &_mythrow;
}

sub validation_error {
    unshift @_, 'validation_error';
    goto &_mythrow;
}

sub workflow_error {
    unshift @_, 'workflow_error';
    goto &_mythrow;
}

# Override 'throw' so we can massage the message and parameters into
# the right format for E::C

sub throw {
    my ( $class, @items ) = @_;

    my ( $msg, %params ) = _massage(@items);
    goto &Exception::Class::Base::throw( $class, message => $msg, %params );
}

sub _massage {
    my @items = @_;

    my %params = ( ref $items[-1] eq 'HASH' ) ? %{ pop @items } : ();
    my $msg = join '', @items;
    $msg =~ s/\\n/ /g; # don't log newlines as per Log4perl recommendations
    return ( $msg, %params );
}

1;

__END__