In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/494d0b3d4a7073965a8aacef74cfaa25322edce6?hp=ecafefb82337acf1046f535da14a6fc0293f70b5>
- Log ----------------------------------------------------------------- commit 494d0b3d4a7073965a8aacef74cfaa25322edce6 Author: Matthew Horsfall (alh) <[email protected]> Date: Tue Dec 2 08:18:32 2014 -0500 Upgrade Devel::PPPort from 3.24 to 3.25 ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 2 +- cpan/Devel-PPPort/PPPort_pm.PL | 2 +- cpan/Devel-PPPort/parts/inc/SvPV | 1 - cpan/Devel-PPPort/parts/inc/cop | 156 +++++++++++++++++++++++++++++++++- cpan/Devel-PPPort/parts/inc/magic | 15 +++- cpan/Devel-PPPort/parts/inc/variables | 2 +- cpan/Devel-PPPort/soak | 2 +- cpan/Devel-PPPort/t/cop.t | 52 +++++++++++- 8 files changed, 220 insertions(+), 12 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 75cb6c1..65c7f890 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -342,7 +342,7 @@ use File::Glob qw(:case); }, 'Devel::PPPort' => { - 'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.24.tar.gz', + 'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.25.tar.gz', # RJBS has asked MHX to have UPSTREAM be 'blead' # (i.e. move this from cpan/ to dist/) 'FILES' => q[cpan/Devel-PPPort], diff --git a/cpan/Devel-PPPort/PPPort_pm.PL b/cpan/Devel-PPPort/PPPort_pm.PL index a73336c..d96593b 100644 --- a/cpan/Devel-PPPort/PPPort_pm.PL +++ b/cpan/Devel-PPPort/PPPort_pm.PL @@ -539,7 +539,7 @@ package Devel::PPPort; use strict; use vars qw($VERSION $data); -$VERSION = '3.24'; +$VERSION = '3.25'; sub _init_data { diff --git a/cpan/Devel-PPPort/parts/inc/SvPV b/cpan/Devel-PPPort/parts/inc/SvPV index 1034072..387b0d8 100644 --- a/cpan/Devel-PPPort/parts/inc/SvPV +++ b/cpan/Devel-PPPort/parts/inc/SvPV @@ -438,7 +438,6 @@ SvPV_nomg_nolen(sv) SV *sv PREINIT: char *str; - STRLEN len; CODE: str = SvPV_nomg_nolen(sv); RETVAL = strEQ(str, "mhx") ? 61 : 0; diff --git a/cpan/Devel-PPPort/parts/inc/cop b/cpan/Devel-PPPort/parts/inc/cop index 72d8087..355a2e1 100644 --- a/cpan/Devel-PPPort/parts/inc/cop +++ b/cpan/Devel-PPPort/parts/inc/cop @@ -11,6 +11,7 @@ =provides +caller_cx __UNDEFINED__ =implementation @@ -46,6 +47,81 @@ __UNDEFINED__ CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif /* USE_ITHREADS */ +#if { VERSION >= 5.6.0 } +#ifndef caller_cx + +# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) +static I32 +DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) +{ + I32 i; + + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + case CXt_FORMAT: + return i; + } + } + return i; +} +# endif + +# if { NEED caller_cx } + +const PERL_CONTEXT * +caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +{ + register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); + register const PERL_CONTEXT *cx; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + } + + cx = &ccstack[cxix]; + if (dbcxp) *dbcxp = cx; + + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; + } + + return cx; +} + +# endif +#endif /* caller_cx */ +#endif /* 5.6.0 */ + +=xsinit + +#define NEED_caller_cx + =xsubs char * @@ -62,7 +138,36 @@ CopFILE() OUTPUT: RETVAL -=tests plan => 2 +#if { VERSION >= 5.6.0 } + +void +caller_cx(level) + I32 level + PREINIT: + const PERL_CONTEXT *cx, *dbcx; + const char *pv; + const GV *gv; + PPCODE: + cx = caller_cx(level, &dbcx); + if (!cx) XSRETURN_EMPTY; + + EXTEND(SP, 4); + + pv = CopSTASHPV(cx->blk_oldcop); + ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef; + gv = CvGV(cx->blk_sub.cv); + ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef; + + pv = CopSTASHPV(dbcx->blk_oldcop); + ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef; + gv = CvGV(dbcx->blk_sub.cv); + ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef; + + XSRETURN(4); + +#endif /* 5.6.0 */ + +=tests plan => 28 my $package; { @@ -75,3 +180,52 @@ ok($package, "MyPackage"); my $file = &Devel::PPPort::CopFILE(); print "# $file\n"; ok($file =~ /cop/i); + +BEGIN { + if ($] < 5.006000) { + # Skip + for (1..28) { + ok(1, 1); + } + exit; + } +} + +BEGIN { + package DB; + no strict "refs"; + local $^P = 1; + sub sub { &$DB::sub } +} + +{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } } +{ + package Two; + sub two { One::one(@_) } + sub dbtwo { + BEGIN { $^P = 1 } + One::one(@_); + BEGIN { $^P = 0 } + } +} + +for ( + # This is rather confusing. The package is the package the call is + # made *from*, the sub name is the sub the call is made *to*. When + # DB::sub is involved the first call is to DB::sub from the calling + # package, the second is to the real sub from package DB. + [\&One::one, 0, qw/main one main one/], + [\&One::one, 2, ], + [\&Two::two, 0, qw/Two one Two one/], + [\&Two::two, 1, qw/main two main two/], + [\&Two::dbtwo, 0, qw/Two sub DB one/], + [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/], +) { + my ($sub, $arg, @want) = @$_; + my @got = $sub->($arg); + ok(@got, @want); + for (0..$#want) { + ok($got[$_], $want[$_]); + } +} + diff --git a/cpan/Devel-PPPort/parts/inc/magic b/cpan/Devel-PPPort/parts/inc/magic index 136758d..de6f438 100644 --- a/cpan/Devel-PPPort/parts/inc/magic +++ b/cpan/Devel-PPPort/parts/inc/magic @@ -343,7 +343,6 @@ new_with_other_mg(package, ...) HV *self; HV *stash; SV *self_ref; - int i = 0; const char *data = "hello\0"; MAGIC *mg; CODE: @@ -354,7 +353,10 @@ new_with_other_mg(package, ...) sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data)); mg = mg_find((SV*)self, PERL_MAGIC_ext); - mg->mg_virtual = &other_mg_vtbl; + if (mg) + mg->mg_virtual = &other_mg_vtbl; + else + croak("No mg!"); RETVAL = sv_bless(self_ref, stash); OUTPUT: @@ -367,7 +369,6 @@ new_with_mg(package, ...) HV *self; HV *stash; SV *self_ref; - int i = 0; const char *data = "hello\0"; MAGIC *mg; CODE: @@ -378,7 +379,10 @@ new_with_mg(package, ...) sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data)); mg = mg_find((SV*)self, PERL_MAGIC_ext); - mg->mg_virtual = &null_mg_vtbl; + if (mg) + mg->mg_virtual = &null_mg_vtbl; + else + croak("No mg!"); RETVAL = sv_bless(self_ref, stash); OUTPUT: @@ -521,6 +525,9 @@ sv_magic_portable(sv) #if { VERSION >= 5.004 } sv_magic_portable(sv, 0, '~', foo, 0); mg = mg_find(sv, '~'); + if (!mg) + croak("No mg!"); + RETVAL = mg->mg_ptr == foo; #else sv_magic(sv, 0, '~', (char *) foo, strlen(foo)); diff --git a/cpan/Devel-PPPort/parts/inc/variables b/cpan/Devel-PPPort/parts/inc/variables index 0898ab5..7ae6fab 100644 --- a/cpan/Devel-PPPort/parts/inc/variables +++ b/cpan/Devel-PPPort/parts/inc/variables @@ -222,7 +222,7 @@ extern U32 get_PL_signals_3(void); int no_dummy_parser_vars(int); int dummy_parser_warning(void); -#define ppp_TESTVAR(var) STMT_START { mXPUSHi(&var != NULL); count++; } STMT_END +#define ppp_TESTVAR(var) STMT_START { mXPUSHi(&var); count++; } STMT_END #define ppp_PARSERVAR(type, var) STMT_START { \ type volatile my_ ## var; \ diff --git a/cpan/Devel-PPPort/soak b/cpan/Devel-PPPort/soak index 893212b..2f13412 100644 --- a/cpan/Devel-PPPort/soak +++ b/cpan/Devel-PPPort/soak @@ -27,7 +27,7 @@ use File::Find; use List::Util qw(max); use Config; -my $VERSION = '3.24'; +my $VERSION = '3.25'; $| = 1; my %OPT = ( diff --git a/cpan/Devel-PPPort/t/cop.t b/cpan/Devel-PPPort/t/cop.t index 1162a5e..1677dee 100644 --- a/cpan/Devel-PPPort/t/cop.t +++ b/cpan/Devel-PPPort/t/cop.t @@ -30,9 +30,9 @@ BEGIN { require 'testutil.pl' if $@; } - if (2) { + if (28) { load(); - plan(tests => 2); + plan(tests => 28); } } @@ -60,3 +60,51 @@ my $file = &Devel::PPPort::CopFILE(); print "# $file\n"; ok($file =~ /cop/i); +BEGIN { + if ($] < 5.006000) { + # Skip + for (1..28) { + ok(1, 1); + } + exit; + } +} + +BEGIN { + package DB; + no strict "refs"; + local $^P = 1; + sub sub { &$DB::sub } +} + +{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } } +{ + package Two; + sub two { One::one(@_) } + sub dbtwo { + BEGIN { $^P = 1 } + One::one(@_); + BEGIN { $^P = 0 } + } +} + +for ( + # This is rather confusing. The package is the package the call is + # made *from*, the sub name is the sub the call is made *to*. When + # DB::sub is involved the first call is to DB::sub from the calling + # package, the second is to the real sub from package DB. + [\&One::one, 0, qw/main one main one/], + [\&One::one, 2, ], + [\&Two::two, 0, qw/Two one Two one/], + [\&Two::two, 1, qw/main two main two/], + [\&Two::dbtwo, 0, qw/Two sub DB one/], + [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/], +) { + my ($sub, $arg, @want) = @$_; + my @got = $sub->($arg); + ok(@got, @want); + for (0..$#want) { + ok($got[$_], $want[$_]); + } +} + -- Perl5 Master Repository
