File Coverage

blib/lib/App/CLI/Plugin/StackTrace.pm

Criterion	Covered	Total	%
statement	12	48	25.0
branch	0	16	0.0
condition	0	21	0.0
subroutine	4	7	57.1
pod	0	1	0.0
total	16	93	17.2

package App::CLI::Plugin::StackTrace;

use strict;
use warnings;
use Devel::StackTrace;
use Fcntl qw(:DEFAULT :flock);

our $CONTEXT_LINE   = 5;
our @IGNORE_PACKAGE = ( __PACKAGE__, "Carp", "Error::subs" );
our $VERSION        = '1.1';

sub setup {

	my($self, @argv) = @_;

    my $stacktrace = (exists $self->config->{stacktrace}) ? $self->config->{stacktrace} : 0;

	if ( (defined $stacktrace && $stacktrace != 0) ||
		 (exists $ENV{APPCLI_STACKTRACE_ENABLE} && $ENV{APPCLI_STACKTRACE_ENABLE} != 0) ||
		 (exists $self->{stacktrace} && defined $self->{stacktrace} && $self->{stacktrace} != 0)
	) {
		$self->_build_override_die_subroutine;
	}

	$self->maybe::next::method(@argv);
}

sub _build_override_die_subroutine {

	my $self = shift;

	$SIG{__DIE__} = sub {

		my $message = shift;
		my @frames;
		my $pkg   = ref $self;
		my $trace = Devel::StackTrace->new( ignore_package => \@IGNORE_PACKAGE );
		my $stacktrace_message = <
$pkg

  $message

----------
STACKTRACE_MESSAGE

		chomp $message;

		LOOP_OF_FRAMES:
		while ( my $frame = $trace->next_frame ) {

			my $start_line = $frame->line - $CONTEXT_LINE;
			my $end_line   = $frame->line + $CONTEXT_LINE;
			if ($start_line < 1) {
				$start_line = 1;
			}

			my @lines;
			open my $fh, "<", $frame->filename or die sprintf("can not open %s. %s", $frame->filename, $!);
			flock $fh, LOCK_EX                 or die sprintf("can not flock %s. %s", $frame->filename, $!);
			while ( my $line = <$fh> ) {

				chomp $line;
				my $current_line = $.;
				if ($current_line < $start_line || $current_line > $end_line) {
					next;
				}
				my $mark = ($current_line == $frame->line) ? "*" : " ";
				push @lines, sprintf("   %s %05d: %s", $mark, $current_line, $line);
			}
			close $fh or die sprintf("can not close %s. %s", $frame->filename, $!);

			my $package  = $frame->package;
			my $filename = $frame->filename;
			my $line     = $frame->line;
			my $lines    = join "\n", @lines;
			$stacktrace_message .= <
  $package at $filename line $line.

$lines

  ==========
STACKTRACE_MESSAGE

		} # end of LOOP_OF_FRAMES

		$stacktrace_message .= <
----------

STACKTRACE_MESSAGE

		# rethrow
		die $stacktrace_message;
	};

}

1;

__END__