File Coverage

blib/lib/Error/Pure/Output/ANSIColor.pm

Criterion	Covered	Total	%
statement	15	112	13.3
branch	0	22	0.0
condition			n/a
subroutine	5	17	29.4
pod	7	7	100.0
total	27	158	17.0

package Error::Pure::Output::ANSIColor;

use base qw(Exporter);
use strict;
use warnings;

use Readonly;
use Term::ANSIColor;

Readonly::Array our @EXPORT_OK => qw(err_bt_pretty err_bt_pretty_rev err_die
	err_line err_line_all err_print err_print_var);
Readonly::Scalar our $EMPTY_STR => q{};
Readonly::Scalar our $SPACE => q{ };

our $EPANSI_CLASS_COLOR = 'blue';
our $EPANSI_ERROR_COLOR = 'red';
our $EPANSI_LINE_COLOR = 'yellow';
our $EPANSI_OTHER_COLOR = 'cyan';
our $EPANSI_SCRIPT_COLOR = 'yellow';
our $EPANSI_SUB_COLOR = 'green';

our $VERSION = 0.02;

# Pretty print of backtrace.
sub err_bt_pretty {
	my @errors = @_;
	my @ret;
	my $l_ar = _lenghts(@errors);
	foreach my $error_hr (@errors) {
		push @ret, _bt_pretty_one($error_hr, $l_ar);
	}
	return wantarray ? @ret : (join "\n", @ret)."\n";
}

# Reverse pretty print of backtrace.
sub err_bt_pretty_rev {
	my @errors = @_;
	my @ret;
	my $l_ar = _lenghts(@errors);
	foreach my $error_hr (reverse @errors) {
		push @ret, _bt_pretty_one($error_hr, $l_ar);
	}
	return wantarray ? @ret : (join "\n", @ret)."\n";
}

# Pretty print of classic die.
sub err_die {
	my @errors = @_;
	my $error = join $EMPTY_STR, @{$errors[-1]->{'msg'}};
	if ($error eq 'undef') {
		$error = 'Died';
	}
	my $stack_ar = $errors[-1]->{'stack'};
	my $die = color($EPANSI_ERROR_COLOR).$error.
		color($EPANSI_OTHER_COLOR).' at '.
		color($EPANSI_SCRIPT_COLOR).$stack_ar->[0]->{'prog'}.
		color($EPANSI_OTHER_COLOR).' line '.
		color($EPANSI_LINE_COLOR)."$stack_ar->[0]->{'line'}.".
		color('reset');
	return $die;
}

# Pretty print line error.
sub err_line {
	my @errors = @_;
	return _err_line($errors[-1]);
}

# Pretty print with errors each on one line.
sub err_line_all {
	my @errors = @_;
	my $ret;
	foreach my $error_hr (@errors) {
		$ret .= _err_line($error_hr);
	}
	return $ret;
}

# Print error.
sub err_print {
	my @errors = @_;
	my $class = _err_class($errors[-1]);
	return $class.$errors[-1]->{'msg'}->[0];
}

# Print error with all variables.
sub err_print_var {
	my @errors = @_;
	my @msg = @{$errors[-1]->{'msg'}};
	my $class = _err_class($errors[-1]);
	my @ret = ($class.color($EPANSI_ERROR_COLOR).(shift @msg).color('reset'));
	push @ret, _err_variables(@msg);
	return wantarray ? @ret : (join "\n", @ret)."\n";
}

# Pretty print one error backtrace helper.
sub _bt_pretty_one {
	my ($error_hr, $l_ar) = @_;
	my @msg = @{$error_hr->{'msg'}};
	my @ret = (color($EPANSI_OTHER_COLOR).'ERROR: '.
		color($EPANSI_ERROR_COLOR).(shift @msg).color('reset'));
	push @ret, _err_variables(@msg);
	foreach my $i (0 .. $#{$error_hr->{'stack'}}) {
		my $st = $error_hr->{'stack'}->[$i];
		my $ret = color($EPANSI_CLASS_COLOR).$st->{'class'}.color('reset');
		$ret .=  $SPACE x ($l_ar->[0] - length $st->{'class'});
		$ret .=  color($EPANSI_SUB_COLOR).$st->{'sub'}.color('reset');
		$ret .=  $SPACE x ($l_ar->[1] - length $st->{'sub'});
		$ret .= color($EPANSI_SCRIPT_COLOR).$st->{'prog'}.color('reset');
		$ret .=  $SPACE x ($l_ar->[2] - length $st->{'prog'});
		$ret .=  color($EPANSI_LINE_COLOR).$st->{'line'}.color('reset');
		push @ret, $ret;
	}
	return @ret;
}

# Print class if class isn't main.
sub _err_class {
	my $error_hr = shift;
	my $class = $error_hr->{'stack'}->[0]->{'class'};
	if ($class eq 'main') {
		$class = $EMPTY_STR;
	}
	if ($class) {
		$class = color($EPANSI_CLASS_COLOR).$class.
			color($EPANSI_OTHER_COLOR).': '.color('reset');
	}
	return $class;
}

# Pretty print line error.
sub _err_line {
	my $error_hr = shift;
	my $stack_ar = $error_hr->{'stack'};
	my $msg = $error_hr->{'msg'};
	my $prog = $stack_ar->[0]->{'prog'};
	$prog =~ s/^\.\///gms;
	my $e = $msg->[0];
	chomp $e;
	return color($EPANSI_OTHER_COLOR).'#Error ['.color($EPANSI_SCRIPT_COLOR).$prog.
		color($EPANSI_OTHER_COLOR).':'.color($EPANSI_LINE_COLOR).$stack_ar->[0]->{'line'}.
		color($EPANSI_OTHER_COLOR).'] '.color($EPANSI_ERROR_COLOR).$e.color('reset')."\n";
}

# Process variables.
sub _err_variables {
	my @msg = @_;
	my @ret;
	while (@msg) {
		my $f = shift @msg;
		my $t = shift @msg;

		if (! defined $f) {
			last;
		}
		my $ret = $f;
		if (defined $t) {
			chomp $t;
			$ret .= color($EPANSI_OTHER_COLOR).': '.
				color($EPANSI_ERROR_COLOR).$t.color('reset');
		}
		push @ret, color($EPANSI_ERROR_COLOR).$ret.color('reset');
	}
	return @ret;
}

# Gets length for errors.
sub _lenghts {
	my @errors = @_;
	my $l_ar = [0, 0, 0];
	foreach my $error_hr (@errors) {
		foreach my $st (@{$error_hr->{'stack'}}) {
			if (length $st->{'class'} > $l_ar->[0]) {
				$l_ar->[0] = length $st->{'class'};
			}
			if (length $st->{'sub'} > $l_ar->[1]) {
				$l_ar->[1] = length $st->{'sub'};
			}
			if (length $st->{'prog'} > $l_ar->[2]) {
				$l_ar->[2] = length $st->{'prog'};
			}
		}
	}
	$l_ar->[0] += 2;
	$l_ar->[1] += 2;
	$l_ar->[2] += 2;
	return $l_ar;
}

1;

__END__