view release on metacpan or  search on metacpan

lib/Devel/CompiledCalls.pm  view on Meta::CPAN

	cv_get_call_checker
	cv_set_call_checker
);
use Sub::Identify qw(sub_fullname);

our $VERSION = "2.00";

=head1 NAME

Devel::CompiledCalls - show where calls to a named subroutine are compiled

=head1 SYNOPSIS

  # from the shell
  shell$ perl -c -MDevel::CompiledCalls=Data::Dumper::Dumper myscript.pl
  Data::Dumper::Dumper call at myscript.pl line 4.
  Data::Dumper::Dumper call at myscript.pl line 5.
  myscript.pl syntax OK

  # from within a Perl script
  use Devel::CompiledCalls qw(Data::Dumper::Dumper);

  # from a perl script with custom callback
  use Devel::CompiledCalls;
  BEGIN {
    Devel::CompiledCalls::attach_callback("Data::Dumper::Dumper", sub {
      my ($subname, $filename, $line) = @_;
      say "$subname at $line of $filename";
    });
  };

=head1 DESCRIPTION

This module allows you to put hooks into Perl so that whenever a call to
a named subroutine has been compiled a callback is fired.  The easiest syntax
(import Devel::CompiledCalls and pass the name of the subroutine) simply
logs the line and filename of the call to STDERR.

Note that since we are hooking the process of compiling not the execution of
the subroutines (technically, we're hooking the process of subroutine parameter
checking, but the effects are the same) this module will find calls that aren't
normally captured by modules like Hook::LexWrap because they're not normally
executed during the program's execution (e.g. a call in exception handling code
that only occurs once every four years.)

=head2 Use with import

The simpliest way to to hook is to pass the name of the function in the
import list:

    use Devel::CompiledCalls qw(foo);
    ...

Or from the command line:

    perl -MDevel::CompiledCalls=foo -e '...'

In both these cases the standard callback - which simply prints to STDERR - will
be installed.

=head2 Custom callbacks

Custom callbacks can be installed with the C<attach_callback> subroutine.
This routine is not exported and must be called with a fully qualified
function call.

=over

=item attach_callback( $subroutine_ref, $callback )

=item attach_callback( $subroutine_name, $callback )

The callback will be called whenever a call to the subroutine is compiled.  The
subroutine can either be passed by reference, by fully qualified name (including
the package,) or by just the subroutine name (in which case it will be assumed
to be in the same package as C<attach_callback> is called from.)

The callback will be executed with three parameters: The name of the subroutine,
the filename of the source file, and the the line of the sourcefile that
contains the subroutine.

=back

=cut

sub import {
	shift;
	attach_callback($_, sub {
		my ($name, $file, $line,$stash) = @_;
		local $\ = undef;  # locally reset back to default just in case
		print {*STDERR} "$name call at $file line $line.\n";
	}) foreach @_;
	return;
}

sub attach_callback {
	my $name = shift;
	my $callback = shift;

	# check for an unqualifed subroutine name.  If we have one
	# then we need to give it our *caller's* package (or, potentially
	# our caller's caller package
	my $fully_qualified_name =
		ref $name eq "CODE" ? $name :
		$name =~ /::/x      ? $name  : do {
			my $caller_package;
			my $level = 1;
			do { ($caller_package) = caller($level++) }
				while ($caller_package eq __PACKAGE__);
			$caller_package.'::'.$name;
		};
	$name = sub_fullname($name) if ref($name) eq "CODE";

	# get the sub (this will spring into existence with autovivication
	# if needed)
	my $uboat = do { no strict 'subs'; \&{$fully_qualified_name} };

	# work out what original check would have been made
	my ($original_check, $data) = cv_get_call_checker($uboat);

	# install our own checker that doesn't actually do any checking
	# but instead simply calls the callback
	cv_set_call_checker($uboat, sub {