In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/7b6e8075e45ebc684565efbe3ce7b70435f20c79?hp=425b8234618a94b12ca70c9914e5818c3952c7ed>
- Log -----------------------------------------------------------------
commit 7b6e8075e45ebc684565efbe3ce7b70435f20c79
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 23:21:56 2013 -0700
Let av_push accept NULL values
Now that NULL is used for a nonexistent element, it is easy for XS
code to pass it to av_push(). av_store already accepts NULL, and
av_push already works with it on non-debugging builds, so there is
really no need for this restriction.
M MANIFEST
M embed.fnc
M ext/XS-APItest/APItest.xs
A ext/XS-APItest/t/av.t
M proto.h
commit 313efa9019b629125306f4c66c583d70960482b8
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 18:07:50 2013 -0700
Stop Devel'Peek'Dump with no args from crashing
I accidentally broke this in commit xxxxxxxx (5.19.3). The crash hap-
pened at compile time.
M ext/Devel-Peek/Peek.xs
M ext/Devel-Peek/t/Peek.t
commit 958c98f0f80fcd212653c42fe408bb6d9eb1f6d0
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 16:06:07 2013 -0700
regcomp.c:S_concat_pat: Allow 64-bit array offsets
M regcomp.c
commit 0cb43d32ad1fb3ae746cfccf03ac6197a775a4ec
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 16:04:40 2013 -0700
Make /@array/ handle nonexistent array elements
Commit ce0d59f changed AVs to use NULLs for nonexistent elements.
S_concat_pat in regcomp.c needs to account for that, to
avoid crashing.
M regcomp.c
M t/re/pat.t
commit de935cc90faecfae2bc1afad24f1b5315a7787a0
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 12:35:56 2013 -0700
Allow 64-bit array and stack offsets in entersub & goto
I donât have enough memory to test this, but it needs to be done even-
tually anyway.
M pp_ctl.c
M pp_hot.c
commit 8c9d3376fbfa04ec0e0e2164dcf7d9e824cf0e94
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 6 08:30:41 2013 -0700
Stop &xsub and goto &xsub from crashing on undef *_
$ perl -e 'undef *_; &Internals::V'
Segmentation fault: 11
$ perl -e 'sub { undef *_; goto &Internals::V }->()'
$ perl5.18.1 -e 'sub { undef *_; goto &Internals::V }->()'
Segmentation fault: 11
The goto case is actually a regression from 5.16 (049bd5ffd62), as
goto used to ignore changes to *_. (Fixing one bug uncovers another.)
We shouldnât assume that GvAV(PL_defgv) (*_{ARRAY}) gives us anything.
While weâre at it, since we have to add extra checks anyway, use them
to speed up empty @_ in goto (by checking items, rather than arg).
M pp_ctl.c
M pp_hot.c
M t/op/goto.t
M t/op/sub.t
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
embed.fnc | 2 +-
ext/Devel-Peek/Peek.xs | 7 +++++++
ext/Devel-Peek/t/Peek.t | 6 ++++++
ext/XS-APItest/APItest.xs | 5 +++++
ext/XS-APItest/t/av.t | 14 ++++++++++++++
pp_ctl.c | 12 +++++++-----
pp_hot.c | 10 +++++-----
proto.h | 5 ++---
regcomp.c | 7 ++++---
t/op/goto.t | 9 ++++++++-
t/op/sub.t | 9 ++++++++-
t/re/pat.t | 10 +++++++++-
13 files changed, 77 insertions(+), 20 deletions(-)
create mode 100644 ext/XS-APItest/t/av.t
diff --git a/MANIFEST b/MANIFEST
index 4679c95..d1cc4f1 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3941,6 +3941,7 @@ ext/XS-APItest/README XS::APItest extension
ext/XS-APItest/t/addissub.t test op check wrapping
ext/XS-APItest/t/arrayexpr.t test recursive descent expression parsing
ext/XS-APItest/t/autoload.t Test XS AUTOLOAD routines
+ext/XS-APItest/t/av.t Test AV functions
ext/XS-APItest/t/BHK.pm Helper for ./blockhooks.t
ext/XS-APItest/t/blockasexpr.t test recursive descent block parsing
ext/XS-APItest/t/blockhooks-csc.t XS::APItest: more tests for
PL_blockhooks
diff --git a/embed.fnc b/embed.fnc
index 11425ad..4940ae4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -219,7 +219,7 @@ ApdR |SSize_t|av_len |NN AV *av
ApdR |AV* |av_make |SSize_t size|NN SV **strp
Apd |SV* |av_pop |NN AV *av
ApdoxM |void |av_create_and_push|NN AV **const avp|NN SV *const val
-Apd |void |av_push |NN AV *av|NN SV *val
+Apd |void |av_push |NN AV *av|NULLOK SV *val
: Used in scope.c, and by Data::Alias
EXp |void |av_reify |NN AV *av
ApdR |SV* |av_shift |NN AV *av
diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs
index 73094b8..91b7555 100644
--- a/ext/Devel-Peek/Peek.xs
+++ b/ext/Devel-Peek/Peek.xs
@@ -389,6 +389,13 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
prev = aop;
aop = aop->op_sibling;
}
+ if (!aop) {
+ /* It doesnât really matter what we return here, as this only
+ occurs after yyerror. */
+ op_free(first);
+ return entersubop;
+ }
+
/* aop now points to the second arg if there is one, the cvop otherwise
*/
if (aop->op_sibling) {
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index 929ce79..7025b45 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -1039,6 +1039,12 @@ SV = PV\($ADDR\) at $ADDR
LEN = \d+
SUBSTR
+# Dump with no arguments
+eval 'Dump';
+like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
+eval 'Dump()';
+like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
+
SKIP: {
skip "Not built with usemymalloc", 2
unless $Config{usemymalloc} eq 'y';
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 16d26de..85e2b01 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3467,6 +3467,11 @@ alias_av(AV *av, IV ix, SV *sv)
CODE:
av_store(av, ix, SvREFCNT_inc(sv));
+void
+av_pushnull(AV *av)
+ CODE:
+ av_push(av, NULL);
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
diff --git a/ext/XS-APItest/t/av.t b/ext/XS-APItest/t/av.t
new file mode 100644
index 0000000..03e2aa6
--- /dev/null
+++ b/ext/XS-APItest/t/av.t
@@ -0,0 +1,14 @@
+#!perl
+
+use Test::More tests => 4;
+use XS::APItest;
+
+av_pushnull \@_;
+is $#_, 0, '$#_ after av_push(@_, NULL)';
+ok !exists $_[0], '!exists $_[0] after av_push(@_,NULL)';
+
+use Tie::Array;
+tie @tied, 'Tie::StdArray';
+av_pushnull \@tied;
+is $#tied, 0, '$#tied after av_push(@tied, NULL)';
+is $tied[0], undef, '$tied[0] is undef after av_push(@tied,NULL)';
diff --git a/pp_ctl.c b/pp_ctl.c
index 24a8cd6..7fd27f8 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2895,19 +2895,21 @@ PP(pp_goto) /* also pp_dump */
OP* const retop = cx->blk_sub.retop;
SV **newsp;
I32 gimme;
- const SSize_t items = AvFILLp(arg) + 1;
+ const SSize_t items = arg ? AvFILLp(arg) + 1 : 0;
SV** mark;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
/* put GvAV(defgv) back onto stack */
- EXTEND(SP, items+1); /* @_ could have been extended. */
- Copy(AvARRAY(arg), SP + 1, items, SV*);
+ if (items) {
+ EXTEND(SP, items+1); /* @_ could have been extended. */
+ Copy(AvARRAY(arg), SP + 1, items, SV*);
+ }
mark = SP;
SP += items;
- if (AvREAL(arg)) {
- I32 index;
+ if (items && AvREAL(arg)) {
+ SSize_t index;
for (index=0; index<items; index++)
if (SP[-index])
SvREFCNT_inc_void_NN(sv_2mortal(SP[-index]));
diff --git a/pp_hot.c b/pp_hot.c
index 2598ef0..d3f8976 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2640,7 +2640,7 @@ try_autoload:
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- I32 items = SP - MARK;
+ SSize_t items = SP - MARK;
PADLIST * const padlist = CvPADLIST(cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
@@ -2703,7 +2703,7 @@ try_autoload:
RETURNOP(CvSTART(cv));
}
else {
- I32 markix = TOPMARK;
+ SSize_t markix = TOPMARK;
SAVETMPS;
PUTBACK;
@@ -2714,12 +2714,12 @@ try_autoload:
!CvLVALUE(cv))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- if (!hasargs) {
+ if (!hasargs && GvAV(PL_defgv)) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
AV * const av = GvAV(PL_defgv);
- const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
+ const SSize_t items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
SSize_t i = 0;
@@ -2736,7 +2736,7 @@ try_autoload:
}
else {
SV **mark = PL_stack_base + markix;
- I32 items = SP - mark;
+ SSize_t items = SP - mark;
while (items--) {
mark++;
if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
diff --git a/proto.h b/proto.h
index 7819f21..388fa64 100644
--- a/proto.h
+++ b/proto.h
@@ -221,10 +221,9 @@ PERL_CALLCONV SV* Perl_av_pop(pTHX_ AV *av)
assert(av)
PERL_CALLCONV void Perl_av_push(pTHX_ AV *av, SV *val)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_AV_PUSH \
- assert(av); assert(val)
+ assert(av)
PERL_CALLCONV void Perl_av_reify(pTHX_ AV *av)
__attribute__nonnull__(pTHX_1);
diff --git a/regcomp.c b/regcomp.c
index 450ac90..e0787e1 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5030,6 +5030,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
STRLEN orig_patlen = 0;
bool code = 0;
SV *msv = use_delim ? delim : *svp;
+ if (!msv) msv = &PL_sv_undef;
/* if we've got a delimiter, we go round the loop twice for each
* svp slot (except the last), using the delimiter the second
@@ -5048,7 +5049,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
* The code in this block is based on S_pushav() */
AV *const av = (AV*)msv;
- const I32 maxarg = AvFILL(av) + 1;
+ const SSize_t maxarg = AvFILL(av) + 1;
SV **array;
if (oplist) {
@@ -5058,11 +5059,11 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
}
if (SvRMAGICAL(av)) {
- U32 i;
+ SSize_t i;
Newx(array, maxarg, SV*);
SAVEFREEPV(array);
- for (i=0; i < (U32)maxarg; i++) {
+ for (i=0; i < maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
array[i] = svp ? *svp : &PL_sv_undef;
}
diff --git a/t/op/goto.t b/t/op/goto.t
index 1336685..5c96f8b 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
use warnings;
use strict;
-plan tests => 91;
+plan tests => 92;
our $TODO;
my $deprecated = 0;
@@ -491,6 +491,13 @@ is ${*__}[0], 'rough and tubbery', 'goto &foo leaves
reified @_ alone';
is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub';
}
+# goto &xsub when @_ itself does not exist
+undef *_;
+eval { & { sub { goto &utf8::encode } } };
+# The main thing we are testing is that it did not crash. But make sure
+# *_{ARRAY} was untouched, too.
+is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
+
# [perl #36521] goto &foo in warn handler could defeat recursion avoider
{
diff --git a/t/op/sub.t b/t/op/sub.t
index bbb9d76..2088662 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan( tests => 29 );
+plan( tests => 30 );
sub empty_sub {}
@@ -175,3 +175,10 @@ is eval {
is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
}
+
+# &xsub when @_ itself does not exist
+undef *_;
+eval { &utf8::encode };
+# The main thing we are testing is that it did not crash. But make sure
+# *_{ARRAY} was untouched, too.
+is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
diff --git a/t/re/pat.t b/t/re/pat.t
index 5c44429..2586647 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -20,7 +20,7 @@ BEGIN {
require './test.pl';
}
-plan tests => 698; # Update this when adding/deleting tests.
+plan tests => 699; # Update this when adding/deleting tests.
run_tests() unless caller;
@@ -1471,6 +1471,14 @@ EOP
is ($s, 'XbXX$XX&', 'RT #45667 with /x');
}
+ {
+ no warnings "uninitialized";
+ my @a;
+ $a[1]++;
+ /@a/;
+ pass('no crash with /@a/ when array has nonexistent elems');
+ }
+
} # End of sub run_tests
1;
--
Perl5 Master Repository
