File Coverage

blib/lib/Debug/Show.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	5	6	83.3
condition	2	6	33.3
subroutine	10	11	90.9
pod	2	2	100.0
total	67	74	90.5

=head1 NAME

Debug::Show - display variables helpfully for debugging

=head1 SYNOPSIS

	use Debug::Show qw(debug=hide);   # normally
	use Debug::Show qw(debug=show);   # while debugging

	debug $foo, $bar->{baz};

=head1 DESCRIPTION

This module provides a facility for displaying variable values for
debugging purposes.  Statements in the code determine what values are
displayed.  Whether the statements actually cause debugging output depends
on the manner in which C was invoked, so the debug statements
can remain permanently in the code, normally inactive.  When inactive,
the debug statements impose no runtime overhead.

When the debug statements are active, each value displayed is labelled
with the expression used to generate it.  This saves the bother of
manually applying labels.

=cut

package Debug::Show;

{ use 5.006; }
use warnings;
use strict;

use B::CallChecker 0.000 qw(cv_set_call_checker ck_entersub_args_proto);
BEGIN {
	# B::Generate provides a broken version of B::COP->warnings, which
	# makes B::Deparse barf [rt.cpan.org #70396], and of B::SVOP->sv,
	# which makes B::Concise emit rubbish [rt.cpan.org #70398].
	# This works around it by restoring the non-broken versions,
	# provided that B::Generate hasn't already been loaded.  If it
	# was loaded by someone else, better hope they worked around it
	# the same way.
	require B;
	my $cop_warnings = \&B::COP::warnings;
	my $svop_sv = \&B::SVOP::sv;
	require B::Generate;
	no warnings "redefine";
	*B::COP::warnings = $cop_warnings;
	*B::SVOP::sv = $svop_sv;
	B::Generate->VERSION(1.33);
}
use Carp qw(croak);

our $VERSION = "0.000";

=head1 FUNCTIONS

These functions are not exported in the normal way.  See below for how
to import.  The functions may be referenced directly by fully qualified
name (e.g., C).

=over

=item debug_show(EXPR, ...)

Display (via C) the values of all the argument expressions.
There may be any number of argument expressions.  Each value is deeply
serialised (by means of C), and is labelled with source
for the expression that evaluated to it (generated by C).
All the expresssions are evaluated in scalar context, so say C<\%foo>
rather than C<%foo> if you want to display the contents of a hash.
The entire display consists of a single line.

=cut

my $dumper_initialised;
sub debug_show {
	unless($dumper_initialised) {
		require Data::Dumper;
		Data::Dumper->VERSION(2.11);
		$dumper_initialised = 1;
	}
	my @part = ("###");
	while(@_) {
		my $label = shift(@_);
		my $value = shift(@_);
		my $dumper = Data::Dumper->new([$value]);
		$dumper->Terse(1);
		$dumper->Indent(0);
		$dumper->Useqq(1);
		$dumper->Quotekeys(0);
		$dumper->Sortkeys(1);
		push @part, " ", $label, " = ", $dumper->Dump, ";";
	}
	push @part, "\n";
	warn join("", @part);
}

my $deparser_initialised;
cv_set_call_checker(\&debug_show, sub ($$$) {
	my($entersubop, $namegv, undef) = @_;
	unless($deparser_initialised) {
		require B::Compiling;
		B::Compiling->VERSION(0.01);
		require B::Deparse;
		B::Deparse->VERSION(0.64);
		$deparser_initialised = 1;
	}
	my $deparser = B::Deparse->new;
	# Beware, this knows too much about B::Deparse internals.
	# Would prefer to have a proper interface to parse ops in
	# (relative) isolation.
	$deparser->{curcv} = $entersubop->find_cv;
	$deparser->{curcop} = B::Compiling::PL_compiling();
	my $foreop = $entersubop->first;
	$foreop = $foreop->first if $foreop->sibling->isa("B::NULL");
	my $n = 0;
	until((my $argop = $foreop->sibling)->sibling->isa("B::NULL")) {
		my $expr = eval {
			local $SIG{__DIE__};
			# The 50 here is a precedence value.  This is a
			# very high precedence, forcing any non-atomic
			# expression to be parenthesised.
			$deparser->indent($deparser->deparse($argop, 50));
		} || "'???'";
		print $@ if $@ ne "";
		$expr =~ s/\n[\t ]*/ /g;
		my $exprop = B::SVOP->new("const", 0, $expr);
		$exprop->sibling($argop);
		$foreop->sibling($exprop);
		$foreop = $argop;
		$n++;
	}
	return ck_entersub_args_proto($entersubop, $namegv, \("\$\$"x$n));
}, \!1);

=item debug_hide(EXPR, ...)

Do nothing.  Calls to this function are excised at compile time, so
there is no overhead from evaluating the argument expressions or calling
the subroutine.

=cut

sub debug_hide { }

cv_set_call_checker(\&debug_hide, sub ($$$) {
	my($entersubop, undef, undef) = @_;
	# B::Generate doesn't offer a way to explicitly free ops.
	# We ought to be able to implicitly free $entersubop via constant
	# folding, by something like
	#
	#     return B::LOGOP->new("and", 0,
	#         B::SVOP->new("const", 0, !1),
	#         $entersubop);
	#
	# but empirically that causes memory corruption and it's not
	# clear why.  For the time being, leak $entersubop.
	return B::SVOP->new("const", 0, !1);
}, \!1);

=back

=head1 PACKAGE METHOD

This method is meant to be invoked on the C package.
It will normally be accessed through the C facility.

=over

=item Debug::Show->import("debug=show")

Puts the subroutine L into the caller's namespace under
the name "C".

=item Debug::Show->import("debug=hide")

Puts the subroutine L into the caller's namespace under
the name "C".

=cut

sub import {
	croak "bad importation from $_[0]"
		unless @_ == 2 && ref($_[1]) eq "" &&
			$_[1] =~ /\Adebug=(?:show|hide)\z/;
	no strict "refs";
	*{caller(0)."::debug"} =
		$_[1] eq "debug=show" ? \&debug_show : \&debug_hide;
}

=back

=head1 BUGS

The operation of this module depends on L.  That module has
been found to interact badly with other C modules in some cases.
This module includes workarounds for known bugs, but others may lurk.

Because the expression source in the output is generated by
L, it cannot be expected to match the original source
character-for-character.  It will normally be equivalent source.  In some
obscure cases the deparser generates incorrect output; that is a bug
in L.  The kinds of expression that confuse the deparser
are relatively unlikely to occur with expressions being displayed for
debugging.

The shenanigans that take place with the debug functions at compile time
will make L produce incorrect output for the debug statements.

When hiding debug output, the ops corresponding to the debug expressions,
which ought to be freed, are instead leaked.  This is because freeing
them has been observed to cause memory corruption.  The cause of this
is currently unknown.  The leakage should have negligible impact, unless
debug statements occur in code that is repeatedly generated dynamically.

=head1 SEE ALSO

L,
L

=head1 AUTHOR

Andrew Main (Zefram)

=head1 COPYRIGHT

Copyright (C) 2011 Andrew Main (Zefram)

=head1 LICENSE

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;