File Coverage

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

Criterion	Covered	Total	%
statement	101	101	100.0
branch	20	20	100.0
condition			n/a
subroutine	15	15	100.0
pod	6	6	100.0
total	142	142	100.0

package Error::Pure::Output::Text;

# Pragmas.
use base qw(Exporter);
use strict;
use warnings;

# Modules.
use Readonly;

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

# Version.
our $VERSION = 0.21;

# 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 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.(shift @msg));
	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 = ('ERROR: '.(shift @msg));
	push @ret, _err_variables(@msg);
	foreach my $i (0 .. $#{$error_hr->{'stack'}}) {
		my $st = $error_hr->{'stack'}->[$i];
		my $ret = $st->{'class'};
		$ret .=  $SPACE x ($l_ar->[0] - length $st->{'class'});
		$ret .=  $st->{'sub'};
		$ret .=  $SPACE x ($l_ar->[1] - length $st->{'sub'});
		$ret .=  $st->{'prog'};
		$ret .=  $SPACE x ($l_ar->[2] - length $st->{'prog'});
		$ret .=  $st->{'line'};
		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 .= ': ';
	}
	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 "#Error [$prog:$stack_ar->[0]->{'line'}] $e\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 .= ': '.$t;
		}
		push @ret, $ret;
	}
	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__