Devel-Caller-2.07/0000755000175000017500000000000014415234305014022 5ustar richardcrichardcDevel-Caller-2.07/Changes0000644000175000017500000000462614415234235015327 0ustar richardcrichardc2.07 Tuesday 11th April, 2023 Fix compatibility with bleadperl https://rt.cpan.org/Public/Bug/Display.html?id=144051 Small Pod and Distribution cleanups contributed by Tom Hukins based on other rt.cpan tickets https://github.com/richardc/perl-devel-caller/pull/1 2.06 Wednesday 16th January, 2013 Corrected some pod syntax RT#56456 Handle the new padrange op added in 5.17 RT#81704 2.05 Thursday 8th April, 2010 Don't call B::PADOP->gv. Work by by Florian Ragwitz http://github.com/rafl/perl-devel-caller/commit/248a23390eef48a73bb717be085da58ce50ff784 2.04 Tuesday 16th February, 2010 Use CxTYPE macro rather than directly inspecting cx->cx_type http://rt.cpan.org/Public/Bug/Display.html?id=33005 2.03 Tuesday 8th January, 2008 Rerelease from a linux host to avoid hateful OSX and its hateful resource forks http://rt.cpan.org/Ticket/Display.html?id=32154 2.02 Friday 28th December, 2007 Make use of INT2PTR macro for great justice! (or 64-bit stuff, it's hard to tell) 2.01 Thursday 27th December, 2007 Translated the XS and C into perl using B. Though the perl looks much like C this gives a chance to make it more perlish in the future. There's a tiny bit of XS left to expose some internals to perl space. Dropped compatibilty for older perls (PadWalker doesn't work there anyway) 0.11 Sunday 9th July, 2006 Fudge around the segfaults in 5.8.x ithreaded builds by not looking up what the package variable is. 0.10 Wednesday 5th July, 2006 Use strlen rather than playing with SvLEN/SvCUR to determine the length of identifiers in the pad. It's a theoretical segfault waiting to happen, but one that isn't tickled by the current test suite. Fixes failures under perl 5.8.8 as reported by clkao. 0.09 Sunday 5th October, 2003 Split Changes out from HISTORY pod section. Port to Module::Build We can now determine constant values in called_with. Partial fixes for http://rt.cpan.org/NoAuth/Bug.html?id=2878 0.08 2003-03-28 Added caller_vars as a synonym for called_with Added caller_args 0.07 2002-11-21 Fix to called_as_method from Rafael Garcia-Suarez to handle $foo->$method() calls. 0.06 2002-11-20 Added called_as_method routine 0.05 2002-07-25 Fix a segfault under ithreads. Cleaned up some development cruft that leaked out while rushing. 0.04 2002-07-01 Decode glob params too. 0.03 2002-04-02 Refactored to share the upcontext code from PadWalker 0.08 Devel-Caller-2.07/Makefile.PL0000644000175000017500000000137614415234235016005 0ustar richardcrichardc#!perl use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Devel::Caller', AUTHOR => 'Richard Clamp ', LICENSE => 'perl', VERSION_FROM => 'lib/Devel/Caller.pm', ABSTRACT_FROM => 'lib/Devel/Caller.pm', PREREQ_PM => { 'Test::More' => 0, 'PadWalker' => '0.08' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/richardc/perl-devel-caller.git', web => 'https://github.com/richardc/perl-devel-caller', }, license => 'http://dev.perl.org/licenses/', }, }, ); Devel-Caller-2.07/t/0000755000175000017500000000000014415234304014264 5ustar richardcrichardcDevel-Caller-2.07/t/Devel-Caller.t0000644000175000017500000001401514415226244016715 0ustar richardcrichardc#!perl -w use strict; use Test::More tests => 72; BEGIN { use_ok( 'Devel::Caller', qw( caller_cv caller_args caller_vars called_with called_as_method ) ) } package CV; use Test::More; my $cv; $cv = sub { is( ::caller_cv(0), $cv, "caller_cv" ); }; $cv->(); sub foo { bar(my $bar) } sub bar { baz(my $baz) } sub baz { check(my $check) } sub check { my $i = 0; for (qw( check baz bar foo )) { is( ::caller_cv($i), \&{"CV::$_"}, "caller_cv $i is $_" ); is_deeply( [::called_with($i,1)], [ "\$$_" ], "called_with $i is \$$_" ); ++$i; } } foo(my $foo); package main; my (@foo, %foo); sub called_lex { my @called = called_with(0); is( scalar @called, 3, "right count"); is( $called[0], \$foo, "with lexical \$foo" ); is( $called[1], \@foo, "with lexical \@foo" ); is( $called[2], \%foo, "with lexical \%foo" ); } called_lex($foo, @foo, %foo); sub called_lex_names { my @called = called_with(0, 1); is( @called, 3, "right count"); is( $called[0], '$foo', "with lexical name \$foo" ); is( $called[1], '@foo', "with lexical name \@foo" ); is( $called[2], '%foo', "with lexical name \%foo" ); } called_lex_names($foo, @foo, %foo); # called_with muddied with assignments my @expect; my $what; sub called_assign { is_deeply([ called_with(0, 1) ], \@expect, "$what called_assign(".join(', ', map { $_ || "undef"} @expect).")"); } $what = 'constant'; { my $foo; @expect = undef; called_assign('foo'); @expect = (undef, '$foo'); called_assign('foo', $foo); @expect = (undef, '$foo'); called_assign(['foo'], $foo); } $what = 'lexical create'; { # test scalars @expect = qw( $bar ); called_assign(my $bar = q(some value)); @expect = qw( $baz ); called_assign(my $baz = $foo); @expect = qw( $quux $bar ); called_assign(my $quux = $foo, $bar); } { # same again for arrays @expect = qw( @bar ); called_assign(my @bar = qw(some values)); @expect = qw( @baz ); called_assign(my @baz = @foo); @expect = qw( @quux @bar ); called_assign(my @quux = @foo, @bar); @expect = qw( @flange ); called_assign(my @flange = (@foo, @bar)); } { # and again for hashes @expect = qw( %bar ); called_assign(my %bar = qw(some values)); @expect = qw( %baz ); called_assign(my %baz = %foo); @expect = qw( %quux %bar ); called_assign(my %quux = %foo, %bar); @expect = qw( %flange ); called_assign(my %flange = (%foo, %bar)); } $what = 'lexical prexist'; { # test scalars my ($bar, $baz, $quux); @expect = qw( $bar ); called_assign($bar = q(some value)); @expect = qw( $baz ); called_assign($baz = $foo); @expect = qw( $quux $bar ); called_assign($quux = $foo, $bar); } { # same again for arrays my (@bar, @baz, @quux, @flange); @expect = qw( @bar ); called_assign(@bar = qw(some values)); @expect = qw( @baz ); called_assign(@baz = @foo); @expect = qw( @quux @bar ); called_assign(@quux = @foo, @bar); @expect = qw( @flange ); called_assign(@flange = (@foo, @bar)); } { # and again for hashes my (%bar, %baz, %quux, %flange); @expect = qw( %bar ); called_assign(%bar = qw(some values)); @expect = qw( %baz ); called_assign(%baz = %foo); @expect = qw( %quux %bar ); called_assign(%quux = %foo, %bar); @expect = qw( %flange ); called_assign(%flange = (%foo, %bar)); } use vars qw( $quux @quux %quux ); sub called { my @called = caller_vars(0); is( scalar @called, 3, "right count"); is( $called[0], \$quux, "with \$quux" ); is( $called[1], \@quux, "with \@quux" ); is( $called[2], \%quux, "with \%quux" ); } called($quux, @quux, %quux); sub called_names { my @called = called_with(0, 1); is( scalar @called, 3, "right count"); is( $called[0], '$main::quux', "with name 0" ); is( $called[1], '@main::quux', "with name 1" ); is( $called[2], '%main::quux', "with name 2" ); } called_names($quux, @quux, %quux); sub called_globs { my @called = called_with(0, 1); is( scalar @called, 3, "right count"); is( $called[0], '*main::STDIN', "with name 0" ); is( $called[1], '*main::STDOUT', "with name 1" ); is( $called[2], '*main::STDERR', "with name 2" ); } called_globs(*STDIN, *STDOUT, *STDERR); package T; $what = 'package'; *called_assign = \&::called_assign; { # test scalars use vars qw( $bar $baz $quux ); @expect = qw( $T::bar ); called_assign($bar = q(a value)); @expect = qw( $T::baz ); called_assign($baz = $foo); @expect = qw( $T::quux $T::bar ); called_assign($quux = $foo, $bar); } { # same again for arrays use vars qw( @bar @baz @quux @flange ); { local $::TODO = "splitops under 5.00503" if $] < 5.006; @expect = qw( @T::bar ); called_assign(@bar = qw(some values)); } @expect = qw( @T::baz ); called_assign(@baz = @foo); @expect = qw( @T::quux @T::bar ); called_assign(@quux = @foo, @bar); @expect = qw( @T::flange ); called_assign(@flange = (@foo, @bar)); } { # and again for hashes use vars qw( %bar %baz %quux %flange ); @expect = qw( %T::bar ); called_assign(%bar = qw(1 2)); @expect = qw( %T::baz ); called_assign(%baz = %foo); @expect = qw( %T::quux %T::bar ); called_assign(%quux = %foo, %bar); @expect = qw( %T::flange ); called_assign(%flange = (%foo, %bar)); } package main; # were we called as a method or a sub my $called; sub maybe_method { is( called_as_method(), $called, "called_as_method" ); } maybe_method(); $called = 1; main->maybe_method(); my $name = 'maybe_method'; main->$name(); sub args { is_deeply( \@_, [ caller_args(0) ] ); } args('foo', 'bar'); # rt.cpan.org 2878 my $coy = rand 6; print "# cunning coy tests\n"; real( $coy, $coy ); print "# concat\n"; print "# print ", real( $coy, $coy ), "\n"; sub real { is_deeply( [ called_with(0,1) ], [qw( $coy $coy )], 'real( $coy, $coy )' ); } Devel-Caller-2.07/MANIFEST0000644000175000017500000000013714415226244015157 0ustar richardcrichardcMETA.yml META.json MANIFEST Changes Makefile.PL lib/Devel/Caller.pm Caller.xs t/Devel-Caller.t Devel-Caller-2.07/Caller.xs0000644000175000017500000000136514415226244015610 0ustar richardcrichardc/* -*- C -*- */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = Devel::Caller PACKAGE = Devel::Caller SV* _context_cv(context) SV* context; CODE: PERL_CONTEXT *cx = INT2PTR(PERL_CONTEXT *, SvIV(context)); CV *cur_cv; if (CxTYPE(cx) != CXt_SUB) croak("cx_type is %d not CXt_SUB\n", CxTYPE(cx)); cur_cv = cx->blk_sub.cv; if (!cur_cv) croak("Context has no CV!\n"); RETVAL = (SV*) newRV_inc( (SV*) cur_cv ); OUTPUT: RETVAL SV* _context_op(context) SV* context; CODE: PERL_CONTEXT *cx = INT2PTR(PERL_CONTEXT*, SvIV(context)); OP *op = cx->blk_oldcop->op_next; SV *rv = newSV(0); sv_setref_iv(rv, "B::OP", PTR2IV(op)); RETVAL = rv; OUTPUT: RETVAL Devel-Caller-2.07/lib/0000755000175000017500000000000014415234304014567 5ustar richardcrichardcDevel-Caller-2.07/lib/Devel/0000755000175000017500000000000014415234304015626 5ustar richardcrichardcDevel-Caller-2.07/lib/Devel/Caller.pm0000644000175000017500000002033414415234235017373 0ustar richardcrichardcuse 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 =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 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 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 in both cases =item called_as_method($level) C 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 as described in L 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, L, L =head1 AUTHOR Richard Clamp 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 Devel-Caller-2.07/META.yml0000644000175000017500000000127314415234304015275 0ustar richardcrichardc--- abstract: 'meatier versions of C' author: - 'Richard Clamp ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-Caller no_index: directory: - t - inc requires: PadWalker: '0.08' Test::More: '0' resources: license: http://dev.perl.org/licenses/ repository: https://github.com/richardc/perl-devel-caller.git version: '2.07' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-Caller-2.07/META.json0000644000175000017500000000235414415234305015447 0ustar richardcrichardc{ "abstract" : "meatier versions of C", "author" : [ "Richard Clamp " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Devel-Caller", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "PadWalker" : "0.08", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/richardc/perl-devel-caller.git", "web" : "https://github.com/richardc/perl-devel-caller" } }, "version" : "2.07", "x_serialization_backend" : "JSON::PP version 2.97001" }