Catalyst::Plugin::ErrorCatcher - Catch application errors and emit them somewhere

  use Catalyst qw/-Debug StackTrace ErrorCatcher/;

  <Plugin::ErrorCatcher>
      enable                1
      context               5
      always_log            0
      include_session       0
      user_identified_by    username

      emit_module           A::Module
  </Plugin::ErrorCatcher>

  use Catalyst qw<
    ErrorCatcher
    StackTrace
  >;

  <stacktrace>
    enable      1
  </stacktrace>

  <Plugin::ErrorCatcher>
    enable      1
    # include other options here
  <Plugin::ErrorCatcher>

  package A::Module;
  # vim: ts=8 sts=4 et sw=4 sr sta
  use strict;
  use warnings;

  sub emit {
    my ($class, $c, $output) = @_;

    $c->log->info(
      'IGNORING OUTPUT FROM Catalyst::Plugin::ErrorCatcher'
    );

    return;
  }

  1;
  __END__

  my @error = @{ $c->error };

package Catalyst::Plugin::ErrorCatcher;
BEGIN {
  $Catalyst::Plugin::ErrorCatcher::VERSION = '0.0.8.8';
}
BEGIN {
  $Catalyst::Plugin::ErrorCatcher::DIST = 'Catalyst-Plugin-ErrorCatcher';
}
# ABSTRACT: Catch application errors and emit them somewhere
use strict;
use warnings;
use 5.008001;
use base qw/Class::Data::Accessor/;
use IO::File;
use MRO::Compat;
use Module::Pluggable::Object;

__PACKAGE__->mk_classaccessor(qw/_errorcatcher/);
__PACKAGE__->mk_classaccessor(qw/_errorcatcher_msg/);
__PACKAGE__->mk_classaccessor(qw/_errorcatcher_cfg/);
__PACKAGE__->mk_classaccessor(qw/_errorcatcher_c_cfg/);
__PACKAGE__->mk_classaccessor(qw/_errorcatcher_first_frame/);
__PACKAGE__->mk_classaccessor(qw/_errorcatcher_emitter_of/);

sub setup {
    my $c = shift @_;

    # make sure other modules (e.g. ConfigLoader) work their magic
    $c->maybe::next::method(@_);

    # store the whole config (so plugins have a method to access it)
    $c->_errorcatcher_c_cfg( $c->config );

    # get our plugin config
    my $config = $c->config->{'Plugin::ErrorCatcher'} || {};

    # set some defaults
    $config->{context}            ||= 4;
    $config->{verbose}            ||= 0;
    $config->{always_log}         ||= 0;
    $config->{include_session}    ||= 0;
    $config->{user_identified_by} ||= 'id';
    
    # start with an empty hash
    $c->_errorcatcher_emitter_of({});

    # store our plugin config
    $c->_errorcatcher_cfg( $config );

    # some annoying emitters want a new() to be called
    $c->emitters_init;

    return 1;
}

# implementation borrowed from ABERLIN
sub finalize_error {
    my $c = shift;
    my $conf = $c->_errorcatcher_cfg;

    # finalize_error is only called when we have $c->error, so no need to test
    # for it

    # this should let ::StackTrace do some of our heavy-lifting
    # and prepare the Devel::StackTrace frames for us to re-use
    $c->maybe::next::method(@_);

    # don't run if user is certain we shouldn't
    if (
        # the config file insists we DO NOT run
        defined $conf->{enable} && not $conf->{enable}
    ) {
        return;
    }

    # run if required
    if (
        # the config file insists we run
        defined $conf->{enable} && $conf->{enable}
            or
        # we're in debug mode
        !defined $conf->{enable} && $c->debug
    ) {
        $c->my_finalize_error;
    }

    return;
}

sub my_finalize_error {
    my $c = shift;
    $c->_keep_frames;
    $c->_prepare_message;
    $c->_emit_message;
    return;
}

sub emitters_init {
    my $c = shift;

    if (defined (my $emit_list = $c->_errorcatcher_cfg->{emit_module})) {
        my @emit_list;
        # one item or a list?
        if (defined ref($emit_list) and 'ARRAY' eq ref($emit_list)) {
            @emit_list = @{ $emit_list };
        }
        elsif (not ref($emit_list)) {
            @emit_list = ( $emit_list );
        }

        foreach my $emitter (@emit_list) {
            $c->_require_and_new($emitter);
        }
    }
}

sub _require_and_new {
    my $c = shift;
    my $emitter_name = shift;
    my $output = shift;
    my $conf = $c->_errorcatcher_cfg;

    # make sure our emitter loads
    eval "require $emitter_name";
    if ($@) {
        $c->log->error($@);
        return;
    }
    # make sure it "can" new()
    if ($emitter_name->can('new')) {
        my ($e, $e_cfg);
        $e_cfg = $c->config->{$emitter_name} || {}; 

        eval {
            $e = $emitter_name->new({c=>$c});
        };
        if ($@) {
            $c->log->error($@);
            return;
        }
        # store the object
        $c->_errorcatcher_emitter_of->{$emitter_name} = $e;

        $c->log->debug(
                $emitter_name
            . q{: initialised without errors}
        ) if $conf->{verbose} > 1;

        # we are happy when they emitted without incident
        return 1;
    }

    # default is, "no we didn't mit anything"
    return;
}
sub _emit_message {
    my $c = shift;
    my $conf = $c->_errorcatcher_cfg;
    my $emitted_count = 0;

    return
        unless defined($c->_errorcatcher_msg);

    # use a custom emit method?
    if (defined (my $emit_list = $c->_errorcatcher_cfg->{emit_module})) {
        my @emit_list;
        # one item or a list?
        if (defined ref($emit_list) and 'ARRAY' eq ref($emit_list)) {
            @emit_list = @{ $emit_list };
        }
        elsif (not ref($emit_list)) {
            @emit_list = ( $emit_list );
        }

        foreach my $emitter (@emit_list) {
            $c->log->debug(
                  q{Trying to use custom emitter: }
                . $emitter
            ) if $conf->{verbose};

            # require, and call methods
            my $emitted_ok = $c->_require_and_emit(
                $emitter, $c->_errorcatcher_msg
            );
            if ($emitted_ok) {
                $emitted_count++;
                $c->log->debug(
                      $emitter
                    . q{: OK}
                ) if $conf->{verbose};
            }
            else {
                $c->log->debug(
                      $emitter
                    . q{: FAILED}
                ) if $conf->{verbose};
            }
        }
    }

    # by default use $c->log
    if (
        not $emitted_count
            or
        $c->_errorcatcher_cfg->{always_log}
    ) {
        $c->log->info(
            $c->_errorcatcher_msg
        );
    }

    return;
}

sub _require_and_emit {
    my $c = shift;
    my $emitter_name = shift;
    my $output = shift;
    my $conf = $c->_errorcatcher_cfg;
    my $emitter;

    # if we've preloaded an emitter [because it nas new()]
    # call that object
    if (defined (my $e=$c->_errorcatcher_emitter_of->{$emitter_name})) {
        # make sure it's "the right thing"
        if ($emitter_name eq ref($e)) {
            $emitter = $e;
        }
        else {
            die "$emitter isn't a $emitter";
        }
    }

    # if we haven't set the emitter (from a preloaded object)
    # require it ...
    if (not defined $emitter) {
        # make sure our emitter loads
        eval "require $emitter_name";
        if ($@) {
            $c->log->error($@);
            return;
        }

        $emitter = $emitter_name;
    }

    # make sure it "can" emit
    if ($emitter->can('emit')) {
        eval {
            $emitter->emit(
                $c, $output
            );
        };
        if ($@) {
            $c->log->error($@);
            return;
        }

        $c->log->debug(
                $emitter_name
            . q{: emitted without errors}
        ) if $conf->{verbose} > 1;

        # we are happy when they emitted without incident
        return 1;
    }
    else {
        $c->log->debug(
                $emitter_name
            . q{ does not have an emit() method}
        ) if $conf->{verbose};
    }

    # default is, "no we didn't emit anything"
    return;
}

sub _cleaned_error_message {
    my $error_message = shift;

    # load message cleaning plugins
    my %opts = (
        require     => 1,
        search_path => ['Catalyst::Plugin::ErrorCatcher::Plugin'],
    );
    my $finder = Module::Pluggable::Object->new(%opts);

    # loop through plugins and let them do some message tidying
    foreach my $plugin ($finder->plugins) {
        $plugin->tidy_message(\$error_message)
            if $plugin->can('tidy_message');
    }

    # get rid of annoying newlines and return a potentially clean error
    # message
    chomp $error_message;
    return $error_message;
}

sub _prepare_message {
    my $c = shift;
    my ($feedback, $full_error, $parsed_error);

    # get the (list of) error(s)
    for my $error (@{ $c->error }) {
        $full_error .= qq{$error\n\n};
    }
    # trim out some extra fluff from the full message
    $parsed_error = _cleaned_error_message($full_error);

    # A title for the feedback
    $feedback .= qq{Exception caught:\n};

    # the (parsed) error
    $feedback .= "\n   Error: " . $parsed_error . "\n";

    # general request information
    # some of these aren't always defined...
    $feedback .= "    Time: " . scalar(localtime) . "\n";

    $feedback .= "  Client: " . $c->request->address
        if (defined $c->request->address);
    if (defined $c->request->hostname) {
        $feedback .=        " (" . $c->request->hostname . ")\n"
    }
    else {
        $feedback .= "\n";
    }

    if (defined $c->request->user_agent) {
        $feedback .= "   Agent: " . $c->request->user_agent . "\n";
    }
    $feedback .= "     URI: " . ($c->request->uri||q{n/a}) . "\n";
    $feedback .= "  Method: " . ($c->request->method||q{n/a}) . "\n";

    my $user_identifier_method =
        $c->_errorcatcher_cfg->{user_identified_by};
    # if we have a logged-in user, add to the feedback
    if (
           $c->can('user_exists')
        && $c->user_exists
        && $c->user->can($user_identifier_method)
    ) {
        $feedback .= "    User: " . $c->user->$user_identifier_method;
        $feedback .= " [$user_identifier_method]";
        if (ref $c->user) {
            $feedback .= " (" . ref($c->user) . ")\n";
        }
        else {
            $feedback .= "\n";
        }
    }

    if ('ARRAY' eq ref($c->_errorcatcher)) {
        # push on information and context
        for my $frame ( @{$c->_errorcatcher} ) {
            # clean up the common filename of
            # .../MyApp/script/../lib/...
            if ( $frame->{file} =~ /../ ) {
                $frame->{file} =~ s{script/../}{};
            }

            # if we haven't stored a frame, do so now
            # this is useful for easy access to the filename, line, etc
            if (not defined $c->_errorcatcher_first_frame) {
                $c->_errorcatcher_first_frame($frame);
            }

            my $pkg  = $frame->{pkg};
            my $line = $frame->{line};
            my $file = $frame->{file};
            my $code_preview = _print_context(
                $frame->{file},
                $frame->{line},
                $c->_errorcatcher_cfg->{context}
            );

            $feedback .= "\nPackage: $pkg\n   Line: $line\n   File: $file\n";
            $feedback .= "\n$code_preview\n";
        }
    }
    else {
        $feedback .= "\nStack trace unavailable - use and enable Catalyst::Plugin::StackTrace\n";
    }

    # RT-64492 - add session data if requested
    if (
        $c->_errorcatcher_cfg->{include_session}
        and defined $c->session
    ) {
        eval { require Data::Dump };
        if (my $e=$@) {
            $feedback .= "\nSession data requested but failed to require Data::Dump:\n";
            $feedback .= "    $e\n"
        }
        else {
            $feedback .= "\nSession Data:\n" . Data::Dump::pp($c->session) . "\n";
        }
    }

    # in case we bugger up the s/// on the original error message
    if ($full_error) {
        $feedback .= "\nOriginal Error:\n\n$full_error";
    }

    # store it, otherwise we've done the above for mothing
    if (defined $feedback) {
        $c->_errorcatcher_msg($feedback);
    }

    return;
}

# we don't have to do much here now that we're relying on ::StackTrace to do
# the work for us
sub _keep_frames {
    my $c = shift;
    my $conf = $c->_errorcatcher_cfg;
    my $stacktrace;

    eval {
        $stacktrace = $c->_stacktrace;
    };

    if (defined $stacktrace) {
        $c->_errorcatcher( $stacktrace );
    }
    else {
        $c->log->debug(
                __PACKAGE__
            . q{ has no stack-trace information}
        ) if $conf->{verbose} > 1;
    }
    return;
}

# borrowed heavily from Catalyst::Plugin::StackTrace
sub _print_context {
    my ( $file, $linenum, $context ) = @_;

    my $code;
    if ( -f $file ) {
        my $start = $linenum - $context;
        my $end   = $linenum + $context;
        $start = $start < 1 ? 1 : $start;
        if ( my $fh = IO::File->new( $file, 'r' ) ) {
            my $cur_line = 0;
            while ( my $line = <$fh> ) {
                ++$cur_line;
                last if $cur_line > $end;
                next if $cur_line < $start;
                my @tag = $cur_line == $linenum ? ('-->', q{}) : (q{   }, q{});
                $code .= sprintf(
                    '%s%5d: %s%s',
                        $tag[0],
                        $cur_line,
                        $line ? $line : q{},
                        $tag[1],
                );
            }
        }
    }
    return $code;
}

1;

__END__


# vim: ts=8 sts=4 et sw=4 sr sta