File Coverage

blib/lib/Test/TraceCalls.pm

Criterion	Covered	Total	%
statement	23	46	50.0
branch	0	8	0.0
condition			n/a
subroutine	9	15	60.0
pod	0	2	0.0
total	32	71	45.0

use strict;
use warnings;

package Test::TraceCalls;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.001';

use constant ACTIVE => $ENV{'PERL_TRACE_CALLS'};

BEGIN {
	eval q{
		use match::simple ();
		use Carp ();
		use File::Spec ();
		use FindBin ();
		use Hook::AfterRuntime ();
		use JSON::PP ();
		use Sub::Util 1.40 ();
		1;
	} || die($@) if ACTIVE;
};

our %CALL;

sub import {
	my $me = shift;
	my $caller = caller;
	my (%opts) = @_;
	&Hook::AfterRuntime::after_runtime(
		sub { $me->setup_for($caller, %opts) },
	) if ACTIVE;
}

sub setup_for {
	my $me = shift;
	my ($caller, %opts) = @_;
	$opts{match} = sub {
		local $_ = shift;
		!/^_/ and /\p{Ll}/;
	} unless exists $opts{match};
	no strict 'refs';
	my @names =
		grep  match::simple::match($_, $opts{match}),
		grep !/::$/,
		sort keys %{"$caller\::"};
	$me->wrap_sub($caller, $_) for @names;
}

sub wrap_sub {
	my $me = shift;
	no strict 'refs';
	no warnings 'redefine';
	my ($package, $sub) = @_;
	($package, $sub) = (/^(.+)::([^:]+)$/ =~ $package)
		if !defined $sub;
	my $code    = \&{"$package\::$sub"} or return;
	my $newcode =
		Sub::Util::set_prototype Sub::Util::prototype($code),
		Sub::Util::set_subname Sub::Util::subname($code),
		sub { ++$CALL{$package}{$sub}; goto $code };
	*{"$package\::$sub"} = $newcode;
}

END {
	if (ACTIVE) {
		my $JSON = 'JSON::PP'->new->pretty(1)->canonical(1);
		my $map  = $JSON->encode(\%CALL);

		my $outfile = 'File::Spec'->catfile(
			$FindBin::RealBin,
			$FindBin::RealScript . ".map",
		);
		my $already = 0;

		if (-f $outfile) {
			my $slurped = do {
				local $/; my $fh;
				open($fh, '<', $outfile) ? <$fh> : undef;
			};
			$already++ if $slurped eq $map;
		}

		if (!$already) {
			open my $outfh, '>', $outfile
				or Carp::croak("Cannot open $outfile for output: $!");
			print {$outfh} $map
				or Carp::croak("Cannot write to $outfile: $!");
			close $outfh
				or Carp::croak("Cannot close $outfile: $!");
		}
	};
}

1;

__END__