In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3885a45a68b1e213942bbd5c25da091b4785423e?hp=38e1c50bf9e085dc64a8fca6db7c28200ddf95b0>
- Log ----------------------------------------------------------------- commit 3885a45a68b1e213942bbd5c25da091b4785423e Author: Father Chrysostomos <[email protected]> Date: Sat Sep 20 06:55:39 2014 -0700 Fix read-only flag checks in lvalue sub exit See the previous commit for the explanation. This fixes this discrepancy: $ ./miniperl -Ilib -e '+sub:lvalue{my $x = 3; Internals::SvREADONLY $x, 1; $x }->() = 3' Can't return a readonly value from lvalue subroutine at -e line 1. $ ./miniperl -Ilib -e '+sub:lvalue{my $x = *foo; Internals::SvREADONLY $x, 1; $x }->() = 3' Modification of a read-only value attempted at -e line 1. It was not just a flag check that this commit fixed, but also a bogus SvREADONLY(TOPs) where TOPs may not even be the scalar we are dying for, giving âa temporaryâ for some read-only values. That mistake was my own, made in commit d25b0d7b8. M pp_ctl.c M t/op/sub_lval.t commit 57c404c9ca0d045fece7cbd7010d0d084cef5821 Author: Father Chrysostomos <[email protected]> Date: Sat Sep 20 06:41:29 2014 -0700 [perl #115254] Fix flag check on scope exit $ ./perl -Ilib -e '{ my $x = 3; Internals::SvREADONLY $x, 1; () }' $ ./perl -Ilib -e '{ my $x = ${qr//}; Internals::SvREADONLY $x, 1; () }' Modification of a read-only value attempted at -e line 1. The latter causes $x to be marked FAKE. At the time this code was introduced in scope.c, read-only+fake meant cow, so the !fake check was necessary. (That said, it has always behaved incorrectly for glob copies that are also marked fake.) M scope.c M t/lib/universal.t commit f7634e8653b6354fafc3483263dce775dae43ffd Author: Father Chrysostomos <[email protected]> Date: Sat Sep 20 06:33:14 2014 -0700 More Peek.t fix-ups M ext/Devel-Peek/t/Peek.t commit a623f8939cbcaa58a069807591675c0ebcd4135b Author: Father Chrysostomos <[email protected]> Date: Fri Sep 19 23:12:48 2014 -0700 Implement the bipolar read-only system This fixes bugs related to Hash::Util::unlock accidentally unlocking internal scalars (e.g., that returned by undef()) and allowing them to be modified. Internal read-only values are now marked by two flags, the regular read-only flag, and the new âprotectedâ flag. Before this SvREADONLY served two purposes: 1) The code would use it to protect things that must not be modi- fied, ever (except when the core sees fit to do so). 2) Hash::Util and everybody else would use it to make this unmodifia- ble temporarily when requested by the user. Internals::SvREADONLY serves the latter purpose and only flips the read-only flag, so things that need to stay read-only will remain so, because of the âotherâ read-only flag, that CPAN doesnât know about. (If you are a CPAN author, do not read this.) M mg.c M scope.c M sv.c M sv.h M t/lib/universal.t M universal.c commit fd01b4b766a3276a9439cade9b1a047c37876c1b Author: Father Chrysostomos <[email protected]> Date: Fri Sep 19 22:23:22 2014 -0700 Add SVf_PROTECT M dump.c M sv.h commit 3c91ba225d7fe7b359a2594c8eeb19a30f0d61af Author: Father Chrysostomos <[email protected]> Date: Fri Sep 19 22:18:14 2014 -0700 Peek.t fix-up M ext/Devel-Peek/t/Peek.t commit 45eaf8afa63b23319b24204f9dbbd0b79cca9f26 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 19 21:48:27 2014 -0700 Renumber SVf_IsCOW and free up a bit. M dump.c M sv.c M sv.h ----------------------------------------------------------------------- Summary of changes: dump.c | 5 +++-- ext/Devel-Peek/t/Peek.t | 22 +++++++++++++++------- mg.c | 23 +++++++++++------------ pp_ctl.c | 13 ++++--------- scope.c | 4 ++-- sv.c | 13 +++++++------ sv.h | 27 ++++++++++++++++----------- t/lib/universal.t | 11 ++++++++++- t/op/sub_lval.t | 15 ++++++++++++++- universal.c | 4 ++-- 10 files changed, 84 insertions(+), 53 deletions(-) diff --git a/dump.c b/dump.c index c848dcd..8fc433c 100644 --- a/dump.c +++ b/dump.c @@ -1307,9 +1307,8 @@ const struct flag_to_name second_sv_flags_names[] = { {SVf_OOK, "OOK,"}, {SVf_FAKE, "FAKE,"}, {SVf_READONLY, "READONLY,"}, - {SVf_IsCOW, "IsCOW,"}, + {SVf_PROTECT, "PROTECT,"}, {SVf_BREAK, "BREAK,"}, - {SVf_AMAGIC, "OVERLOAD,"}, {SVp_IOK, "pIOK,"}, {SVp_NOK, "pNOK,"}, {SVp_POK, "pPOK,"} @@ -1339,6 +1338,7 @@ const struct flag_to_name hv_flags_names[] = { {SVphv_SHAREKEYS, "SHAREKEYS,"}, {SVphv_LAZYDEL, "LAZYDEL,"}, {SVphv_HASKFLAGS, "HASKFLAGS,"}, + {SVf_AMAGIC, "OVERLOAD,"}, {SVphv_CLONEABLE, "CLONEABLE,"} }; @@ -1442,6 +1442,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo sv_catpv(d, "ROK,"); if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); } + if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); append_flags(d, flags, second_sv_flags_names); if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) && type != SVt_PVAV) { diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 34c654c..c085c77 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -140,7 +140,8 @@ do_test('immediate constant (string)', "bar", 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) + FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021004 + FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021004 PV = $ADDR "bar"\\\0 CUR = 3 LEN = \\d+ @@ -158,7 +159,8 @@ do_test('immediate constant (integer)', 456, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) + FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021004 + FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021004 IV = 456'); do_test('assignment of immediate constant (integer)', @@ -208,14 +210,17 @@ do_test('integer constant', 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) + FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021004 + FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021004 IV = 43981'); do_test('undef', undef, 'SV = NULL\\(0x0\\) at $ADDR REFCNT = \d+ - FLAGS = \\(READONLY\\)'); + FLAGS = \\(READONLY\\) # $] < 5.021004 + FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021004 +'); do_test('reference to scalar', \$a, @@ -678,7 +683,8 @@ do_test('blessed reference', RV = $ADDR SV = NULL\\(0x0\\) at $ADDR REFCNT = \d+ - FLAGS = \\(READONLY\\) + FLAGS = \\(READONLY\\) # $] < 5.021004 + FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021004 PV = $ADDR "" CUR = 0 LEN = 0 @@ -708,7 +714,8 @@ do_test('constant subroutine', XSUBANY = $ADDR \\(CONST SV\\) SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) + FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021004 + FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021004 PV = $ADDR "Perl rules"\\\0 CUR = 10 LEN = \\d+ @@ -874,7 +881,8 @@ do_test('ENAMEs on a stash with no NAME', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 3 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017 - FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 + FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021004 + FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021004 IV = 1 # $] < 5.009 NV = $FLOAT # $] < 5.009 AUX_FLAGS = 0 # $] > 5.019008 diff --git a/mg.c b/mg.c index e18ec01..5566372 100644 --- a/mg.c +++ b/mg.c @@ -84,8 +84,7 @@ void setegid(uid_t id); struct magic_state { SV* mgs_sv; I32 mgs_ss_ix; - U32 mgs_magical; - bool mgs_readonly; + U32 mgs_flags; bool mgs_bumped; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -115,8 +114,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; - mgs->mgs_magical = SvMAGICAL(sv); - mgs->mgs_readonly = SvREADONLY(sv) != 0; + mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ mgs->mgs_bumped = bumped; @@ -201,13 +199,15 @@ Perl_mg_get(pTHX_ SV *sv) /* guard against magic having been deleted - eg FETCH calling * untie */ if (!SvMAGIC(sv)) { - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); break; } /* recalculate flags if this entry was deleted. */ if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; + (SSPTR(mgs_ix, MGS *))->mgs_flags &= + ~(SVs_GMG|SVs_SMG|SVs_RMG); } else if (vtbl == &PL_vtbl_utf8) { /* get-magic can reallocate the PV */ @@ -231,7 +231,8 @@ Perl_mg_get(pTHX_ SV *sv) have_new = 1; cur = mg; mg = newmg; - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); } } @@ -267,7 +268,7 @@ Perl_mg_set(pTHX_ SV *sv) nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; + (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); } if (PL_localizing == 2 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) @@ -3254,10 +3255,8 @@ S_restore_magic(pTHX_ const void *p) if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif - if (mgs->mgs_readonly) - SvREADONLY_on(sv); - if (mgs->mgs_magical) - SvFLAGS(sv) |= mgs->mgs_magical; + if (mgs->mgs_flags) + SvFLAGS(sv) |= mgs->mgs_flags; else mg_magical(sv); } diff --git a/pp_ctl.c b/pp_ctl.c index 7f60cce..e716fc7 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2266,10 +2266,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, const char *what = NULL; if (MARK < SP) { assert(MARK+1 == SP); - if ((SvPADTMP(TOPs) || - (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) - == SVf_READONLY - ) && + if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) && !SvSMAGICAL(TOPs)) { what = SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" @@ -2337,11 +2334,9 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); else while (++MARK <= SP) { if (*MARK != &PL_sv_undef - && (SvPADTMP(*MARK) - || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE)) - == SVf_READONLY - ) + && (SvPADTMP(*MARK) || SvREADONLY(*MARK)) ) { + const bool ro = cBOOL( SvREADONLY(*MARK) ); SV *sv; /* Might be flattened array after $#array = */ PUTBACK; @@ -2353,7 +2348,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, /* diag_listed_as: Can't return %s from lvalue subroutine */ Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine", - SvREADONLY(TOPs) ? "readonly value" : "temporary"); + ro ? "readonly value" : "temporary"); } else *++newsp = diff --git a/scope.c b/scope.c index a9c73a4..5eb9ddb 100644 --- a/scope.c +++ b/scope.c @@ -986,7 +986,7 @@ Perl_leave_scope(pTHX_ I32 base) /* these flags are the union of all the relevant flags * in the individual conditions within */ if (UNLIKELY(SvFLAGS(sv) & ( - SVf_READONLY /* for SvREADONLY_off() */ + SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/ | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */ | SVf_OOK | SVf_THINKFIRST))) @@ -996,7 +996,7 @@ Perl_leave_scope(pTHX_ I32 base) * readonlyness so that it can go out of scope * quietly */ - if (SvREADONLY(sv) && !SvFAKE(sv)) + if (SvREADONLY(sv)) SvREADONLY_off(sv); if (SvOOK(sv)) { /* OOK or HvAUX */ diff --git a/sv.c b/sv.c index 566c0e6..53b4f8b 100644 --- a/sv.c +++ b/sv.c @@ -4499,7 +4499,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) /* slated for free anyway (and not COW)? */ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP /* or a swipable TARG */ - || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW)) + || ((sflags & + (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW)) == SVs_PADTMP /* whose buffer is worth stealing */ && CHECK_COWBUF_THRESHOLD(cur,len) @@ -5155,7 +5156,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) if (SvREADONLY(sv)) Perl_croak_no_modify(); - else if (SvIsCOW(sv)) + else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV)) S_sv_uncow(aTHX_ sv, flags); if (SvROK(sv)) sv_unref_flags(sv, flags); @@ -10071,7 +10072,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) if (!SvROK(sv)) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); - if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) { if (SvREADONLY(tmpRef)) Perl_croak_no_modify(); if (SvOBJECT(tmpRef)) { @@ -14875,18 +14876,18 @@ void Perl_init_constants(pTHX) { SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; - SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; + SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL; SvANY(&PL_sv_undef) = NULL; SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; - SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY + SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY|SVf_PROTECT |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK; SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; - SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY + SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY|SVf_PROTECT |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK; diff --git a/sv.h b/sv.h index f3d2e4e..f198d99 100644 --- a/sv.h +++ b/sv.h @@ -362,8 +362,7 @@ perform the upgrade if necessary. See C<svtype>. GvIMPORTED_CV_on() if it needs to be expanded to a real GV */ #define SVpad_NAMELIST SVp_SCREAM /* AV is a padnamelist */ -#define SVf_IsCOW 0x00010000 /* copy on write (shared hash key if - SvLEN == 0) */ +#define SVf_PROTECT 0x00010000 /* very read-only */ #define SVs_PADTMP 0x00020000 /* in use as tmp; only if ! SVs_PADMY */ #define SVs_PADSTALE 0x00020000 /* lexical has gone out of scope; only valid for SVs_PADMY */ @@ -396,17 +395,18 @@ perform the upgrade if necessary. See C<svtype>. -#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG|SVf_IsCOW) +#define SVf_THINKFIRST (SVf_READONLY|SVf_PROTECT|SVf_ROK|SVf_FAKE \ + |SVs_RMG|SVf_IsCOW) #define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \ SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP) #define PRIVSHIFT 4 /* (SVp_?OK >> PRIVSHIFT) == SVf_?OK */ +/* Note that SVf_AMAGIC is now only set on stashes. */ #define SVf_AMAGIC 0x10000000 /* has magical overloaded methods */ - -/* note that SVf_AMAGIC is now only set on stashes, so this bit is free - * for non-HV SVs */ +#define SVf_IsCOW 0x10000000 /* copy on write (shared hash key if + SvLEN == 0) */ /* Ensure this value does not clash with the GV_ADD* flags in gv.h, or the CV_CKPROTO_* flags in op.c, or the padadd_* flags in pad.h: */ @@ -1071,9 +1071,14 @@ sv_force_normal does nothing. #define SvOBJECT_on(sv) (SvFLAGS(sv) |= SVs_OBJECT) #define SvOBJECT_off(sv) (SvFLAGS(sv) &= ~SVs_OBJECT) -#define SvREADONLY(sv) (SvFLAGS(sv) & SVf_READONLY) -#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY) -#define SvREADONLY_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY) +#define SvREADONLY(sv) (SvFLAGS(sv) & (SVf_READONLY|SVf_PROTECT)) +#ifdef PERL_CORE +# define SvREADONLY_on(sv) (SvFLAGS(sv) |= (SVf_READONLY|SVf_PROTECT)) +# define SvREADONLY_off(sv) (SvFLAGS(sv) &=~(SVf_READONLY|SVf_PROTECT)) +#else +# define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY) +# define SvREADONLY_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY) +#endif #define SvSCREAM(sv) ((SvFLAGS(sv) & (SVp_SCREAM|SVp_POK)) == (SVp_SCREAM|SVp_POK)) #define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVp_SCREAM) @@ -1901,7 +1906,7 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>. on-write. */ # define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \ SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \ - SVf_OOK|SVf_BREAK|SVf_READONLY) + SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT) #else # define SvRELEASE_IVX(sv) 0 /* This little game brought to you by the need to shut this warning up: @@ -1919,7 +1924,7 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect # define CowREFCNT(sv) (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1)) # define SV_COW_REFCNT_MAX ((1 << sizeof(U8)*8) - 1) # define CAN_COW_MASK (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \ - SVf_OOK|SVf_BREAK|SVf_READONLY) + SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT) # endif #endif /* PERL_OLD_COPY_ON_WRITE */ diff --git a/t/lib/universal.t b/t/lib/universal.t index 19f8f28..d3510c4 100644 --- a/t/lib/universal.t +++ b/t/lib/universal.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 13 ); + plan( tests => 16 ); } for my $arg ('', 'q[]', qw( 1 undef )) { @@ -60,3 +60,12 @@ Internals::SvREADONLY($h{b},0); $h{b} =~ y/ia/ao/; is __PACKAGE__, 'main', 'turning off a cowâs readonliness did not affect sharers of the same PV'; + +&Internals::SvREADONLY(\!0, 0); +eval { ${\!0} = 7 }; +like $@, qr "^Modification of a read-only value", + 'protected values still croak on assignment after SvREADONLY(..., 0)'; +is ${\3} == 3, "1", 'attempt to modify failed'; + +eval { { my $x = ${qr//}; Internals::SvREADONLY $x, 1; () } }; +is $@, "", 'read-only lexical regexps on scope exit [perl #115254]'; diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 4bd96ee..9b0ad06 100644 --- a/t/op/sub_lval.t +++ b/t/op/sub_lval.t @@ -3,7 +3,7 @@ BEGIN { @INC = '../lib'; require './test.pl'; } -plan tests=>205; +plan tests=>207; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -387,6 +387,19 @@ EOE like($_, qr/Can\'t return a readonly value from lvalue subroutine/); +eval <<'EOF'; + sub lv2tmpr : lvalue { my $x = *foo; Internals::SvREADONLY $x, 1; $x } + lv2tmpr = (2,3); +EOF + +like($@, qr/Can\'t return a readonly value from lvalue subroutine at/); + +eval <<'EOG'; + (lv2tmpr) = (2,3); +EOG + +like($@, qr/Can\'t return a readonly value from lvalue subroutine/); + sub lva : lvalue {@a} $_ = undef; diff --git a/universal.c b/universal.c index 906f74c..94169a6 100644 --- a/universal.c +++ b/universal.c @@ -565,12 +565,12 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) sv_force_normal(sv); #endif - SvREADONLY_on(sv); + SvFLAGS(sv) |= SVf_READONLY; XSRETURN_YES; } else { /* I hope you really know what you are doing. */ - SvREADONLY_off(sv); + SvFLAGS(sv) &=~ SVf_READONLY; XSRETURN_NO; } } -- Perl5 Master Repository
