File Coverage

blib/lib/Sub/Caller.pm

Criterion	Covered	Total	%
statement	41	53	77.3
branch	13	24	54.1
condition	9	15	60.0
subroutine	7	7	100.0
pod	0	3	0.0
total	70	102	68.6

package Sub::Caller;

require DynaLoader;

our $VERSION = '0.60';
our @ISA = qw(DynaLoader);
bootstrap Sub::Caller;
################################
my %change;

##
## We have to delay messing with functions
## until Perl has them all loaded.
##
sub import {
   shift;
   $change{caller()} = \@_;
}

##
## Now we can mess with functions
##
sub CHECK {
   for my $k (keys %change){
      addCaller([$k], @{$change{$k}});
   }
}


my $addCaller  = sub {
   my ($CALL, $call) = ({package=>undef, function=>undef, line=>undef, file=>undef}, 0);
   my $frames = @_?shift():5;

WR_GET_CALLER_FUNC:
   $call++;
   ($CALL->{function}) = (caller $call)[3];

   ## Keep going until we find an actual function call
   if ($CALL->{function} && $CALL->{function} =~ /ANON/ && $call < $frames){
      goto WR_GET_CALLER_FUNC;
   }
   elsif ($call < $frames){
      my ($c) = (caller ++$call)[3];
      $call-- and goto WR_GET_CALLER_FUNC if $c;
   }

   $CALL->{function}    =~ s/(.*):://;
   $CALL->{package}     = $1 || "main";
   $CALL->{function}    ||= "main";
   @$CALL{qw(file line)} = (caller(1))[1,2];

   bless $CALL;
};


sub addCaller {
   if (@_){
      my ($pkg) = ref $_[0]?shift()->[0]:caller();

      if ($_[0] =~ /all/i){
         shift;
         for my $f (keys %{$pkg."::"}){
            push @_, $f if (defined &{$pkg."::$f"} && checkFunc(\&{$pkg."::$f"}) eq $pkg);
         }
      }

      modifyCaller($pkg, @_);

      if (!defined &{$pkg."::aDdCaLLer"}){
         *{$pkg."::aDdCaLLer"} = $addCaller;
      }
   }
}


sub isCaller { ref $_[0] eq __PACKAGE__; }


sub modifyCaller {
   my ($pkg) = shift();

   for my $f (@_){
      ## Don't do anything for non-existant functions
      if (!defined(&{$pkg."::$f"})){ next; }

      ## Don't re-re-define functions else we get infinite loops
      if (defined(&{$pkg."::_$f"})){ next; }

      ## Create copy of original sub
      *{$pkg."::_$f"} = \&{$pkg."::$f"};

      ## Replace original sub with new version
      *{$pkg."::$f"} = sub {
            my $CALL = &{$pkg."::aDdCaLLer"}(2);
            ## Call original sub with caller data at end of stack
            if ($pkg eq 'main'){
               &{$pkg."::_$f"}(@_, $CALL);
            }
            ## Make sure objects get the package name first
            else{
               &{$pkg."::_$f"}($pkg, @_[1..$#_], $CALL);
            }
      };
   }
}

1;
__END__