In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/25f5d540536c9ee920ad9bdc29e43e3284465acb?hp=96801525df66a32483d0872bdbfffea111d7add5>
- Log -----------------------------------------------------------------
commit 25f5d540536c9ee920ad9bdc29e43e3284465acb
Author: Lukas Mai <l....@web.de>
Date: Sat Oct 25 12:25:14 2014 +0200
APIfy block_start/block_end/intro_my
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
embed.fnc | 6 +--
embed.h | 6 +--
ext/XS-APItest/APItest.pm | 4 +-
ext/XS-APItest/APItest.xs | 89 ++++++++++++++++++++++++++++++++++++++
ext/XS-APItest/t/synthetic_scope.t | 42 ++++++++++++++++++
op.c | 20 +++++++++
pad.c | 8 ++--
8 files changed, 164 insertions(+), 12 deletions(-)
create mode 100644 ext/XS-APItest/t/synthetic_scope.t
diff --git a/MANIFEST b/MANIFEST
index 0f12230..50c9460 100644
--- 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}
diff --git a/embed.fnc b/embed.fnc
index 6aa1ec3..bbec53a 100644
--- 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
--- 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)
@@ -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 a5953c6..9cca610 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|arrayarithexp
... [27 chars truncated]
+ next unless
/\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexp
... [37 chars truncated]
$^H{"XS::APItest/$_"} = 1;
delete $exports->{$_};
}
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index de0b2eb..ccdc8d5 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 0000000..43a758f
--- /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/;
diff --git a/op.c b/op.c
index bdaf324..329115c 100644
--- 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
--- 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
*/
--
Perl5 Master Repository
