In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/b9a58d500dd75ba783abac92a56e57d41227f62b?hp=132771f7006e25b81986880bb09296b68d3e29f4>
- Log -----------------------------------------------------------------
commit b9a58d500dd75ba783abac92a56e57d41227f62b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jul 2 11:35:20 2017 -0700
[perl #131679] Fix âour sub foo::barâ message
It should say subroutine, not variable.
M t/lib/croak/toke
M toke.c
commit cc1385000d16c5233a15d62adab1df3cc1a2d2ad
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jul 2 11:27:32 2017 -0700
op.c: Remove unused THX param
M op.c
commit e26c6904d9f9f5ea818e590331b14038279332d1
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jun 25 06:37:19 2017 -0700
[perl #131645] Fix assert fail in pp_sselect
pp_sselect (4-arg select) process its first three bitfield arguments
first, making sure each one has a valid PV, and then it moves on to
the final, timeout argument.
SvGETMAGIC() on the timeout argument will wipe out any values the SV
holds, so if the same scalar is used as a bitfield argument *and* as
the timeout, it will no longer hold a valid PV.
Assertions later in pp_sselect make sure there is a valid PV.
This commit solves the assertion failure by making a temporary copy of
any gmagical or overloaded argument. When the temporary copy is made,
the values written to the temporary copies of the bitfield arguments
are then copied back to the original magical arguments.
M pp_sys.c
M t/op/sselect.t
commit 7600a9e5585cdade08986d507c3de5ea3b678bc3
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jun 25 17:26:33 2017 -0700
pad.c: comment typo
M pad.c
commit 1cdc5f0b922411a4ba6ac3cfc0450abb16db3f22
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jun 25 17:21:29 2017 -0700
pad.c: POD typo
M pad.c
commit 926b8942cc68fcd98a48c776f19e7348d819a396
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jun 25 06:12:21 2017 -0700
Couple of test file comments
M t/op/select.t
M t/op/sselect.t
-----------------------------------------------------------------------
Summary of changes:
op.c | 6 +++---
pad.c | 4 ++--
pp_sys.c | 21 +++++++++++++++------
t/lib/croak/toke | 6 ++++++
t/op/select.t | 3 +++
t/op/sselect.t | 13 ++++++++++++-
toke.c | 3 ++-
7 files changed, 43 insertions(+), 13 deletions(-)
diff --git a/op.c b/op.c
index 6ff74a1d88..1a2101c628 100644
--- a/op.c
+++ b/op.c
@@ -13495,7 +13495,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV
orig_action, U8 hints)
*/
static void
-S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag)
+S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag)
{
OP *lop;
@@ -14292,7 +14292,7 @@ Perl_rpeep(pTHX_ OP *o)
case OP_PADHV:
/* see if %h is used in boolean context */
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
- S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
if (o->op_type != OP_PADHV)
break;
/* FALLTHROUGH */
@@ -14790,7 +14790,7 @@ Perl_rpeep(pTHX_ OP *o)
case OP_REF:
/* see if ref() is used in boolean context */
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
- S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
break;
case OP_CUSTOM: {
diff --git a/pad.c b/pad.c
index 5bbb07a092..bbc835ab31 100644
--- a/pad.c
+++ b/pad.c
@@ -1019,7 +1019,7 @@ Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
Until the lexical C<$_> feature was removed, this function would
find the position of the lexical C<$_> in the pad of the
-currently-executing function and returns the offset in the current pad,
+currently-executing function and return the offset in the current pad,
or C<NOT_IN_PAD>.
Now it always returns C<NOT_IN_PAD>.
@@ -2001,7 +2001,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV
*cloned,
{
/* my sub */
/* Just provide a stub, but name it. It will be
- upgrade to the real thing on scope entry. */
+ upgraded to the real thing on scope entry. */
dVAR;
U32 hash;
PERL_HASH(hash, PadnamePV(namesv)+1,
diff --git a/pp_sys.c b/pp_sys.c
index 65900faf5a..100762c1b7 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1149,6 +1149,7 @@ PP(pp_sselect)
struct timeval *tbuf = &timebuf;
I32 growsize;
char *fd_sets[4];
+ SV *svs[4];
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
I32 masksize;
I32 offset;
@@ -1164,7 +1165,7 @@ PP(pp_sselect)
SP -= 4;
for (i = 1; i <= 3; i++) {
- SV * const sv = SP[i];
+ SV * const sv = svs[i] = SP[i];
SvGETMAGIC(sv);
if (!SvOK(sv))
continue;
@@ -1177,9 +1178,14 @@ PP(pp_sselect)
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Non-string passed as bitmask");
- SvPV_force_nomg_nolen(sv); /* force string conversion */
+ if (SvGAMAGIC(sv)) {
+ svs[i] = sv_newmortal();
+ sv_copypv_nomg(svs[i], sv);
+ }
+ else
+ SvPV_force_nomg_nolen(sv); /* force string conversion */
}
- j = SvCUR(sv);
+ j = SvCUR(svs[i]);
if (maxlen < j)
maxlen = j;
}
@@ -1228,7 +1234,7 @@ PP(pp_sselect)
tbuf = NULL;
for (i = 1; i <= 3; i++) {
- sv = SP[i];
+ sv = svs[i];
if (!SvOK(sv) || SvCUR(sv) == 0) {
fd_sets[i] = 0;
continue;
@@ -1275,7 +1281,7 @@ PP(pp_sselect)
#endif
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
- sv = SP[i];
+ sv = svs[i];
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
s = SvPVX(sv);
for (offset = 0; offset < growsize; offset += masksize) {
@@ -1284,7 +1290,10 @@ PP(pp_sselect)
}
Safefree(fd_sets[i]);
#endif
- SvSETMAGIC(sv);
+ if (sv != SP[i])
+ SvSetMagicSV(SP[i], sv);
+ else
+ SvSETMAGIC(sv);
}
}
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
index 7aa15effc4..2603224fdd 100644
--- a/t/lib/croak/toke
+++ b/t/lib/croak/toke
@@ -133,6 +133,12 @@ state sub;
EXPECT
Missing name in "state sub" at - line 2.
########
+# NAME our sub pack::foo
+our sub foo::bar;
+EXPECT
+No package name allowed for subroutine &foo::bar in "our" at - line 1, near
"our sub foo::bar"
+Execution of - aborted due to compilation errors.
+########
# NAME my sub pack::foo
use feature 'lexical_subs', 'state';
my sub foo::bar;
diff --git a/t/op/select.t b/t/op/select.t
index d61c373b82..3e29c39fe8 100644
--- a/t/op/select.t
+++ b/t/op/select.t
@@ -1,5 +1,8 @@
#!./perl
+# This file is for testing select() with one argument. Four-argument
+# select() is tested in sselect.t.
+
BEGIN {
chdir 't' if -d 't';
require './test.pl';
diff --git a/t/op/sselect.t b/t/op/sselect.t
index a2507c788b..9ec1c63d7f 100644
--- a/t/op/sselect.t
+++ b/t/op/sselect.t
@@ -1,5 +1,7 @@
#!./perl
+# Four-argument select
+
my $hires;
BEGIN {
chdir 't' if -d 't';
@@ -11,7 +13,7 @@ BEGIN {
skip_all("Win32 miniperl has no socket select")
if $^O eq "MSWin32" && is_miniperl();
-plan (15);
+plan (16);
my $blank = "";
eval {select undef, $blank, $blank, 0};
@@ -93,3 +95,12 @@ note("diff=$diff under=$under");
select (undef, undef, undef, $sleep);
::is($count, 1, 'RT120102');
}
+
+package _131645{
+ sub TIESCALAR { bless [] }
+ sub FETCH { 0 }
+ sub STORE { }
+}
+tie $tie, _131645::;
+select ($tie, undef, undef, $tie);
+ok("no crash from select $numeric_tie, undef, undef, $numeric_tie")
diff --git a/toke.c b/toke.c
index ace92e3989..6aa5f2690e 100644
--- a/toke.c
+++ b/toke.c
@@ -8848,7 +8848,8 @@ S_pending_ident(pTHX)
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
if (has_colon)
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
- "variable %s in \"our\"",
+ "%se %s in \"our\"",
+ *PL_tokenbuf=='&' ?"subroutin":"variabl",
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
--
Perl5 Master Repository
