File Coverage

blib/lib/Debug/Filter/PrintExpr.pm

Criterion	Covered	Total	%
statement	79	81	97.5
branch	20	22	90.9
condition	6	7	85.7
subroutine	23	23	100.0
pod			n/a
total	128	133	96.2

package Debug::Filter::PrintExpr;

use strict;
use warnings;

use 5.010;
use Filter::Simple;
use Scalar::Util qw(isdual blessed);
use List::Util 'pairs';
use Data::Dumper;
use B qw(svref_2object SVf_IOK SVp_IOK SVf_NOK SVp_NOK);

our
$VERSION = '0.19';

# variable is exposed and my be overwritten by caller
our $handle = *STDERR;

# helper function: tests if given variable has data
# in it's "numeric slot"
sub _isnumeric {
	return svref_2object(\$_[0])->FLAGS &
		(SVf_IOK | SVp_IOK | SVf_NOK | SVp_NOK);
}

# generate a prefix containing line number or custom label
# consume first three args, return number of printed chars
# if no expression is present
sub _genprefix {
	my ($label, $line, $expr, $pos) = splice @_, 0, 3;
	local ($,, $\);
	printf $handle "%s%n", $label || "L$line:", $pos;
	print $handle $expr ? " $expr = " : " ";
	return $expr ? undef : $pos + 1;
}

# create representation of single value
sub _singlevalue {
	my ($val, $str, $num) = shift;
	my $isdual = isdual($val);
	my $isnumeric = _isnumeric($val);
	$str = "$val" if defined $val;
	$num = $val + 0 if $isnumeric;
	if (!defined $val) {
		return 'undef';
	} elsif (my $class = blessed($val)) {
		return "blessed($class)";
	} elsif (ref($val)) {
		return $val;
	} elsif ($isdual) {
		return "dualvar($num, '$str')";
	} elsif ($isnumeric) {
		return $num;
	} else {
		return "'$str'";
	}
}

# print out an expression in scalar context
sub _valuescalar {
	local ($,, $\);
	print $handle _singlevalue($_[0]);
}

# print out an expression in list context
sub _valuearray {
	local ($,, $\);
	print $handle '(', join(', ',
		map({_singlevalue($_)} @_)), ");\n";
}

# print out an expression as key-value pairs
sub _valuehash {
	local ($,, $\);
	print $handle '(', join(", ",
		map(
		{"'$_->[0]' => " . _singlevalue($_->[1])}
		pairs(@_))), ");\n";
}

# process a scalar debug statement
sub _print_scalar {
	local ($,, $\);
	unless (&_genprefix) {
		_valuescalar($_[0]);
		print $handle ';';
	}
	print $handle "\n";
}

# process a string scalar debug statement
sub _print_str {
	my $val = $_[3];
	splice @_, 3, 1, "$val";
	goto &_print_scalar;
}

# process a numeric scalar debug statement
sub _print_num {
	no warnings qw(numeric);
	my $val = $_[3];
	splice @_, 3, 1, $val + 0;
	goto &_print_scalar;
}

# process an array debug statement
sub _print_array {
	&_genprefix;
	goto &_valuearray;
}

# process a hash debug statement
sub _print_hash {
	&_genprefix;
	goto &_valuehash;
}

# process a reference debug statement
sub _print_ref {
	my $expr = splice @_, 2, 1, undef;
	my $skip = &_genprefix;
	local ($,, $\);
	print $handle "dump($expr);\n";
	print $handle
		Data::Dumper->new([@_], [map("_[$_]", (0 .. $#_))])
		->Pad(' ' x $skip)->Dump;
}

# type classifications: print function suffix + is scalar
my %type_defs = (
	'$' => ['scalar', 1],
	'"' => ['str', 1],
	'#' => ['num', 1],
	'@' => ['array', 0],
	'%' => ['hash', 0],
	'\\' => ['ref', 0],
);

# process a debug statement, runs in filter context
sub _gen_print {
	my ($type, $label, $expr) = map $_ // '', @_;
	my $val = $_[2] // '()';
	my ($ptype, $scalar) = @{$type_defs{$type}};
	my $print = __PACKAGE__ . "::_print_$ptype";
	return qq[{$print("$label", __LINE__, q{$expr}, ] .
		($scalar ? qq[scalar($val)] : qq[$val]) .
		q[)}];
}

# source code processing happens here
FILTER {
	my ($self, @args) = @_;
	my $debug;
	$debug ||= grep /^-debug$/, @args;
	s/
		^\h*+\#
		(?[%@\$\\#"])
		\{\h*+
		(?[[:alpha:]_]\w*+:)?
		\h*+
		(?\V*[^\s])?\h*
		\}\h*+\r?$
	/ _gen_print($+{type}, $+{label}, $+{expr}) /gmex;
	print STDERR if $debug;
};

1;

__END__