t/op/lexsub.t See if lexical subroutines work
t/op/lex.t Tests too complex for t/base/lex.t
t/op/lfs.t See if large files work for perlio
-t/op/list.t See if array lists work
+t/op/list.t See if lists and list slices work
t/op/localref.t See if local ${deref} works
t/op/local.t See if local works
t/op/lock.t Tests for lock args & retval (no threads)
like $@, mkErr("Parameter 'fred' not writable"),
"wanted writable, got readonly";
+ skip '\\ returns mutable value in 5.19.3', 1
+ if $] >= 5.019003;
+
eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => \'abc') ; };
like $@, mkErr("Parameter 'fred' not writable"),
"wanted writable, got readonly";
use Config;
skip 'readonly + threads', 1
- if $Config{useithreads};
+ if $Config{useithreads} || $] >= 5.019003;
eval { $a = $Func->(\$in, \$out, TrailingData => \"abc") ;} ;
use warnings::register;
use vars qw($VERSION %declared);
-$VERSION = '1.27';
+$VERSION = '1.28';
#=======================================================================
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
# By doing this, we save 1 run time check for *every* call to import.
- no strict 'refs';
my $const = $] > 5.009002;
- *_CAN_PCS = sub () {$const};
-
my $downgrade = $] < 5.015004; # && $] >= 5.008
- *_DOWNGRADE = sub () { $downgrade };
+ my $constarray = $] >= 5.019003;
+ if ($const) {
+ Internals::SvREADONLY($const, 1);
+ Internals::SvREADONLY($downgrade, 1);
+ $constant::{_CAN_PCS} = \$const;
+ $constant::{_DOWNGRADE} = \$downgrade;
+ $constant::{_CAN_PCS_FOR_ARRAY} = \$constarray;
+ }
+ else {
+ no strict 'refs';
+ *{"_CAN_PCS"} = sub () {$const};
+ *{"_DOWNGRADE"} = sub () { $downgrade };
+ *{"_CAN_PCS_FOR_ARRAY"} = sub () { $constarray };
+ }
}
#=======================================================================
# The constant serves to optimise this entire block out on
# 5.8 and earlier.
- if (_CAN_PCS && $symtab && !exists $symtab->{$name}) {
- # No typeglob yet, so we can use a reference as space-
- # efficient proxy for a constant subroutine
+ if (_CAN_PCS) {
+ # Use a reference as a proxy for a constant subroutine.
+ # If this is not a glob yet, it saves space. If it is
+ # a glob, we must still create it this way to get the
+ # right internal flags set, as constants are distinct
+ # from subroutines created with sub(){...}.
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
- $symtab->{$name} = \$scalar;
- ++$flush_mro;
+ if ($symtab && !exists $symtab->{$name}) {
+ $symtab->{$name} = \$scalar;
+ ++$flush_mro;
+ }
+ else {
+ local $constant::{_dummy} = \$scalar;
+ *$full_name = \&{"_dummy"};
+ }
} else {
*$full_name = sub () { $scalar };
}
} elsif (@_) {
my @list = @_;
- *$full_name = sub () { @list };
+ if (_CAN_PCS_FOR_ARRAY) {
+ Internals::SvREADONLY(@list, 1);
+ Internals::SvREADONLY($list[$_], 1) for 0..$#list;
+ if ($symtab && !exists $symtab->{$name}) {
+ $symtab->{$name} = \@list;
+ $flush_mro++;
+ }
+ else {
+ local $constant::{_dummy} = \@list;
+ *$full_name = \&{"_dummy"};
+ }
+ }
+ else { *$full_name = sub () { @list }; }
} else {
*$full_name = sub () { };
}
=head1 CAVEATS
-In the current version of Perl, list constants are not inlined
-and some symbols may be redefined without generating a warning.
+List constants are not inlined unless you are using Perl v5.20 or higher.
It is not possible to have a subroutine or a keyword with the same
name as a constant in the same package. This is probably a Good Thing.
use strict;
-use Test::More tests => 96;
+use Test::More tests => 104;
my $TB = Test::More->builder;
BEGIN { use_ok('constant'); }
eval 'use constant undef, 5; 1';
like $@, qr/\ACan't use undef as constant name at /;
}
+
+# Constants created by "use constant" should be read-only
+
+# This test will not test what we are trying to test if this glob entry
+# exists already, so test that, too.
+ok !exists $::{immutable};
+eval q{
+ use constant immutable => 23987423874;
+ for (immutable) { eval { $_ = 22 } }
+ like $@, qr/^Modification of a read-only value attempted at /,
+ 'constant created in empty stash slot is immutable';
+ eval { for (immutable) { ${\$_} = 432 } };
+ SKIP: {
+ require Config;
+ if ($Config::Config{useithreads}) {
+ skip "fails under threads", 1 if $] < 5.019003;
+ }
+ like $@, qr/^Modification of a read-only value attempted at /,
+ '... and immutable through refgen, too';
+ }
+};
+() = \&{"immutable"}; # reify
+eval 'for (immutable) { $_ = 42 }';
+like $@, qr/^Modification of a read-only value attempted at /,
+ '... and after reification';
+
+# Use an existing stash element this time.
+# This next line is sufficient to trigger a different code path in
+# constant.pm.
+() = \%::existing_stash_entry;
+use constant existing_stash_entry => 23987423874;
+for (existing_stash_entry) { eval { $_ = 22 } }
+like $@, qr/^Modification of a read-only value attempted at /,
+ 'constant created in existing stash slot is immutable';
+eval { for (existing_stash_entry) { ${\$_} = 432 } };
+SKIP: {
+ if ($Config::Config{useithreads}) {
+ skip "fails under threads", 1 if $] < 5.019003;
+ }
+ like $@, qr/^Modification of a read-only value attempted at /,
+ '... and immutable through refgen, too';
+}
+
+# Test that list constants are also immutable. This only works under
+# 5.19.3 and later.
+SKIP: {
+ skip "fails under 5.19.2 and earlier", 2 if $] < 5.019003;
+ use constant constant_list => 1..2;
+ for (constant_list) {
+ my $num = $_;
+ eval { $_++ };
+ like $@, qr/^Modification of a read-only value attempted at /,
+ "list constant has constant elements ($num)";
+ }
+}
: Used in pp.c and pp_sys.c
ApdR |SV* |gv_const_sv |NN GV* gv
ApdR |SV* |cv_const_sv |NULLOK const CV *const cv
+pR |SV* |cv_const_sv_or_av|NULLOK const CV *const cv
: Used in pad.c
-pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv
+pR |SV* |op_const_sv |NULLOK const OP* o
Apd |void |cv_undef |NN CV* cv
p |void |cv_forget_slab |NN CV *cv
Ap |void |cx_dump |NN PERL_CONTEXT* cx
#define croak_popstack Perl_croak_popstack
#define cv_ckproto_len_flags(a,b,c,d,e) Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
#define cv_clone_into(a,b) Perl_cv_clone_into(aTHX_ a,b)
+#define cv_const_sv_or_av(a) Perl_cv_const_sv_or_av(aTHX_ a)
#define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a)
#define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b)
#define cvstash_set(a,b) Perl_cvstash_set(aTHX_ a,b)
#define nextargv(a) Perl_nextargv(aTHX_ a)
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
-#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b)
+#define op_const_sv(a) Perl_op_const_sv(aTHX_ a)
#define op_unscope(a) Perl_op_unscope(aTHX_ a)
#define package_version(a) Perl_package_version(aTHX_ a)
#define pad_block_start(a) Perl_pad_block_start(aTHX_ a)
use vars qw($TODO $Level $using_open);
require "test.pl";
-our $VERSION = '0.09';
+our $VERSION = '0.10';
# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
being tested, and saved into the synthesized property B<wanted>.
Individual sample lines may be suffixed with whitespace followed
-by (<|<=|==|>=|>)5.nnnn to select that line only for the listed perl
+by (<|<=|==|>=|>)5.nnnn (up to two times) to
+select that line only for the listed perl
version; the whitespace and conditional are stripped.
=head2 bcopts => $bcopts || [ @bcopts ]
# strip out conditional lines
- $str =~ s{^(.*?)\s+(<|<=|==|>=|>)\s*(5\.\d+)\ *\n}
+ $str =~ s{^(.*?) \s+(<|<=|==|>=|>)\s*(5\.\d+)
+ (?:\s+(<|<=|==|>=|>)\s*(5\.\d+))? \ *\n}
{
- my ($line, $cmp, $version) = ($1,$2,$3);
+ my ($line, $cmp, $version, $cmp2, $v2) = ($1,$2,$3,$4,$5,$6);
my $repl = "";
if ( $cmp eq '<' ? $] < $version
: $cmp eq '<=' ? $] <= $version
: $cmp eq '>=' ? $] >= $version
: $cmp eq '>' ? $] > $version
: die("bad comparision '$cmp' in string [$str]\n")
+ and !$cmp2 || (
+ $cmp2 eq '<' ? $] < $v2
+ : $cmp2 eq '<=' ? $] <= $v2
+ : $cmp2 eq '==' ? $] == $v2
+ : $cmp2 eq '>=' ? $] >= $v2
+ : $cmp2 eq '>' ? $] > $v2
+ : die("bad comparision '$cmp2' in string [$str]\n")
+ )
) {
$repl = "$line\n";
}
$repl;
- }gem;
+ }gemx;
$tc->{wantstr} = $str;
EONT_EONT
-my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
+my ($expect, $expect_nt) =
+ $] >= 5.019003
+ ? (" is a constant sub, optimized to a AV\n") x 2
+ : (<<'EOT_EOT', <<'EONT_EONT');
# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
# - <@> lineseq K ->3
# 1 <;> nextstate(constant 61 constant.pm:118) v:*,&,x*,x&,x$ ->2
# n <$> const[PV "b-cmp-a"] s ->o
# p <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
# q <$> const[PVNV 0] s/SHORT ->r < 5.017002
-# q <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002
+# q <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002 < 5.019003
+# q <$> const[SPECIAL sv_no] s/FOLD,SHORT ->r >=5.019003
EOT_EOT
# r <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->r
$c + $d,
'SV = ([NI])V\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(PADTMP,\1OK,p\1OK\\)
+ FLAGS = \\(PADTMP,\1OK,p\1OK\\) # $] < 5.019003
+ FLAGS = \\(\1OK,p\1OK\\) # $] >=5.019003
\1V = 456');
($d = "789") += 0.1;
chr(256).chr(0).chr(512),
'SV = PV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
+ FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
+ FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\) # $] >=5.019003
PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
CUR = 5
LEN = \\d+');
chr(256).chr(0).chr(512),
'SV = PV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
+ FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
+ FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\) # $] >=5.019003
PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
CUR = 5
LEN = \\d+');
use warnings;
use Carp;
-our $VERSION = '0.54';
+our $VERSION = '0.55';
require XSLoader;
for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
- if (SvPOKp(name)) {
+ if (PadnameLEN(name)) {
av_push(retav, newSVpadname(name));
}
}
if (SvTYPE(gv) == SVt_PVGV)
return cv_const_sv(GvCVu(gv));
- return SvROK(gv) ? SvRV(gv) : NULL;
+ return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
}
GP *
if (has_constant) {
/* The constant has to be a simple scalar type. */
switch (SvTYPE(has_constant)) {
- case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVFM:
$| = 1;
BEGIN { require './test.pl' }
-plan tests => 5191;
+plan tests => 5193;
use Scalar::Util qw(tainted);
}
{
+ # Check readonliness of constants, whether shared hash key
+ # scalars or no (brought up in bug #109744)
+ BEGIN { overload::constant integer => sub { "main" }; }
+ eval { ${\5} = 'whatever' };
+ like $@, qr/^Modification of a read-only value attempted at /,
+ 'constant overloading makes read-only constants';
+ BEGIN { overload::constant integer => sub { __PACKAGE__ }; }
+ eval { ${\5} = 'whatever' };
+ like $@, qr/^Modification of a read-only value attempted at /,
+ '... even with shared hash key scalars';
+}
+
+{
package Sklorsh;
use overload
bool => sub { shift->is_cool };
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOPo->op_sv) {
- const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type != OP_METHOD_NAMED &&
- (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
- {
- /* If op_sv is already a PADTMP/MY then it is being used by
- * some pad, so make a copy. */
- sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
- SvREFCNT_dec(cSVOPo->op_sv);
- }
- else if (o->op_type != OP_METHOD_NAMED
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
+ if (o->op_type != OP_METHOD_NAMED
&& cSVOPo->op_sv == &PL_sv_undef) {
/* PL_sv_undef is hack - it's unsafe to store it in the
AV that is the pad, because av_fetch treats values of
}
else {
SvREFCNT_dec(PAD_SVl(ix));
- SvPADTMP_on(cSVOPo->op_sv);
PAD_SETSV(ix, cSVOPo->op_sv);
/* XXX I don't know how this isn't readonly already. */
if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_inc_simple_void(sv);
SvTEMP_off(sv);
}
+ else { assert(SvIMMORTAL(sv)); }
break;
case 3:
/* Something tried to die. Abandon constant folding. */
op_free(o);
#endif
assert(sv);
+ if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
dVAR;
OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
+ SV **svp;
+ AV *av;
list(o);
if (PL_parser && PL_parser->error_count)
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
curop = ((UNOP*)o)->op_first;
- ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
+ av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
+ ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
+ if (AvFILLp(av) != -1)
+ for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
+ SvPADTMP_on(*svp);
#ifdef PERL_MAD
op_getmad(curop,o,'O');
#else
}
static void const_sv_xsub(pTHX_ CV* cv);
+static void const_av_xsub(pTHX_ CV* cv);
/*
SV *
Perl_cv_const_sv(pTHX_ const CV *const cv)
{
+ SV *sv;
PERL_UNUSED_CONTEXT;
if (!cv)
return NULL;
if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
return NULL;
+ sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
+ if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
+ return sv;
+}
+
+SV *
+Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
+{
+ PERL_UNUSED_CONTEXT;
+ if (!cv)
+ return NULL;
+ assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
- *
- * !cv
- * look for a single OP_CONST with attached value: return the value
- *
- * cv && CvCLONE(cv) && !CvCONST(cv)
- *
- * examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
*/
SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+Perl_op_const_sv(pTHX_ const OP *o)
{
dVAR;
SV *sv = NULL;
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
- if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
- sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
- }
else {
return NULL;
}
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = op_const_sv(block);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
+ SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = op_const_sv(block);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
+ SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+ cv = newXS_len_flags(name, len,
+ sv && SvTYPE(sv) == SVt_PVAV
+ ? const_av_xsub
+ : const_sv_xsub,
+ file ? file : "", "",
&sv, XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
CvCONST_on(cv);
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
+ if (SvTYPE(kidsv) == SVt_PVAV) return o;
if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
const char *badthing;
switch (o->op_type) {
{
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
- if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
+ SvREADONLY_on(cSVOPo->op_sv);
return o;
}
XSRETURN(1);
}
+static void
+const_av_xsub(pTHX_ CV* cv)
+{
+ dVAR;
+ dXSARGS;
+ AV * const av = MUTABLE_AV(XSANY.any_ptr);
+ SP -= items;
+ assert(av);
+#ifndef DEBUGGING
+ if (!av) {
+ XSRETURN(0);
+ }
+#endif
+ if (SvRMAGICAL(av))
+ Perl_croak(aTHX_ "Magical list constants are not supported");
+ if (GIMME_V != G_ARRAY) {
+ EXTEND(SP, 1);
+ ST(0) = newSViv((IV)AvFILLp(av)+1);
+ XSRETURN(1);
+ }
+ EXTEND(SP, AvFILLp(av)+1);
+ Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
+ XSRETURN(AvFILLp(av)+1);
+}
+
/*
* Local variables:
* c-indentation-style: bsd
AV which is @_. Other entries are storage for variables and op targets.
Iterating over the PADNAMELIST iterates over all possible pad
-items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
-&PL_sv_undef "names" (see pad_alloc()).
+items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
+"names", while slots for constants have &PL_sv_no "names" (see
+pad_alloc()). That &PL_sv_no is used is an implementation detail subject
+to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
SVs_PADMY named lexical variable ("my", "our", "state")
SVs_PADTMP unnamed temporary store
+ SVf_READONLY constant shared between recursion levels
+
+C<SVf_READONLY> has been supported here only since perl 5.20. To work with
+earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
+does not cause the SV in the pad slot to be marked read-only, but simply
+tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
+least should be treated as such.
I<optype> should be an opcode indicating the type of operation that the
pad entry is to support. This doesn't affect operational semantics,
const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
/*
- * "foreach" index vars temporarily become aliases to non-"my"
- * values. Thus we must skip, not just pad values that are
+ * Entries that close over unavailable variables
+ * in outer subs contain values not marked PADMY.
+ * Thus we must skip, not just pad values that are
* marked as current pad values, but also those with names.
*/
- /* HVDS why copy to sv here? we don't seem to use it */
if (++PL_padix <= names_fill &&
(sv = names[PL_padix]) && sv != &PL_sv_undef)
continue;
sv = *av_fetch(PL_comppad, PL_padix, TRUE);
if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
- !IS_PADGV(sv) && !IS_PADCONST(sv))
+ !IS_PADGV(sv))
break;
}
+ if (tmptype & SVf_READONLY) {
+ av_store(PL_comppad_name, PL_padix, &PL_sv_no);
+ tmptype &= ~SVf_READONLY;
+ tmptype |= SVs_PADTMP;
+ }
retval = PL_padix;
}
SvFLAGS(sv) |= tmptype;
for (off = top; (I32)off > PL_comppad_name_floor; off--) {
SV * const sv = svp[off];
if (sv
- && sv != &PL_sv_undef
+ && PadnameLEN(sv)
&& !SvFAKE(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
while (off > 0) {
SV * const sv = svp[off];
if (sv
- && sv != &PL_sv_undef
+ && PadnameLEN(sv)
&& !SvFAKE(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
+ if (namesv && PadnameLEN(namesv) == namelen
&& !SvFAKE(namesv)
&& (SvPAD_OUR(namesv))
- && SvCUR(namesv) == namelen
&& sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
&& COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
- && SvCUR(namesv) == namelen
+ if (namesv && PadnameLEN(namesv) == namelen
&& sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
{
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
SV * const sv = svp[i];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv)
&& COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
const SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv))
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"%"SVf" never introduced",
SVfARG(sv));
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv)
&& COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
"Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
- if (PL_curpad[po])
- SvPADTMP_off(PL_curpad[po]);
if (refadjust)
SvREFCNT_dec(PL_curpad[po]);
#else
PL_curpad[po] = &PL_sv_undef;
#endif
+ if (PadnamelistMAX(PL_comppad_name) != -1
+ && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
+ assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
+ PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
+ }
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
const SV *namesv = pname[ix];
- if (namesv && namesv == &PL_sv_undef) {
+ if (namesv && !PadnameLEN(namesv)) {
namesv = NULL;
}
if (namesv) {
for (ix = fpad; ix > 0; ix--) {
SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
SV *sv = NULL;
- if (namesv && namesv != &PL_sv_undef) { /* lexical */
+ if (namesv && PadnameLEN(namesv)) { /* lexical */
if (SvFAKE(namesv)) { /* lexical from outside? */
/* formats may have an inactive, or even undefined, parent;
but state vars are always available. */
cv_dump(cv, "To");
);
- if (CvCONST(cv)) {
- /* Constant sub () { $x } closing over $x - see lib/constant.pm:
- * The prototype was marked as a candiate for const-ization,
- * so try to grab the current const value, and if successful,
- * turn into a const sub:
- */
- SV* const const_sv = op_const_sv(CvSTART(cv), cv);
- if (const_sv) {
- SvREFCNT_dec_NN(cv);
- /* For this calling case, op_const_sv returns a *copy*, which we
- donate to newCONSTSUB. Yes, this is ugly, and should be killed.
- Need to fix how lib/constant.pm works to eliminate this. */
- cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
- }
- else {
- CvCONST_off(cv);
- }
- }
-
return cv;
}
AV *av;
for ( ;ix > 0; ix--) {
- if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ if (names_fill >= ix && PadnameLEN(names[ix])) {
const char sigil = SvPVX_const(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE)
|| (SvFLAGS(names[ix]) & SVpad_STATE)
SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
for ( ;ix > 0; ix--) {
if (!oldpad[ix]) {
pad1a[ix] = NULL;
- } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ } else if (names_fill >= ix && PadnameLEN(names[ix])) {
const char sigil = SvPVX_const(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE)
|| (SvFLAGS(names[ix]) & SVpad_STATE)
}
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
pad1a[ix] = sv_dup_inc(oldpad[ix], param);
}
else {
#define PadMAX(pad) AvFILLp(pad)
#define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL)
-#define PadnameLEN(pn) SvCUR(pn)
+#define PadnameLEN(pn) ((pn) == &PL_sv_undef ? 0 : SvCUR(pn))
#define PadnameUTF8(pn) !!SvUTF8(pn)
#define PadnameSV(pn) pn
#define PadnameIsOUR(pn) !!SvPAD_OUR(pn)
/* ensure comppad/curpad to refer to main's pad */
if (CvPADLIST(PL_main_cv)) {
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+ PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
}
op_free(PL_main_root);
PL_main_root = NULL;
if (ps->compcv != PL_compcv) {
PL_compcv = ps->compcv;
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
+ PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
}
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
op_free(ps->val.opval);
See also L<attributes.pm|attributes>.
+=item Magical list constants are not supported
+
+(F) You assigned a magical array to a stash element, and then tried
+to use the subroutine from the same slot. You are asking Perl to do
+something it cannot do, details subject to change between Perl versions.
+
=item Malformed integer in [] in pack
(F) Between the brackets enclosing a numeric repeat count only digits
static const char* const oom_list_extend = "Out of memory during list extend";
const I32 items = SP - MARK;
const I32 max = items * count;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
/* Did the max computation overflow? */
}
#else
if (*SP)
+ {
+ if (mod && SvPADTMP(*SP) && !IS_PADGV(*SP))
+ *SP = sv_mortalcopy(*SP);
SvTEMP_off((*SP));
+ }
#endif
SP--;
}
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
SV ** const firstrelem = lastlelem + 1;
I32 is_something_there = FALSE;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
const I32 max = lastrelem - lastlelem;
SV **lelem;
is_something_there = TRUE;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
+ else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
+ *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
}
}
if (is_something_there)
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
+ if (SvPADTMP(src) && !IS_PADGV(src)) {
+ src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ PL_tmps_floor++;
+ }
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
+ if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
*itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
+ if (SvPADTMP(sv) && !IS_PADGV(sv))
+ sv = newSVsv(sv);
+ else {
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
}
else
sv = &PL_sv_undef;
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
+ if (SvPADTMP(src) && !IS_PADGV(src)) {
+ src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ PL_tmps_floor++;
+ }
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
}
ENTER;
- SAVETMPS;
retry:
if (CvCLONE(cv) && ! CvCLONED(cv))
Copy(MARK,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
+ MARK = AvARRAY(av);
while (items--) {
if (*MARK)
+ {
+ if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+ *MARK = sv_mortalcopy(*MARK);
SvTEMP_off(*MARK);
+ }
MARK++;
}
}
+ SAVETMPS;
if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
!CvLVALUE(cv))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
else {
I32 markix = TOPMARK;
+ SAVETMPS;
PUTBACK;
if (((PL_op->op_private
OP* const nextop = PL_op->op_next;
I32 overloading = 0;
bool hasargs = FALSE;
+ bool copytmps;
I32 is_xsub = 0;
I32 sorting_av = 0;
const U8 priv = PL_op->op_private;
/* shuffle stack down, removing optional initial cv (p1!=p2), plus
* any nulls; also stringify or converting to integer or number as
* required any args */
+ copytmps = !sorting_av && PL_sortcop;
for (i=max; i > 0 ; i--) {
if ((*p1 = *p2++)) { /* Weed out nulls. */
+ if (copytmps && SvPADTMP(*p1) && !IS_PADGV(*p1))
+ *p1 = sv_mortalcopy(*p1);
SvTEMP_off(*p1);
if (!PL_sortcop) {
if (priv & OPpSORT_NUMERIC) {
PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ const CV *const cv)
__attribute__warn_unused_result__;
+PERL_CALLCONV SV* Perl_cv_const_sv_or_av(pTHX_ const CV *const cv)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV void Perl_cv_forget_slab(pTHX_ CV *cv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CV_FORGET_SLAB \
#define PERL_ARGS_ASSERT_OP_CLEAR \
assert(o)
-PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv)
+PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o)
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context)
/* see how far we have to get to not match where we matched before */
reginfo->till = startpos+minend;
+ if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv) && !IS_PADGV(sv)) {
+ /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
+ S_cleanup_regmatch_info_aux has executed (registered by
+ SAVEDESTRUCTOR_X below). S_cleanup_regmatch_info_aux modifies
+ magic belonging to this SV.
+ Not newSVsv, either, as it does not COW.
+ */
+ reginfo->sv = newSV(0);
+ sv_setsv(reginfo->sv, sv);
+ SAVEFREESV(reginfo->sv);
+ }
+
/* reserve next 2 or 3 slots in PL_regmatch_state:
* slot N+0: may currently be in use: skip it
* slot N+1: use for regmatch_info_aux struct
#!./perl
-print "1..14\n";
+print "1..15\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n";
}
+# [perl #78194] foreach() aliasing op return values
+for ("${\''}") {
+ print "not " unless \$_ == \$_;
+ print 'ok 15 - [perl \#78194] \$_ == \$_ inside for("$x"){...}',
+ "\n";
+}
# we've not yet verified that use works.
# use strict;
-print "1..26\n";
+print "1..27\n";
my $test = 0;
# Historically constant folding was performed by evaluating the ops, and if
print "not " unless -z $n;
print "ok ", ++$test, " - truncate(const ? word : ...)\n";
unlink $n;
+
+# Constant folding should not change the mutability of returned values.
+for(1+2) {
+ eval { $_++ };
+ print "not " unless $_ eq 4;
+ print "ok ", ++$test,
+ " - 1+2 returns mutable value, just like \$a+\$b",
+ "\n";
+}
require "test.pl";
}
-plan( tests => 62 );
+plan( tests => 66 );
{
my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
"proper error on variable as block. [perl #37314]");
}
+# [perl #78194] grep/map aliasing op return values
+grep is(\$_, \$_, '[perl #78194] \$_ == \$_ inside grep ..., "$x"'),
+ "${\''}", "${\''}";
+map is(\$_, \$_, '[perl #78194] \$_ == \$_ inside map ..., "$x"'),
+ "${\''}", "${\''}";
+
# [perl #92254] freeing $_ in gremap block
{
my $y;
use warnings;
-plan( tests => 245 );
+plan( tests => 250 );
# type coercion on assignment
$foo = 'foo';
is (eval 'biff', "Value", "Constant has correct value");
is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
+$::{yarrow} = [4,5,6];
+is join("-", eval "yarrow()"), '4-5-6', 'array ref as stash elem';
+is ref $::{yarrow}, "ARRAY", 'stash elem is still array ref after use';
+is join("-", eval "&yarrow"), '4-5-6', 'calling const list with &';
+is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args';
+is prototype "yarrow", "", 'const list has "" prototype';
+is eval "yarrow", 3, 'const list in scalar cx returns length';
+
{
use vars qw($glook $smek $foof);
# Check reference assignment isn't affected by the SV type (bug #38439)
format =
.
-foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
# *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
# IO::Handle, which isn't what we want.
my $type = $value;
}
require "test.pl";
-plan( tests => 64 );
+plan( tests => 65 );
@foo = (1, 2, 3, 4);
cmp_ok($foo[0], '==', 1, 'first elem');
("const", my $x) ||= 1;
is( $x, 1 );
}
+
+# [perl #78194] list slice aliasing op return values
+sub {
+ is(\$_[0], \$_[1],
+ '[perl #78194] \$_[0] == \$_[1] when @_ aliases elems repeated by lslice'
+ )
+}
+ ->(("${\''}")[0,0]);
require './test.pl';
}
-plan tests => 19;
+plan tests => 23;
# not() tests
pass("logical negation of empty list") if not();
my $c = Scalar::Util::dualvar(0,"1");
is not($c), "", 'not(dualvar) ignores false int when string is true';
}
+
+# not’s return value should be read-only, as it is the same global scalar
+# each time (and test that it is, too).
+*yes = \not 0;
+*no = \not 1;
+for (!0) { eval { $_ = 43 } }
+like $@, qr/^Modification of a read-only value attempted at /,
+ 'not 0 is read-only';
+for (!1) { eval { $_ = 43 } }
+like $@, qr/^Modification of a read-only value attempted at /,
+ 'not 1 is read-only';
+require Config;
+is \!0, \$yes, '!0 returns the same value each time [perl #114838]';
+is \!1, \$no, '!1 returns the same value each time [perl #114838]';
is( ( join ' ', map { join '', map ++$_, ($x=1)..4 } 1..2 ), '2345 2345',
'modifiable variable num range' );
-is( ( join ' ', map { join '', map ++$_, 1..4 } 1..2 ), '2345 3456',
- 'modifiable const num range' ); # Unresolved bug RT#3105
+is( ( join ' ', map { join '', map ++$_, 1..4 } 1..2 ), '2345 2345',
+ 'modifiable const num range' ); # RT#3105
$s = ''; for (1..2) { for (1..4) { $s .= ++$_ } $s.=' ' if $_==1; }
is( $s, '2345 2345','modifiable num counting loop counter' );
is( ( join ' ', map { join '', map ++$_, ($x='a')..'d' } 1..2 ), 'bcde bcde',
'modifiable variable alpha range' );
-is( ( join ' ', map { join '', map ++$_, 'a'..'d' } 1..2 ), 'bcde cdef',
- 'modifiable const alpha range' ); # Unresolved bug RT#3105
+is( ( join ' ', map { join '', map ++$_, 'a'..'d' } 1..2 ), 'bcde bcde',
+ 'modifiable const alpha range' ); # RT#3105
$s = ''; for (1..2) { for ('a'..'d') { $s .= ++$_ } $s.=' ' if $_==1; }
is( $s, 'bcde bcde','modifiable alpha counting loop counter' );
# [perl #19566]: sv_gets writes directly to its argument via
# TARG. Test that we respect SvREADONLY.
-eval { for (\2) { $_ = <FH> } };
+use constant roref => \2;
+eval { for (roref) { $_ = <FH> } };
like($@, 'Modification of a read-only value attempted', '[perl #19566]');
# [perl #21628]
use strict qw(refs subs);
-plan(230);
+plan(235);
# Test glob operations.
is ref( bless {}, "nul\0clean" ), "nul\0clean", "ref() is nul-clean";
+# Test constants and references thereto.
+for (3) {
+ eval { $_ = 4 };
+ like $@, qr/^Modification of a read-only/,
+ 'assignment to value aliased to literal number';
+ require Config;
+ eval { ${\$_} = 4 };
+ like $@, qr/^Modification of a read-only/,
+ 'refgen does not allow assignment to value aliased to literal number';
+}
+for ("4eounthouonth") {
+ eval { $_ = 4 };
+ like $@, qr/^Modification of a read-only/,
+ 'assignment to value aliased to literal string';
+ require Config;
+ eval { ${\$_} = 4 };
+ like $@, qr/^Modification of a read-only/,
+ 'refgen does not allow assignment to value aliased to literal string';
+}
+{
+ my $aref = \123;
+ is \$$aref, $aref,
+ '[perl #109746] referential identity of \literal under threads+mad'
+}
+
# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
$test = curr_test();
curr_test($test + 3);
}
require './test.pl';
-plan(tests => 42);
+plan(tests => 43);
# compile time
# [perl #35885]
is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' );
+
+# [perl #78194] x aliasing op return values
+sub {
+ is(\$_[0], \$_[1],
+ '[perl #78194] \$_[0] == \$_[1] when @_ aliases elems repeated by x')
+}
+ ->(("${\''}")x2);
require 'test.pl';
}
use warnings;
-plan( tests => 180 );
+plan( tests => 181 );
# these shouldn't hang
{
$#a = -1;
() = [sort { $a = 10; $b = 10; 0 } $#a, $#a];
is $#a, 10, 'sort block modifying $a and $b';
+
+() = sort {
+ is \$a, \$a, '[perl #78194] op return values passed to sort'; 0
+} "${\''}", "${\''}";
require './test.pl';
}
-plan( tests => 16 );
+plan( tests => 27 );
sub empty_sub {}
undef *bar;
print "ok\n";
end
+
+# The outer call sets the scalar returned by ${\""}.${\""} to the current
+# package name.
+# The inner call sets it to "road".
+# Each call records the value twice, the outer call surrounding the inner
+# call. In 5.10-5.18 under ithreads, what gets pushed is
+# qw(main road road road) because the inner call is clobbering the same
+# scalar. If __PACKAGE__ is changed to "main", it works, the last element
+# becoming "main".
+my @scratch;
+sub a {
+ for (${\""}.${\""}) {
+ $_ = $_[0];
+ push @scratch, $_;
+ a("road",1) unless $_[1];
+ push @scratch, $_;
+ }
+}
+a(__PACKAGE__);
+require Config;
+is "@scratch", "main road road main",
+ 'recursive calls do not share shared-hash-key TARGs';
+
+# Another test for the same bug, that does not rely on foreach. It depends
+# on ref returning a shared hash key TARG.
+undef @scratch;
+sub b {
+ my ($pack, $depth) = @_;
+ my $o = bless[], $pack;
+ $pack++;
+ push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
+}
+b('n',0);
+is "@scratch", "o n",
+ 'recursive calls do not share shared-hash-key TARGs (2)';
+
+# [perl #78194] @_ aliasing op return values
+sub { is \$_[0], \$_[0],
+ '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
+ ->("${\''}");
+
+# The return statement should make no difference in this case:
+sub not_constant () { 42 }
+sub not_constantr() { return 42 }
+use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
+my sub not_constantm () { 42 }
+my sub not_constantmr() { return 42 }
+eval { ${\not_constant}++ };
+is $@, "", 'sub (){42} returns a mutable value';
+eval { ${\not_constantr}++ };
+is $@, "", 'sub (){ return 42 } returns a mutable value';
+eval { ${\not_constantm}++ };
+is $@, "", 'my sub (){42} returns a mutable value';
+eval { ${\not_constantmr}++ };
+is $@, "", 'my sub (){ return 42 } returns a mutable value';
+is eval {
+ sub Crunchy () { 1 }
+ sub Munchy { $_[0] = 2 }
+ eval "Crunchy"; # test that freeing this op does not turn off PADTMP
+ Munchy(Crunchy);
+} || $@, 2, 'freeing ops does not make sub(){42} immutable';
+
+# [perl #79908]
+{
+ my $x = 5;
+ *_79908 = sub (){$x};
+ $x = 7;
+ is eval "_79908", 7, 'sub(){$x} does not break closures';
+ isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
+
+ # Test another thing that was broken by $x inlinement
+ my $y;
+ no warnings 'once';
+ local *time = sub():method{$y};
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval "()=time";
+ is $w, undef,
+ '*keyword = sub():method{$y} does not cause ambiguity warnings';
+}
@INC = '../lib';
require './test.pl';
}
-plan tests=>192;
+plan tests=>193;
sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
sub b : lvalue { ${\shift} }
}
ucfr();
+# Test TARG with potential lvalue context, too
+for (sub : lvalue { "$x" }->()) {
+ is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}'
+}
+
# [perl #117947] XSUBs should not be treated as lvalues at run time
eval { &{\&utf8::is_utf8}("") = 3 };
like $@, qr/^Can't modify non-lvalue subroutine call at /,
my $s;
my @a;
my @count = (0) x 4; # pre-allocate
-
- grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ # Using 0..3 with constant endpoints will cause an erroneous test fail-
+ # ure, as the SV in the op tree needs to be copied (to protect it),
+ # but copying happens *during iteration*, causing the number of SVs to
+ # go up. Using a variable (0..$_3) will cause evaluation of the range
+ # operator at run time, not compile time, so the values will already be
+ # on the stack before grep starts.
+ my $_3 = 3;
+
+ grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter");
- grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 0, "void grep block: no new tmps per iter");
- $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 0, "scalar grep expr: no new tmps per iter");
- $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
- @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 0, "list grep expr: no new tmps per iter");
- @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 0, "list grep block: no new tmps per iter");
- map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 0, "void map expr: no new tmps per iter");
- map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 0, "void map block: no new tmps per iter");
- $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 0, "scalar map expr: no new tmps per iter");
- $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
- @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
+ @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
is(@count[3] - @count[0], 3, "list map expr: one new tmp per iter");
- @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
+ @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
is(@count[3] - @count[0], 3, "list map block: one new tmp per iter");
}
undef
no
no
+########
+
+# [perl #78194] Passing op return values to tie constructors
+sub TIEARRAY{
+ print \$_[1] == \$_[1] ? "ok\n" : "not ok\n";
+};
+tie @a, "", "$a$b";
+EXPECT
+ok
}
is($destroyed, 1, 'Timely scalar destruction with lvalue vec');
-eval { for (\1) { vec($_,0,1) = 1 } };
+use constant roref => \1;
+eval { for (roref) { vec($_,0,1) = 1 } };
like($@, qr/^Modification of a read-only value attempted at /,
'err msg when modifying read-only refs');
require './test.pl';
}
-plan tests => 39;
+plan tests => 40;
$^R = undef;
like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' );
$x = "(?{})";
is eval { "a" =~ /a++(?{})+$x/x } || $@, '1', '/a++(?{})+$code_block/'
}
+
+# [perl #78194] $_ in code block aliasing op return values
+"$_" =~ /(?{ is \$_, \$_,
+ '[perl #78194] \$_ == \$_ when $_ aliases "$x"' })/;
EXPECT
foo
########
+# [perl #3066]
sub C () { 1 }
-sub M { $_[0] = 2; }
+sub M { print "$_[0]\n" }
eval "C";
M(C);
EXPECT
-Modification of a read-only value attempted at - line 2.
+1
########
print qw(ab a\b a\\b);
EXPECT
use open qw( :utf8 :std );
use warnings;
-plan( tests => 212 );
+plan( tests => 211 );
# type coersion on assignment
$ᕘ = 'ᕘ';
format =
.
- foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+ foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
# *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
# IO::Handle, which isn't what we want.
my $type = $value;
# [perl #19566]: sv_gets writes directly to its argument via
# TARG. Test that we respect SvREADONLY.
-eval { for (\2) { $_ = <Fʜ> } };
+use constant roref=>\2;
+eval { for (roref) { $_ = <Fʜ> } };
like($@, 'Modification of a read-only value attempted', '[perl #19566]');
# [perl #21628]
d = s + 1;
while (SPACE_OR_TAB(*d))
d++;
- if (*d == ')' && (sv = cv_const_sv(cv))) {
+ if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
s = d + 1;
goto its_constant;
}
UTF8fARG(UTF, l, PL_tokenbuf));
}
/* Check for a constant sub */
- if ((sv = cv_const_sv(cv))) {
+ if ((sv = cv_const_sv_or_av(cv))) {
its_constant:
op_free(rv2cv_op);
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- pl_yylval.opval->op_private = OPpCONST_FOLDED;
- pl_yylval.opval->op_folded = 1;
- pl_yylval.opval->op_flags |= OPf_SPECIAL;
+ if (SvTYPE(sv) == SVt_PVAV)
+ pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
+ pl_yylval.opval);
+ else {
+ pl_yylval.opval->op_private = OPpCONST_FOLDED;
+ pl_yylval.opval->op_folded = 1;
+ pl_yylval.opval->op_flags |= OPf_SPECIAL;
+ }
TOKEN(WORD);
}
https://perl5.git.perl.org / perl5.git / commitdiff