From: Vincent Pit Date: Mon, 10 Sep 2012 11:03:20 +0000 (+0200) Subject: Fix and test UP and SCOPE crossing loop/subst/given/when/default blocks X-Git-Tag: v0.20~15 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=3a43f1ed62c266c8108a25266b461393336016b5 Fix and test UP and SCOPE crossing loop/subst/given/when/default blocks --- diff --git a/Upper.xs b/Upper.xs index aea8e10..c5da0e1 100644 --- a/Upper.xs +++ b/Upper.xs @@ -995,19 +995,6 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { for (i = cxstack_ix; i > cxix; --i) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { -#if SU_HAS_PERL(5, 10, 0) - case CXt_BLOCK: - SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i)); - /* Given and when blocks are actually followed by a simple block, so skip - * it if needed. */ - if (cxix > 0) { /* Implies i > 0 */ - PERL_CONTEXT *next = cx - 1; - if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN) - --cxix; - } - depth++; - break; -#endif #if SU_HAS_PERL(5, 11, 0) case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: @@ -1798,6 +1785,84 @@ STATIC int su_uid_validate(pTHX_ SV *uid) { return su_uid_storage_check(depth, seq); } +/* --- Context operations -------------------------------------------------- */ + +#if SU_HAS_PERL(5, 8, 9) +# define SU_SKIP_DB_MAX 2 +#else +# define SU_SKIP_DB_MAX 3 +#endif + +/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts + * followed by a DB sub */ + +#define SU_SKIP_DB(C) \ + STMT_START { \ + I32 skipped = 0; \ + PERL_CONTEXT *base = cxstack; \ + PERL_CONTEXT *cx = base + (C); \ + while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \ + --cx, ++skipped; \ + if (cx >= base && (C) > skipped) { \ + switch (CxTYPE(cx)) { \ + case CXt_SUB: \ + if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \ + (C) -= skipped + 1; \ + break; \ + default: \ + break; \ + } \ + } \ + } STMT_END + +STATIC I32 su_context_up(pTHX_ I32 cxix) { +#define su_context_up(C) su_context_up(aTHX_ (C)) + PERL_CONTEXT *cx; + + if (cxix <= 0) + return 0; + + cx = cxstack + cxix; + if (CxTYPE(cx) == CXt_BLOCK) { + PERL_CONTEXT *prev = cx - 1; + + switch (CxTYPE(prev)) { +#if SU_HAS_PERL(5, 10, 0) + case CXt_GIVEN: + case CXt_WHEN: +#endif +#if SU_HAS_PERL(5, 11, 0) + /* That's the only subcategory that can cause an extra BLOCK context */ + case CXt_LOOP_PLAIN: +#else + case CXt_LOOP: +#endif + if (cx->blk_oldcop == prev->blk_oldcop) + cxix -= 2; + else + --cxix; + break; + case CXt_SUBST: + if (cx->blk_oldcop && cx->blk_oldcop->op_sibling + && cx->blk_oldcop->op_sibling->op_type == OP_SUBST) + cxix -= 2; + else + --cxix; + break; + default: + --cxix; + break; + } + } else { + --cxix; + } + + if (PL_DBsub) + SU_SKIP_DB(cxix); + + return cxix; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { @@ -1856,34 +1921,6 @@ STATIC void su_setup(pTHX) { /* --- XS ------------------------------------------------------------------ */ -#if SU_HAS_PERL(5, 8, 9) -# define SU_SKIP_DB_MAX 2 -#else -# define SU_SKIP_DB_MAX 3 -#endif - -/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts - * followed by a DB sub */ - -#define SU_SKIP_DB(C) \ - STMT_START { \ - I32 skipped = 0; \ - PERL_CONTEXT *base = cxstack; \ - PERL_CONTEXT *cx = base + (C); \ - while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \ - --cx, ++skipped; \ - if (cx >= base && (C) > skipped) { \ - switch (CxTYPE(cx)) { \ - case CXt_SUB: \ - if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \ - (C) -= skipped + 1; \ - break; \ - default: \ - break; \ - } \ - } \ - } STMT_END - #define SU_GET_CONTEXT(A, B) \ STMT_START { \ if (items > A) { \ @@ -2026,10 +2063,7 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); - if (--cxix < 0) - cxix = 0; - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_up(cxix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2084,19 +2118,10 @@ PREINIT: PPCODE: SU_GET_LEVEL(0, 0); cxix = cxstack_ix; - if (PL_DBsub) { + if (PL_DBsub) SU_SKIP_DB(cxix); - while (cxix > 0) { - if (--level < 0) - break; - --cxix; - SU_SKIP_DB(cxix); - } - } else { - cxix -= level; - if (cxix < 0) - cxix = 0; - } + while (--level >= 0) + cxix = su_context_up(cxix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); diff --git a/t/05-words.t b/t/05-words.t index bcb3ac9..2496460 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -5,113 +5,336 @@ use warnings; use Test::More; -BEGIN { - if ($^P) { - plan skip_all => 'hardcoded values are wrong under the debugger'; - } else { - plan tests => 29 + 13 * 2; - } -} +plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 2) + 7 + 15 * 2; use Scope::Upper qw<:words>; -# This test is for internal use only and doesn't imply any kind of future -# compatibility on what the words should actually return. +# Tests with hardcoded values are for internal use only and doesn't imply any +# kind of future compatibility on what the words should actually return. + +my $top = HERE; -is HERE, 0, 'main : here'; -is TOP, 0, 'main : top'; -is UP, 0, 'main : up'; +is $top, 0, 'main : here' unless $^P; +is TOP, $top, 'main : top'; +is UP, $top, 'main : up'; is SUB, undef, 'main : sub'; is EVAL, undef, 'main : eval'; { - is HERE, 1, '{ 1 } : here'; - is TOP, 0, '{ 1 } : top'; - is UP, 0, '{ 1 } : up'; + my $desc = '{ 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; } do { - is HERE, 1, 'do { 1 } : here'; - is SUB, undef, 'do { 1 } : sub'; - is EVAL, undef, 'do { 1 } : eval'; + my $desc = 'do { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; }; eval { - is HERE, 1, 'eval { 1 } : here'; - is SUB, undef, 'eval { 1 } : sub'; - is EVAL, 1, 'eval { 1 } : eval'; + my $desc = 'eval { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, HERE, "$desc : eval"; }; +diag $@ if $@; eval q[ - is HERE, 1, 'eval "1" : here'; - is SUB, undef, 'eval "1" : sub'; - is EVAL, 1, 'eval "1" : eval'; + my $desc = 'eval "1"'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, HERE, "$desc : eval"; ]; - -do { - is HERE, 1, 'do { 1 } while (0) : here'; -} while (0); +diag $@ if $@; sub { - is HERE, 1, 'sub { 1 } : here'; - is SUB, 1, 'sub { 1 } : sub'; - is EVAL, undef, 'sub { 1 } : eval'; + my $desc = 'sub { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, HERE, "$desc : sub"; + is EVAL, undef, "$desc : eval"; }->(); +my $true = 1; +my $false = !$true; + +if ($true) { + my $desc = 'if () { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +unless ($false) { + my $desc = 'unless () { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +if ($false) { + fail "false was true : $_" for 1 .. 5; +} else { + my $desc = 'if () { } else { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + for (1) { - is HERE, 1, 'for () { 1 } : here'; + my $desc = 'for (list) { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +for (1 .. 1) { + my $desc = 'for (num range) { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +for (1 .. 1) { + my $desc = 'for (pv range) { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +for (my $i = 0; $i < 1; ++$i) { + my $desc = 'for (;;) { 1 }'; + is HERE, 2, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +my $flag = 1; +while ($flag) { + $flag = 0; + my $desc = 'while () { 1 }'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} + +my @list = (1); +while (my $thing = shift @list) { + my $desc = 'while (my $thing = ...) { 2 }'; + is HERE, "$]" <= 5.008_008 ? 1 : 2, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; } do { - eval { - do { - sub { - eval q[ - { - is HERE, 6, 'mixed : here'; - is TOP, 0, 'mixed : top'; - is SUB, 4, 'mixed : first sub'; - is SUB(SUB), 4, 'mixed : still first sub'; - is EVAL, 5, 'mixed : first eval'; - is EVAL(EVAL), 5, 'mixed : still first eval'; - is EVAL(UP(EVAL)), 2, 'mixed : second eval'; - } - ]; - }->(); - } - }; + my $desc = 'do { 1 } while (0)'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; } while (0); +map { + my $desc = 'map { 1 } 1'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} 1; + +grep { + my $desc = 'grep { 1 } 1'; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +} 1; + +my $var = 'a'; +$var =~ s{.}{ + my $desc = 'subst'; + is HERE, 2, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; +}e; + +$var = 'a'; +$var =~ s{.}{UP}e; +is $var, $top, 'subst : fake block'; + +$var = 'a'; +$var =~ s{.}{do { UP }}e; +is $var, 2, 'subst : real block' unless $^P; + +SKIP: { + skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + if "$]" < 5.010; + + eval <<'TEST_GIVEN'; + use feature 'switch'; + my $desc = 'given'; + my $base = HERE; + given (1) { + is HERE, $base + 2, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $base, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, $base, "$desc : eval"; + } +TEST_GIVEN + diag $@ if $@; + + eval <<'TEST_GIVEN_WHEN'; + use feature 'switch'; + my $desc = 'when in given'; + my $base = HERE; + given (1) { + my $given = HERE; + when (1) { + is HERE, $base + 4, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $given, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, $base, "$desc : eval"; + } + } +TEST_GIVEN_WHEN + diag $@ if $@; + + eval <<'TEST_GIVEN_DEFAULT'; + use feature 'switch'; + my $desc = 'default in given'; + my $base = HERE; + given (1) { + my $given = HERE; + default { + is HERE, $base + 4, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $given, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, $base, "$desc : eval"; + } + } +TEST_GIVEN_DEFAULT + diag $@ if $@; + + eval <<'TEST_FOR_WHEN'; + use feature 'switch'; + my $desc = 'when in for'; + my $base = HERE; + for (1) { + my $loop = HERE; + when (1) { + is HERE, $base + 3, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $loop, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, $base, "$desc : eval"; + } + } +TEST_FOR_WHEN + diag $@ if $@; +} + +SKIP: { + skip 'Hardcoded values are wrong under the debugger' => 7 if $^P; + + my $base = HERE; + + do { + eval { + do { + sub { + eval q[ + { + is HERE, $base + 6, 'mixed : here'; + is TOP, $top, 'mixed : top'; + is SUB, $base + 4, 'mixed : first sub'; + is SUB(SUB), $base + 4, 'mixed : still first sub'; + is EVAL, $base + 5, 'mixed : first eval'; + is EVAL(EVAL), $base + 5, 'mixed : still first eval'; + is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval'; + } + ]; + }->(); + } + }; + } while (0); +} + { - is SCOPE, 1, 'block : scope'; - is SCOPE(0), 1, 'block : scope 0'; - is SCOPE(1), 0, 'block : scope 1'; - is CALLER, 0, 'block: caller'; - is CALLER(0), 0, 'block : caller 0'; - is CALLER(1), 0, 'block : caller 1'; + my $block = HERE; + is SCOPE, $block, 'block : scope'; + is SCOPE(0), $block, 'block : scope 0'; + is SCOPE(1), $top, 'block : scope 1'; + is CALLER, $top, 'block : caller'; + is CALLER(0), $top, 'block : caller 0'; + is CALLER(1), $top, 'block : caller 1'; sub { - is SCOPE, 2, 'block sub : scope'; - is SCOPE(0), 2, 'block sub : scope 0'; - is SCOPE(1), 1, 'block sub : scope 1'; - is CALLER, 2, 'block sub : caller'; - is CALLER(0), 2, 'block sub : caller 0'; - is CALLER(1), 0, 'block sub : caller 1'; + my $sub = HERE; + is SCOPE, $sub, 'block sub : scope'; + is SCOPE(0), $sub, 'block sub : scope 0'; + is SCOPE(1), $block, 'block sub : scope 1'; + is CALLER, $sub, 'block sub : caller'; + is CALLER(0), $sub, 'block sub : caller 0'; + is CALLER(1), $top, 'block sub : caller 1'; for (1) { - is SCOPE, 3, 'block sub for : scope'; - is SCOPE(0), 3, 'block sub for : scope 0'; - is SCOPE(1), 2, 'block sub for : scope 1'; - is CALLER, 2, 'block sub for : caller'; - is CALLER(0), 2, 'block sub for : caller 0'; - is CALLER(1), 0, 'block sub for : caller 1'; + my $loop = HERE; + is SCOPE, $loop, 'block sub for : scope'; + is SCOPE(0), $loop, 'block sub for : scope 0'; + is SCOPE(1), $sub, 'block sub for : scope 1'; + is SCOPE(2), $block, 'block sub for : scope 2'; + is CALLER, $sub, 'block sub for : caller'; + is CALLER(0), $sub, 'block sub for : caller 0'; + is CALLER(1), $top, 'block sub for : caller 1'; + is CALLER(2), $top, 'block sub for : caller 2'; eval { - is SCOPE, 4, 'block sub for eval : scope'; - is SCOPE(0), 4, 'block sub for eval : scope 0'; - is SCOPE(1), 3, 'block sub for eval : scope 1'; - is SCOPE(2), 2, 'block sub for eval : scope 2'; - is CALLER, 4, 'block sub for eval : caller'; - is CALLER(0), 4, 'block sub for eval : caller 0'; - is CALLER(1), 2, 'block sub for eval : caller 1'; - is CALLER(2), 0, 'block sub for eval : caller 2'; + my $eval = HERE; + is SCOPE, $eval, 'block sub for eval : scope'; + is SCOPE(0), $eval, 'block sub for eval : scope 0'; + is SCOPE(1), $loop, 'block sub for eval : scope 1'; + is SCOPE(2), $sub, 'block sub for eval : scope 2'; + is SCOPE(3), $block, 'block sub for eval : scope 3'; + is CALLER, $eval, 'block sub for eval : caller'; + is CALLER(0), $eval, 'block sub for eval : caller 0'; + is CALLER(1), $sub, 'block sub for eval : caller 1'; + is CALLER(2), $top, 'block sub for eval : caller 2'; + is CALLER(3), $top, 'block sub for eval : caller 3'; } } }->();