File Coverage

blib/lib/Devel/Calltree.pm

Criterion	Covered	Total	%
statement	107	141	75.8
branch	23	50	46.0
condition	16	23	69.5
subroutine	22	26	84.6
pod	0	10	0.0
total	168	250	67.2

package Devel::Calltree;

use 5.006;
use strict;

use vars qw($VERSION);
use B::Utils;

$VERSION = '0.00_3';

our %OPT;
my $CURFILE;

use overload '@{}' =>
    sub {
	my $calls = shift;
	# the outer map() will turn __MAIN__ into 'z' x 100 in the hope
	# that this will put '__MAIN__' at the end of the list
	[   map $_->[0],
	    sort { $a->[1] cmp $b->[1] or $a->[2] cmp $b->[2] }
	    map [ $_, $_ ne '__MAIN__' ? /(.+)::(.+)/ : 'z' x 100 ], keys %$calls   ];
    };

sub import {
    my $class = shift;
    %OPT = @_;
    push @{ $OPT{-exclude} }, __PACKAGE__;
    if (my $h = $OPT{-output}) {
        if (ref($h) eq 'GLOB') {
            select $h;
        } else {
            open FH, ">$h" or die "Could not open $h for output: $!";
            select FH;
        }
    }
    # when -test is set, we are running the tests.
    # in order to get consistent output, $CURFILE will
    # be tied so that it always return 'XXX'.
    tie $CURFILE => "Devel::Calltree::testmode" if $OPT{-test};
    setup_reportfuncs($OPT{ -reportfuncs });
}

sub INIT {

    my %root = B::Utils::all_roots();
    remove_excluded(\%root);
    my @pkgs = get_packages(\%root);

    my %CALLS;
    while (my ($name, $root) = each %root) {
        my ($pkg) = $name =~ /(.*)::/;
        my @CALLS;

        # we pass the current package name ($pkg)
        # so that we can find the real
        # package of $pkg::func in find_subcall().
        B::Utils::walkoptree_simple($root, \&find_subcall, [\@CALLS, $pkg]);
        $CALLS{ $name } = bless [] => $CURFILE;
        for my $call (@CALLS) {
            push @{ $CALLS{$name} }, $call;
        }
    }
    my $calls = bless \%CALLS => __PACKAGE__;
    if (!$OPT{-iscalled}) {
        $calls->print_report;
    } else {
        $calls->print_report_called;
    }
    exit;
}

sub find_subcall {
    my ($op, $args) = @_;

    my ($data, $name) = @$args;

    $CURFILE = $B::Utils::file;

    # function call
    if ($op->name eq 'gv' && $op->next && $op->next->name eq 'entersub') {
        my $realfnc;
        my $fnc = join '::', $op->gv->STASH->NAME, $op->gv->NAME;

        # do we need to attempt resolving the real function name?
        # this assumes that a call to a fully qualified function
        # can be taken as is (unless it is main::func()).
        if ($op->gv->STASH->NAME eq $name or $op->gv->STASH->NAME eq 'main') {
            no strict 'refs';
            # not sure why this happens:
            # sometimes B::svref_2object(...)->STASH returns a B::SPECIAL
            # which has no NAME() method
            my $pkg = eval { B::svref_2object(\&$fnc)->STASH->NAME };
            $pkg ||= '??';
            $fnc =~ s/.*:://;
            $realfnc = "${pkg}::$fnc";
        } else {
            $realfnc = $fnc;
        }
        $B::Utils::file =~ tr#/##s; # squeeze: blib/lib//bla.pm => blib/lib/bla.pm
        push @$data, bless { name       => $realfnc,
                             line       => $B::Utils::line,
                             file       => $B::Utils::file,
                             is_method  => 0 } => 'Devel::Calltree::Func';
        return;
    }

    # method call
    if ($op->name eq 'method_named' && $op->next && $op->next->name eq 'entersub') {
        push @$data, bless { name       => $op->gv->PV,
                             line       => $B::Utils::line,
                             file       => $B::Utils::file,
                             is_method  => 1 } => 'Devel::Calltree::Func';
    }

}

sub print_report {
    my $calls = shift;
    for my $caller (@$calls) {
        my $file = file($calls->{ $caller });
        if (funcs($calls->{$caller}) || !$OPT{-filter_empty} ) {
            print "\n$caller  ($file): \n";
	    for my $targ (funcs($calls->{$caller})) {
                my $n = $targ->name;
                my $l = $targ->line;
                if ($targ->is_method) {
                    print "  method   '$n'", ' ' x (60 - 14 - length($n)), " ($l)\n";
                    next;
                }
                print "  function '$n'", ' ' x (60 - 14 - length($n)), " ($l)\n";
            }
        }
    }
}

sub print_report_called {

    my $calls = shift;
    my @funcs = @{ $OPT{ -iscalled } };
    my %notfound;
    @notfound{ @funcs } = ();
    my $pat = "(" . $funcs[0] . ")";
    $pat .= "|($_)" for @funcs[1..$#funcs];
    my @found;

    while (my ($caller, $candid) = each %$calls) {
        for (@$candid) {
            if ($_->name =~ /$pat/o) {
                delete $notfound{ $funcs[$+] };
                push @found, [ $caller, $_ ];
            }
        }
    }
    if (keys %notfound) {
        print "These patterns did not match any called function:\n";
        print "  $_\n" for keys %notfound;
        print "\n";
    }

    print "These functions were called:\n";
    for (sort { $a->[1]->name cmp $b->[1]->name } @found) {
        printf "  %-8s %-30s from %-30s at line %i\n", $_->[1]->is_method ? "method" : "function",
               $_->[1]->name, $_->[0], $_->[1]->line;
    }
}


sub remove_excluded {
    my $roots = shift;
    my @bad;
    my $patbad = join "|^", @{ $OPT{-exclude} };
    # no include pattern: come up with one that always fails
    my $patgood = join "|^", @{ $OPT{-include} || [ qw/&!%"§@@/ ]};
    $patbad = qr/^$patbad/;
    $patgood = qr/^$patgood/;

    for (keys %$roots) {
        push @bad, $_ if /$patbad/o && !/$patgood/o;
    }
    delete @$roots{ @bad };
}

sub get_packages {
   my $roots = shift;
   my %pkgs = map { /(.+)::/ ? $1 : __MAIN__ => 1 } keys %$roots;
   keys %pkgs;
}

sub array_to_hash {
    my @array = @_;
    my %hash;
    @hash{ @array } = (1) x @array;
    return %hash;
}

sub sort {
    my $self = shift;
    $self->{ "sorted\0" } = [ # prevent clash with function name
        map $_->[0],
        sort { $a->[1] cmp $b->[1] or $a->[2] cmp $b->[2] }
        map [ $_, $_ ne '__MAIN__' ? /(.+)::(.+)/ : 'z' x 100 ], keys %$self ];
}

sub setup_reportfuncs {
    my $file = shift;
    return if ! defined $file;
    local $^W = 0;
    unless (my $err = do $file) {
	die "Can't parse '$file':\n$@\n"    if $@;
	die "Can't open '$file':\n$!\n"	    if !defined $err;
	die "Can't run '$file':\nMaybe it didn't return a true value?\n";
    }
}

sub Devel::Calltree::Func::file         { shift->{ file } }
sub Devel::Calltree::Func::line         { shift->{ line } }
sub Devel::Calltree::Func::name         { shift->{ name } }
sub Devel::Calltree::Func::is_method    { shift->{ is_method } }


sub Devel::Calltree::testmode::TIESCALAR { bless \my $var => "Devel::Calltree::testmode" }
sub Devel::Calltree::testmode::FETCH     { "XXX" }
sub Devel::Calltree::testmode::STORE     { }

# functions to be used by the --reportfuncs snipplets

sub file    { my $f = ref $_[0]; $f =~ tr#/##s; $f }
sub funcs   { @{ $_[0] || [] } }

1;
__END__