PERL_TRACE_CALLS=1 prove -l t/sometest.t

##</code><code>##

{
   "Local::Example" : {
      "quux" : 1
   },
   "Local::Example::Module1" : {
      "bar" : 1
   },
   "Local::Example::Module2" : {
      "bar" : 1,
      "foo" : 1
   }
}

##</code><code>##

use strict;
use warnings;

package Devel::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;
	} || die($@) if ACTIVE;
};

our $JSON;
our %CALL;
$JSON = 'JSON::PP'->new->pretty(1)->canonical(1) if ACTIVE;

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"};
	my $subname = Sub::Util::subname($code);
	my $newcode =
		Sub::Util::set_prototype prototype($code),
		Sub::Util::set_subname $subname,
		sub { ++$CALL{$package}{$sub}; goto $code };
	*{"$package\::$sub"} = $newcode;
}

END {
	if (ACTIVE) {
		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;