diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 6 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.pm | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 89 | ||||
| -rw-r--r-- | ext/XS-APItest/t/synthetic_scope.t | 42 | ||||
| -rw-r--r-- | op.c | 20 | ||||
| -rw-r--r-- | pad.c | 8 |
8 files changed, 164 insertions, 12 deletions
@@ -3868,6 +3868,7 @@ ext/XS-APItest/t/svsetsv.t Test behaviour of sv_setsv with/without PERL_CORE ext/XS-APItest/t/swaplabel.t test recursive descent label parsing ext/XS-APItest/t/swaptwostmts.t test recursive descent statement parsing ext/XS-APItest/t/sym-hook.t Test rv2cv hooks for bareword lookup +ext/XS-APItest/t/synthetic_scope.t Test block_start/block_end/intro_my ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps ext/XS-APItest/t/underscore_length.t Test find_rundefsv() ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed} @@ -239,10 +239,10 @@ s |MAGIC* |get_aux_mg |NN AV *av : Used in perly.y pR |OP* |bind_match |I32 type|NN OP *left|NN OP *right : Used in perly.y -pR |OP* |block_end |I32 floor|NULLOK OP* seq +ApdR |OP* |block_end |I32 floor|NULLOK OP* seq ApR |I32 |block_gimme : Used in perly.y -pR |int |block_start |int full +ApdR |int |block_start |int full Aodp |void |blockhook_register |NN BHK *hk : Used in perl.c p |void |boot_core_UNIVERSAL @@ -2570,7 +2570,7 @@ Apd |SV* |pad_sv |PADOFFSET po Apd |void |pad_setsv |PADOFFSET po|NN SV* sv #endif pd |void |pad_block_start|int full -pd |U32 |intro_my +Apd |U32 |intro_my pd |OP * |pad_leavemy pd |void |pad_swipe |PADOFFSET po|bool refadjust #if defined(PERL_IN_PAD_C) @@ -66,7 +66,9 @@ #define av_top_index(a) S_av_top_index(aTHX_ a) #define av_undef(a) Perl_av_undef(aTHX_ a) #define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b) +#define block_end(a,b) Perl_block_end(aTHX_ a,b) #define block_gimme() Perl_block_gimme(aTHX) +#define block_start(a) Perl_block_start(aTHX_ a) #define bytes_cmp_utf8(a,b,c,d) Perl_bytes_cmp_utf8(aTHX_ a,b,c,d) #define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c) #define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) @@ -236,6 +238,7 @@ #define init_stacks() Perl_init_stacks(aTHX) #define init_tm(a) Perl_init_tm(aTHX_ a) #define instr Perl_instr +#define intro_my() Perl_intro_my(aTHX) #define isALNUM_lazy(a) Perl_isALNUM_lazy(aTHX_ a) #define isIDFIRST_lazy(a) Perl_isIDFIRST_lazy(aTHX_ a) #define is_ascii_string Perl_is_ascii_string @@ -1076,8 +1079,6 @@ #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) #define av_extend_guts(a,b,c,d,e) Perl_av_extend_guts(aTHX_ a,b,c,d,e) #define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c) -#define block_end(a,b) Perl_block_end(aTHX_ a,b) -#define block_start(a) Perl_block_start(aTHX_ a) #define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX) #define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX) #define boot_core_mro() Perl_boot_core_mro(aTHX) @@ -1183,7 +1184,6 @@ #define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b) #define init_constants() Perl_init_constants(aTHX) #define init_debugger() Perl_init_debugger(aTHX) -#define intro_my() Perl_intro_my(aTHX) #define invert(a) Perl_invert(aTHX_ a) #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define isinfnansv(a) Perl_isinfnansv(aTHX_ a) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index a5953c62aa..9cca610b1c 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.66'; +our $VERSION = '0.67'; require XSLoader; @@ -40,7 +40,7 @@ sub import { } } foreach (keys %{$exports||{}}) { - next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags|DEFSV)\z/; + next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags|DEFSV|with_vars)\z/; $^H{"XS::APItest/$_"} = 1; delete $exports->{$_}; } diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index de0b2eb045..ccdc8d5def 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -663,6 +663,7 @@ static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv; static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv; static SV *hintkey_arrayexprflags_sv; static SV *hintkey_DEFSV_sv; +static SV *hintkey_with_vars_sv; static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); /* low-level parser helpers */ @@ -958,6 +959,89 @@ static OP *THX_parse_keyword_DEFSV(pTHX) return newDEFSVOP(); } +static void sv_cat_c(pTHX_ SV *sv, U32 c) { + char ds[UTF8_MAXBYTES + 1], *d; + d = (char *)uvchr_to_utf8((U8 *)ds, c); + if (d - ds > 1) { + sv_utf8_upgrade(sv); + } + sv_catpvn(sv, ds, d - ds); +} + +#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX) +static OP *THX_parse_keyword_with_vars(pTHX) +{ + I32 c; + IV count; + int save_ix; + OP *vardeclseq, *body; + + save_ix = block_start(TRUE); + vardeclseq = NULL; + + count = 0; + + lex_read_space(0); + c = lex_peek_unichar(0); + while (c != '{') { + SV *varname; + PADOFFSET padoff; + + if (c == -1) { + croak("unexpected EOF; expecting '{'"); + } + + if (!isIDFIRST_uni(c)) { + croak("unexpected '%c'; expecting an identifier", (int)c); + } + + varname = newSVpvs("$"); + if (lex_bufutf8()) { + SvUTF8_on(varname); + } + + sv_cat_c(varname, c); + lex_read_unichar(0); + + while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) { + sv_cat_c(varname, c); + lex_read_unichar(0); + } + + padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL); + + { + OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); + my_var->op_targ = padoff; + + vardeclseq = op_append_list( + OP_LINESEQ, + vardeclseq, + newSTATEOP( + 0, NULL, + newASSIGNOP( + OPf_STACKED, + my_var, 0, + newSVOP( + OP_CONST, 0, + newSViv(++count) + ) + ) + ) + ); + } + + lex_read_space(0); + c = lex_peek_unichar(0); + } + + intro_my(); + + body = parse_block(0); + + return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body)); +} + /* plugin glue */ #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv) @@ -1046,6 +1130,10 @@ static int my_keyword_plugin(pTHX_ keyword_active(hintkey_DEFSV_sv)) { *op_ptr = parse_keyword_DEFSV(); return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) && + keyword_active(hintkey_with_vars_sv)) { + *op_ptr = parse_keyword_with_vars(); + return KEYWORD_PLUGIN_STMT; } else { return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } @@ -3333,6 +3421,7 @@ BOOT: hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr"); hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags"); hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV"); + hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars"); next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; } diff --git a/ext/XS-APItest/t/synthetic_scope.t b/ext/XS-APItest/t/synthetic_scope.t new file mode 100644 index 0000000000..43a758f077 --- /dev/null +++ b/ext/XS-APItest/t/synthetic_scope.t @@ -0,0 +1,42 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 18; + +use XS::APItest qw(with_vars); + +my $foo = "A"; my $rfoo = \$foo; +my $bar = "B"; my $rbar = \$bar; +my $baz = "C"; my $rbaz = \$baz; + +with_vars foo bar baz { + is $foo, 1; + is $$rfoo, "A"; + isnt \$foo, $rfoo; + + is $bar, 2; + is $$rbar, "B"; + isnt \$bar, $rbar; + + is $baz, 3; + is $$rbaz, "C"; + isnt \$baz, $rbaz; +} + +is $foo, "A"; +is \$foo, $rfoo; + +is $bar, "B"; +is \$bar, $rbar; + +is $baz, "C"; +is \$baz, $rbaz; + +with_vars x { + is $x, 1; +} + +is eval('$x++'), undef; +like $@, qr/explicit package name/; @@ -3558,6 +3558,16 @@ Perl_op_unscope(pTHX_ OP *o) return o; } +/* +=for apidoc Am|int|block_start|int full + +Handles compile-time scope entry. Arranges for hints to be restored on block +exit and also handles pad sequence numbers to make lexical variables scope +right. Returns a savestack index for use with C<block_end>. + +=cut +*/ + int Perl_block_start(pTHX_ int full) { @@ -3574,6 +3584,16 @@ Perl_block_start(pTHX_ int full) return retval; } +/* +=for apidoc Am|OP *|block_end|I32 floor|OP *seq + +Handles compile-time scope exit. I<floor> is the savestack index returned by +C<block_start>, and I<seq> is the body of the block. Returns the block, +possibly modified. + +=cut +*/ + OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { @@ -1509,11 +1509,11 @@ Perl_pad_block_start(pTHX_ int full) } /* -=for apidoc m|U32|intro_my +=for apidoc Am|U32|intro_my -"Introduce" my variables to visible status. This is called during parsing -at the end of each statement to make lexical variables visible to -subsequent statements. +"Introduce" C<my> variables to visible status. This is called during parsing +at the end of each statement to make lexical variables visible to subsequent +statements. =cut */ |