From: Vincent Pit Date: Fri, 14 Sep 2012 00:04:31 +0000 (+0200) Subject: Implement leave() X-Git-Tag: v0.20~6 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=be1d59463692da1b5ef787aeffd0aedbef65664e Implement leave() --- diff --git a/Upper.xs b/Upper.xs index 0d51f43..eef2503 100644 --- a/Upper.xs +++ b/Upper.xs @@ -1119,6 +1119,7 @@ STATIC void su_unwind(pTHX_ void *ud_) { STATIC void su_yield(pTHX_ void *ud_) { dMY_CXT; PERL_CONTEXT *cx; + const char *which = ud_; I32 cxix = MY_CXT.yield_storage.cxix; I32 items = MY_CXT.yield_storage.items; opcode type = OP_NULL; @@ -1243,10 +1244,11 @@ cxt_when: break; #endif case CXt_SUBST: - croak("yield() cannot target a substitution context"); + croak("%s() cannot target a substitution context", which); break; default: - croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix)); + croak("%s() don't know how to leave a %s context", + which, SU_CXNAME(cxstack + cxix)); break; } @@ -2210,6 +2212,8 @@ XS(XS_Scope__Upper_unwind) { croak("Can't return outside a subroutine"); } +STATIC const char su_yield_name[] = "yield"; + XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */ XS(XS_Scope__Upper_yield) { @@ -2235,7 +2239,33 @@ XS(XS_Scope__Upper_yield) { /* See XS_Scope__Upper_unwind */ if (GIMME_V == G_SCALAR) PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; - SAVEDESTRUCTOR_X(su_yield, NULL); + SAVEDESTRUCTOR_X(su_yield, su_yield_name); + return; +} + +STATIC const char su_leave_name[] = "leave"; + +XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */ + +XS(XS_Scope__Upper_leave) { +#ifdef dVAR + dVAR; dXSARGS; +#else + dXSARGS; +#endif + dMY_CXT; + I32 cxix; + + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + + MY_CXT.yield_storage.cxix = su_context_here(); + MY_CXT.yield_storage.items = items; + MY_CXT.yield_storage.savesp = PL_stack_sp; + /* See XS_Scope__Upper_unwind */ + if (GIMME_V == G_SCALAR) + PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; + SAVEDESTRUCTOR_X(su_yield, su_leave_name); return; } @@ -2258,6 +2288,7 @@ BOOT: newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); + newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); su_setup(); } diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 7ed86d8..4a90100 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -170,7 +170,7 @@ localize variables, array/hash values or deletions of elements in higher context =item * -return values immediately to an upper level with L and L, and know which context was in use then with L ; +return values immediately to an upper level with L, L and L, and know which context was in use then with L ; =item * @@ -340,6 +340,14 @@ Hence you can use it to return values from a C or a C block : Like for L, the upper context isn't coerced onto C<@values>. +=head2 C + + leave; + leave @values; + +Immediately returns C<@values> from the current block, whatever it may be (besides a C substitution context). +C is actually a synonym for C, while C is a synonym for C. + =head2 C my $want = want_at; @@ -638,7 +646,7 @@ Where L, L, L and L point to depending on t =head1 EXPORT -The functions L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. +The functions L, L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. The constant L is also only exported on request, individually or by the tags C<':consts'> and C<':all'>. @@ -653,7 +661,7 @@ our %EXPORT_TAGS = ( funcs => [ qw< reap localize localize_elem localize_delete - unwind yield + unwind yield leave want_at uplevel uid validate_uid diff --git a/t/01-import.t b/t/01-import.t index dcd2525..2474705 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2 * 18; +use Test::More tests => 2 * 19; require Scope::Upper; @@ -14,6 +14,7 @@ my %syms = ( localize_delete => '$$;$', unwind => undef, yield => undef, + leave => undef, want_at => ';$', uplevel => '&@', uid => ';$', diff --git a/t/55-yield-target.t b/t/55-yield-target.t index 594a04b..48b5036 100644 --- a/t/55-yield-target.t +++ b/t/55-yield-target.t @@ -5,7 +5,7 @@ use warnings; use Test::More tests => 18; -use Scope::Upper qw; +use Scope::Upper qw; my @res; diff --git a/t/58-yield-misc.t b/t/58-yield-misc.t index 23fc1d4..2eb222f 100644 --- a/t/58-yield-misc.t +++ b/t/58-yield-misc.t @@ -3,12 +3,12 @@ use strict; use warnings; -use Test::More tests => 4 * 3; +use Test::More tests => 4 * 3 + 3; use lib 't/lib'; use VPIT::TestHelpers; -use Scope::Upper qw; +use Scope::Upper qw; # Test timely destruction of values returned from yield() @@ -74,3 +74,34 @@ sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) } } is $destroyed, 1, "$desc: destroyed 2"; } + +# Test leave + +{ + my @res = (1, do { + leave; + 'XXX'; + }, 2); + is "@res", '1 2', 'leave without arguments'; +} + +{ + my @res = (1, do { + leave 2, 3; + 'XXX'; + }, 4); + is "@res", '1 2 3 4', 'leave with arguments'; +} + +{ + my $s = 'a'; + local $@; + eval { + $s =~ s/./leave; die 'not reached'/e; + }; + my $err = $@; + my $line = __LINE__-3; + like $err, + qr/^leave\(\) cannot target a substitution context at \Q$0\E line $line/, + 'leave() cannot exit subst'; +}