File Coverage

lib/Devel/CallStack.pm

Criterion	Covered	Total	%
statement	33	74	44.5
branch	17	52	32.6
condition	1	3	33.3
subroutine	9	13	69.2
pod	1	6	16.6
total	61	148	41.2

package Devel::CallStack;

require 5.006001;

use strict;

use vars qw($VERSION
	    $Depth $Full $Reverse $Stdout $Stderr $Out $In $Append
	    $Import
	    %Cumul);

$VERSION = '0.19';
$Depth = 1e9; # If someone has a callstack this deep, we are in trouble.
$Import = 0;

sub import {
    my $class = shift;
    for my $i (@_) {
	if ($i =~ /^(?:depth=)?(\d+)$/) {
	    $Depth = $1;
	} elsif ($i eq 'full') {
	    $Full = 1;
	} elsif ($i eq 'reverse') {
	    $Reverse = 1;
	} elsif ($i eq 'stdout') {
	    $Stdout = 1;
	} elsif ($i eq 'stderr') {
	    $Stderr = 1;
	} elsif ($i =~ /^out=(.+)/) {
	    $Out = $1;
	} elsif ($i =~ /^in(?:=(.+))?/) {
	    $In = $1 ne "" ? $1 : "callstack.out";
	} elsif ($i eq 'append') {
	    $Append = 1;
	} else {
	    die "Devel::CallStack::import: '$i' unknown\n";
	}
    }
    &set(); # Otherwise we get the import() call stack captured, too.
    &read($In) if defined $In;
    $Out = "callstack.out" unless defined $Out || $Stdout;
    $Import++; # Import was a success.
}

sub set {
    %Cumul = @_;
}

sub get {
    %Cumul;
}

sub write {
    if ($Import) {
	my $ofh;
	if ($Stdout) {
	    $ofh = select STDOUT;
	} elsif ($Stderr) {
	    $ofh = select STDERR;
	} elsif (defined $Out) {
	    my $mode = $Append ? ">>" : ">";
	    unless (open(OUT, "$mode$Out")) {
		die qq[Devel::CallStack::END: failed to open "$Out" for writing: $!\n];
	    }
	    $ofh = select OUT;
	}
	for my $s (sort keys %Cumul) {
	    next if $s =~ /Devel::CallStack/o; # We do not exist.
	    my $d = ($s =~ tr/,/,/) + 1;
	    print "$s $d $Cumul{$s}\n";
	}
	select $ofh;
    }
}

sub read {
    my $fn = shift;
    unless (open(IN, $fn)) {
	die qq[Devel::CallStack::read: failed to open "$fn" for reading: $!\n];
    }
    while () {
	my ($s, $d, $n) = split;
	$s = join(",", reverse split(/,/, $s)) if $Reverse;
	$Cumul{$s} += $n;
    }
    close(IN);
}

sub END {
    &write();
}

package DB;

use strict;

sub DB { }

use vars qw($Full $Depth $Reverse %Cumul);

*Depth   = \$Devel::CallStack::Depth;
*Full    = \$Devel::CallStack::Full;
*Reverse = \$Devel::CallStack::Reverse;
*Cumul   = \%Devel::CallStack::Cumul;

sub sub {
    if (my ($p, $s) = ($DB::sub =~ /^(.+)::(.+)/)) {
	my @s;
	if ($Full) {
	    if (my ($f, $l) = ($DB::sub{$DB::sub} =~ /^(.+):(\d+)/)) {
		@s = ( "$f:$l:${p}::$s" );
		for (my $i = 0; @s < $Depth; $i++) {
		    my @c = caller($i);
		    last unless @c;
		    push @s, "$c[1]:$c[2]:$c[3]";
		}
	    }
	} else {
	    @s = ( $DB::sub );
	    for (my $i = 0; @s < $Depth; $i++) {
		my @c = caller($i);
		last unless @c;
		push @s, $c[3];
	    }
	}
	$Cumul{
	       join ",", $Reverse ? @s : reverse @s # Ironic, no?
	      }++;
    }
    no strict 'refs';
    &{$DB::sub}(@_);
}

1;
__END__