File Coverage

blib/lib/Devel/Caller.pm

Criterion	Covered	Total	%
statement	86	103	83.5
branch	44	80	55.0
condition	10	16	62.5
subroutine	12	12	100.0
pod	4	5	80.0
total	156	216	72.2

use strict;
package Devel::Caller;
use warnings;
use B qw( peekop );
use PadWalker ();
use XSLoader;
use base qw( Exporter  );
use 5.008;

our $VERSION = '2.07';
XSLoader::load __PACKAGE__, $VERSION;

our @EXPORT_OK = qw( caller_cv caller_args caller_vars called_with called_as_method );

sub caller_cv {
    my $level = shift;
    my $cx = PadWalker::_upcontext($level + 1);
    return unless $cx;
    return _context_cv($cx);
}

our $DEBUG = 0;

# scan forward through the ops noting the pushmark or a padrange ops.
# These indicate the start of a subroutine call.  We're looking for the most
# recent one before the subroutine invocation (the entersub).
sub scan_forward {
    my $op = shift;
    die "was expecting a pushmark or a padrange, not a " . $op->name
      if ($op->name !~ /^(?:pushmark|padrange)$/);

    my @stack;
    for (; $op && $op->name ne 'entersub'; $op = $op->next) {
        print "SCAN ", peekop($op), "\n" if $DEBUG;
        if ($op->name eq "pushmark" or $op->name eq "padrange") {
            print "   PUSH\n" if $DEBUG;
            push @stack, $op;
        }
        elsif (0) { # op consumes a mark
            print "   POP\n" if $DEBUG;
            pop @stack;
        }
    }
    return pop @stack;
}

*caller_vars = \&called_with;
sub called_with {
    my $level = shift;
    my $want_names = shift;

    my $op  = _context_op( PadWalker::_upcontext( $level + 1 ));
    my $cv  = caller_cv( $level + 2 );
    my $pad = $cv ? B::svref_2object( $cv )->PADLIST : B::comppadlist;
    my $padn = $pad->ARRAYelt( 0 );
    my $padv = $pad->ARRAYelt( 1 );

    print "Context OP: ", peekop($op), "\n" if $DEBUG;
    $op = scan_forward( $op );
    print "Scanned forward to ", peekop($op), "\n" if $DEBUG;

    my @return;
    my $prev;

    # We're scanning through looking for ops which are pushing
    # variables onto the stack (/pad(sv|av|hv)/ push from the pad,
    # /gvsv|rv2([ahg]v/ are from globs.
    for (; $op && $op->name ne 'entersub'; ($prev = $op) && ($op = $op->next)) {
        printf "Loop: %s %s targ: %d\n", peekop($op), $op->name, $op->targ if $DEBUG;

        if ($op->name eq "padrange") {
            # A padrange is a 5.17 optimisation that uses a single op to
            # load multiple pad variables onto the stack.  The old ops
            # are preserved and are reachable as the padrange's sibling
            # so that B::Deparse can pessimise it back to that state.
            #
            # http://perl5.git.perl.org/perl.git/commitdiff/0fe870f5
            # http://perl5.git.perl.org/perl.git/commitdiff/a7fd8ef6
            #
            # We could use the B::Deparse method, but it's probably simpler if
            # we just reassign $op.
            print "padrange, diverting down ", $prev->sibling, "\n" if $DEBUG;
            $op = $op->sibling;
        }

        if ($op->name =~ /padsv_store/) {
            # A padsv_store is a 5.37 optimization that combines a padsv and
            # an sassign into a single op. The new op steals the targ slot
            # of the original padsv.
            #
            # https://github.com/Perl/perl5/commit/9fdd7fc
            print "Copying from pad\n" if $DEBUG;
            if ($want_names) {
                push @return, $padn->ARRAYelt( $op->targ )->PVX;
            }
            else {
                push @return, $padv->ARRAYelt( $op->targ )->object_2svref;
            }
            next;
        }
        elsif ($op->name =~ "pad(sv|av|hv)") {
            if ($op->next->next->name eq "sassign") {
                print "sassign in two ops, this is the target skipping\n" if $DEBUG;
                next;
            } elsif ($op->next->name eq "padsv_store") {
                print "padsv_store in one op, this is the target, skipping\n" if $DEBUG;
                next;
            }

            print "Copying from pad\n" if $DEBUG;
            if ($want_names) {
                push @return, $padn->ARRAYelt( $op->targ )->PVX;
            }
            else {
                push @return, $padv->ARRAYelt( $op->targ )->object_2svref;
            }
            next;
        }
        elsif ($op->name =~ /gvsv|rv2(av|hv|gv)/) {
            if ($op->next->next->name eq "sassign") {
                print "sassign in two ops, this is the target, skipping\n" if $DEBUG;
                next;
            }

            my $consider = ($op->name eq "gvsv") ? $op : $prev;
            my $gv;

            if (ref $consider eq 'B::PADOP') {
                print "GV is really a padgv\n" if $DEBUG;
                $gv = $padv->ARRAYelt( $consider->padix );
                print "NEW GV $gv\n" if $DEBUG;
            }
            else {
                $gv = $consider->gv;
            }

            print "consider: $consider ", $consider->name, " gv $gv\n"
              if $DEBUG;

            if ($want_names) {
                my %sigils = (
                    "gvsv"  => '$',
                    "rv2av" => '@',
                    "rv2hv" => '%',
                    "rv2gv" => '*',
                   );

                push @return, $sigils{ $op->name } . $gv->STASH->NAME . "::" . $gv->SAFENAME;
            }
            else {
                my %slots = (
                    "gvsv"  => 'SCALAR',
                    "rv2av" => 'ARRAY',
                    "rv2hv" => 'HASH',
                    "rv2gv" => 'GLOB',
                   );
                push @return, *{ $gv->object_2svref }{ $slots{ $op->name} };
            }

            next;
        }
        elsif ($op->name eq "const") {
            if ($op->next->next->name eq "sassign") {
                print "sassign in two ops, this is the target, skipping\n" if $DEBUG;
                next;
            } elsif ($op->next->name eq "padsv_store") {
                print "padsv_store in one op, this is the target, skipping\n" if $DEBUG;
                next;
            }

            push @return, $want_names ? undef : $op->sv;
            next;
        }
    }
    return @return;
}


sub called_as_method {
    my $level = shift || 0;
    my $op = _context_op( PadWalker::_upcontext( $level + 1 ));

    print "called_as_method: $op\n" if $DEBUG;
    die "was expecting a pushmark or pad, not a ". $op->name
      unless $op->name eq "pushmark";
    while (($op = $op->next) && ($op->name ne "entersub")) {
        print "method: ", $op->name, "\n" if $DEBUG;
        return 1 if $op->name =~ /^method(?:_named)?$/;
    }
    return;
}


sub caller_args {
    my $level = shift;
    package DB;
    () = caller( $level + 1 );
    return @DB::args
}

1;
__END__