File Coverage

blib/lib/Log/Any/Proxy/WithStackTrace.pm

Criterion	Covered	Total	%
statement	48	58	82.7
branch	12	20	60.0
condition	6	9	66.6
subroutine	16	17	94.1
pod	3	3	100.0
total	85	107	79.4

use 5.008001;
use strict;
use warnings;

package Log::Any::Proxy::WithStackTrace;

# ABSTRACT: Log::Any proxy to upgrade string errors to objects with stack traces
our $VERSION = '1.718';

use Log::Any::Proxy;
our @ISA = qw/Log::Any::Proxy/;

use Devel::StackTrace 2.00;
use Log::Any::Adapter::Util ();
use Scalar::Util qw/blessed reftype/;
use overload;

#pod =head1 SYNOPSIS
#pod
#pod   use Log::Any qw( $log, proxy_class => 'WithStackTrace' );
#pod
#pod   # Allow stack trace call stack arguments to be logged:
#pod   use Log::Any qw( $log, proxy_class => 'WithStackTrace',
#pod                          proxy_show_stack_trace_args => 1 );
#pod
#pod   # Configure some adapter that knows how to:
#pod   #  1) handle structured data, and
#pod   #  2) handle message objects which have a "stack_trace" method:
#pod   Log::Any::Adapter->set($adapter);
#pod
#pod   $log->error("Help!");   # stack trace gets automatically added,
#pod                           # starting from this line of code
#pod
#pod =head1 DESCRIPTION
#pod
#pod Some log adapters, like L, are able to
#pod take advantage of being passed message objects that contain a stack
#pod trace.  However if a stack trace is not available, and fallback logic is
#pod used to generate one, the resulting trace can be confusing if it begins
#pod relative to where the log adapter was called, and not relative to where
#pod the logging method was originally called.
#pod
#pod With this proxy in place, if any logging method is called with a log
#pod message that is a non-reference scalar (i.e. a string), that log message
#pod will be upgraded into a C object with a
#pod C method, and that method will return a trace relative to
#pod where the logging method was called.  A string overload is provided on
#pod the object to return the original log message.
#pod
#pod Additionally, any call stack arguments in the stack trace will be
#pod deleted before logging, to avoid accidentally logging sensitive data.
#pod This happens both for message objects that were auto-generated from
#pod string messages, as well as for message objects that were passed in
#pod directly (if they appear to have a stack trace method).  This default
#pod argument scrubbing behavior can be turned off by specifying a true value
#pod for the C import flag.
#pod
#pod B This proxy should be used with a L that
#pod is configured to handle structured data.  Otherwise the object created
#pod here will just get stringified before it can be used to access the stack
#pod trace.
#pod
#pod =cut

{
    package  # hide from PAUSE indexer
      Log::Any::MessageWithStackTrace;

    use overload '""' => \&stringify;

    sub new
    {
        my ($class, $message, %opts) = @_;

        return bless {
            message     => $message,
            stack_trace => Devel::StackTrace->new(
                # Filter e.g "Log::Any::Proxy", "My::Log::Any::Proxy", etc.
                ignore_package => [ qr/(?:^|::)Log::Any(?:::|$)/ ],
                no_args => $opts{no_args},
            ),
        }, $class;
    }

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

    sub stack_trace { $_[0]->{stack_trace} }
}

#pod =head1 METHODS
#pod
#pod =head2 maybe_upgrade_with_stack_trace
#pod
#pod   @args = $self->maybe_upgrade_with_stack_trace(@args);
#pod
#pod This is an internal-use method that will convert a non-reference scalar
#pod message into a C object with a
#pod C method.  A string overload is provided to return the
#pod original message.
#pod
#pod Stack trace args are scrubbed out in case they contain sensitive data,
#pod unless the C option has been set.
#pod
#pod =cut

sub maybe_upgrade_with_stack_trace
{
    my ($self, @args) = @_;

    # We expect a message, optionally followed by a structured data
    # context hashref.  Bail if we get anything other than that rather
    # than guess what the caller might be trying to do:
    return @args unless   @args == 1 ||
                        ( @args == 2 && ref $args[1] eq 'HASH' );

    if (ref $args[0]) {
        $self->maybe_delete_stack_trace_args($args[0])
            unless $self->{proxy_show_stack_trace_args};
    }
    else {
        $args[0] = Log::Any::MessageWithStackTrace->new(
            $args[0],
            no_args => !$self->{proxy_show_stack_trace_args},
        );
    }

    return @args;
}

#pod =head2 maybe_delete_stack_trace_args
#pod
#pod   $self->maybe_delete_stack_trace_args($arg);
#pod
#pod This is an internal-use method that, given a single argument that is a
#pod reference, tries to figure out whether the argument is an object with a
#pod stack trace, and if so tries to delete any stack trace args.
#pod
#pod The logic is based on L.
#pod
#pod It specifically looks for objects with a C method (which
#pod should catch anything that does L, including anything
#pod that does L), or a C method (used by
#pod L and L and friends).
#pod
#pod It specifically ignores L objects, because their stack
#pod traces don't contain any call stack args.
#pod
#pod =cut

sub maybe_delete_stack_trace_args
{
    my ($self, $arg) = @_;

    return unless blessed $arg;

    if ($arg->can('stack_trace')) {
        # This should catch anything that does StackTrace::Auto,
        # including anything that does Throwable::Error.
        my $trace = $arg->stack_trace;
        $self->delete_args_from_stack_trace($trace);
    }
    elsif ($arg->isa('Mojo::Exception')) {
        # Skip these, they don't have args in their stack traces.
    }
    elsif ($arg->can('trace')) {
        # This should catch Exception::Class and Moose::Exception and
        # friends.  Make sure to check for the "trace" method *after*
        # skipping the Mojo::Exception objects, because those also have
        # a "trace" method.
        my $trace = $arg->trace;
        $self->delete_args_from_stack_trace($trace);
    }

    return;
}

my %aliases = Log::Any::Adapter::Util::log_level_aliases();

# Set up methods/aliases and detection methods/aliases
foreach my $name ( Log::Any::Adapter::Util::logging_methods(), keys(%aliases) )
{
    my $super_name = "SUPER::" . $name;
    no strict 'refs';
    *{$name} = sub {
        my ($self, @args) = @_;
        @args = $self->maybe_upgrade_with_stack_trace(@args);
        my $response = $self->$super_name(@args);
        return $response if defined wantarray;
        return;
    };
}

#pod =head2 delete_args_from_stack_trace($trace)
#pod
#pod   $self->delete_args_from_stack_trace($trace)
#pod
#pod To scrub potentially sensitive data from C arguments,
#pod this method deletes arguments from all of the C
#pod in the trace.
#pod
#pod =cut

sub delete_args_from_stack_trace
{
    my ($self, $trace) = @_;

    return unless $trace && $trace->can('frames');

    foreach my $frame ($trace->frames) {
        next unless $frame->{args};
        $frame->{args} = [];
    }

    return;
}

1;

__END__