| Current File : //proc/thread-self/root/usr/lib/x86_64-linux-gnu/perl5/5.38/Devel/Caller.pm |
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__
=head1 NAME
Devel::Caller - meatier versions of C<caller>
=head1 SYNOPSIS
use Devel::Caller qw(caller_cv);
$foo = sub { print "huzzah\n" if $foo == caller_cv(0) };
$foo->(); # prints huzzah
use Devel::Caller qw(called_with);
sub foo { print called_with(0,1); }
foo( my @foo ); # should print '@foo'
=head1 DESCRIPTION
=over
=item caller_cv($level)
C<caller_cv> gives you the coderef of the subroutine being invoked at
the call frame indicated by the value of $level
=item caller_args($level)
Returns the arguments passed into the caller at level $level
=item caller_vars( $level, $names )
=item called_with($level, $names)
C<called_with> returns a list of references to the original arguments
to the subroutine at $level. if $names is true, the names of the
variables will be returned instead
constants are returned as C<undef> in both cases
=item called_as_method($level)
C<called_as_method> returns true if the subroutine at $level was
called as a method.
=back
=head1 BUGS
All of these routines are susceptible to the same limitations as
C<caller> as described in L<perlfunc/caller>
The deparsing of the optree performed by called_with is fairly simple-minded
and so a bit flaky.
=over
=item
As a version 2.0 of Devel::Caller we no longer maintain compatibility with
versions of perl earlier than 5.8.2. Older versions continue to be available
from CPAN and backpan.
=back
=head1 SEE ALSO
L<perlfunc/caller>, L<PadWalker>, L<Devel::Peek>
=head1 AUTHOR
Richard Clamp <richardc@unixbeard.net> with close reference to
PadWalker by Robin Houston
=head1 COPYRIGHT
Copyright (c) 2002, 2003, 2006, 2007, 2008, 2010, 2013, 2023 Richard Clamp.
All Rights Reserved.
This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.
=cut