APIfy block_start/block_end/intro_my blead
authorLukas Mai <l.mai@web.de>
Sat, 25 Oct 2014 10:25:14 +0000 (12:25 +0200)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 25 Oct 2014 18:56:32 +0000 (11:56 -0700)
MANIFEST
embed.fnc
embed.h
ext/XS-APItest/APItest.pm
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/synthetic_scope.t [new file with mode: 0644]
op.c
pad.c

index 0f12230..50c9460 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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}
index 6aa1ec3..bbec53a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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)
diff --git a/embed.h b/embed.h
index ebf519f..1dc949c 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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)
 #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
 #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)
 #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)
index a5953c6..9cca610 100644 (file)
@@ -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->{$_};
     }
index de0b2eb..ccdc8d5 100644 (file)
@@ -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 (file)
index 0000000..43a758f
--- /dev/null
@@ -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/;
diff --git a/op.c b/op.c
index bdaf324..329115c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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)
 {
diff --git a/pad.c b/pad.c
index 58b4d92..6cc5da7 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -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
 */