In perl.git, the branch maint-5.22 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/9d3b1ef1ae2327a7ee711525e99057e4b5925f51?hp=30d1eb7e6dba8f38133658cfe254101dd6aef7f4>
- Log ----------------------------------------------------------------- commit 9d3b1ef1ae2327a7ee711525e99057e4b5925f51 Author: Aristotle Pagaltzis <[email protected]> Date: Sat Mar 26 00:55:21 2016 +0100 improve perldiag implicit close text still further (cherry picked from commit 95032a5ba8a8a8ef02ca87ced5e2e47387c05831) M pod/perldiag.pod commit 51f83360b283636210b71501b3eb7834f3c75fe7 Author: Aristotle Pagaltzis <[email protected]> Date: Fri Mar 25 12:02:44 2016 +0100 improve perldiag implicit close text further (cherry picked from commit ab7ca7edf202fe21133adbdca227b5cd8d15dced) M pod/perldiag.pod commit 64f139cb92326fc0718ec4b62b7c171cdfed9f58 Author: David Mitchell <[email protected]> Date: Wed Mar 23 16:11:01 2016 +0000 improve perldiag implicit close text (cherry picked from commit cc4d3128555c2fbf5af7fc75854461cd87502812) M pod/perldiag.pod commit bc9dfde1dc963f4f50ff2786104de2fdd5238d08 Author: David Mitchell <[email protected]> Date: Sun Mar 20 17:12:13 2016 +0000 stop lc() etc accidentally modifying in-place. As an optimisation, [ul]c() and [ul]cfirst() sometimes modify their argument in-place rather than returning a modified copy. This should only be done when there is no possibility that the arg is going to be reused. However, this fails: use List::Util qw{ first }; my %hash = ( ASD => 1, ZXC => 2, QWE => 3, TYU => 4); print first { lc $_ eq 'qwe' } keys %hash; which prints "qwe" rather than "QWE". Bascally everything in perl that sets $_ or $a/$b and calls a code block or function, such as map, grep, for and, sort, either copies any PADTMPs, turns off SvTEMP, and/or bumps the reference count. List::Util doesn't do this, and it is likely that other CPAN modules which do "set $_ and call a block" don't either. This has been failing since 5.20.0: perl has been in-placing if the arg is (SvTEMP && RC==1 && !mg) (due to v5.19.7-112-g5cd5e2d). Make the optimisation critera stricter by always copying SvTEMPs. It still allows the optimisation if the arg is a PADTMP - I don't know whether this is unsafe too. Perhaps we can think of something better after 5.24? (cherry picked from commit 1921e03146ca6022defa6af5267c4dd20c0ca699) M pp.c M t/op/lc.t commit 450d54aeac41b6ae01f6aa6cb386882c543ac000 Author: David Mitchell <[email protected]> Date: Thu Apr 7 14:00:23 2016 +0100 RT #127786: assertion failure with eval in DB pkg. Normally a cloned anon sud has a NULL CvOUTSIDE(), unless that sub can contain code that will do an eval. However, calling eval from within the DB package pretends that the eval was done in the caller's scope. which then trips up on the NULL CvOUTSIDE(). ts) (cherry picked from commit aea0412a260d9d7295c0a5bebb8bb6978dc02ccd) M op.c M t/op/eval.t commit 738b3793b47018174139e9d7eef4591d021dd3cb Author: Dagfinn Ilmari Mannsåker <[email protected]> Date: Mon Dec 21 19:25:32 2015 +0000 Enforce strict 'subs' in multideref optimisation The code that checks constant keys and turns them into HEKs swallowed the OP_CONST before the strictness checker could get to it, thus allowing barewords when they should not be. (cherry picked from commit e1ccd2206d2572b12ff2ad8efe6b1370c580898f) M op.c M t/lib/strict/subs ----------------------------------------------------------------------- Summary of changes: op.c | 15 ++++++++++++++- pod/perldiag.pod | 17 +++++++++++++++-- pp.c | 14 +++----------- t/lib/strict/subs | 10 ++++++++++ t/op/eval.t | 14 +++++++++++++- t/op/lc.t | 26 +++++++++++++++++++++++++- 6 files changed, 80 insertions(+), 16 deletions(-) diff --git a/op.c b/op.c index 68ac57c..e92de57 100644 --- a/op.c +++ b/op.c @@ -2351,6 +2351,13 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) continue; svp = cSVOPx_svp(key_op); + /* make sure it's not a bareword under strict subs */ + if (key_op->op_private & OPpCONST_BARE && + key_op->op_private & OPpCONST_STRICT) + { + no_bareword_allowed((OP*)key_op); + } + /* Make the CONST have a shared SV */ if ( !SvIsCOW_shared_hash(sv = *svp) && SvTYPE(sv) < SVt_PVMG @@ -2622,7 +2629,13 @@ S_mark_padname_lvalue(pTHX_ PADNAME *pn) PadnameLVALUE_on(pn); while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { cv = CvOUTSIDE(cv); - assert(cv); + /* RT #127786: cv can be NULL due to an eval within the DB package + * called from an anon sub - anon subs don't have CvOUTSIDE() set + * unless they contain an eval, but calling eval within DB + * pretends the eval was done in the caller's scope. + */ + if (!cv) + break; assert(CvPADLIST(cv)); pn = PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index c6e8c18..1421928 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -7068,8 +7068,21 @@ space. =item Warning: unable to close filehandle %s properly: %s -(S io) An error occurred when Perl implicitly closed a filehandle. This -usually indicates your file system ran out of disk space. +(S io) There were errors during the implicit close() done on a filehandle +when its reference count reached zero while it was still open, e.g.: + + { + open my $fh, '>', $file or die "open: '$file': $!\n"; + print $fh $data or die "print: $!"; + } # implicit close here + +Because various errors may only be detected by close() (e.g. buffering could +allow the C<print> in this example to return true even when the disk is full), +it is dangerous to ignore its result. So when it happens implicitly, perl will +signal errors by warning. + +B<Prior to version 5.22.0, perl ignored such errors>, so the common idiom shown +above was liable to cause B<silent data loss>. =item Warning: Use of "%s" without parentheses is ambiguous diff --git a/pp.c b/pp.c index c8d4856..3173c5a 100644 --- a/pp.c +++ b/pp.c @@ -3681,10 +3681,7 @@ PP(pp_ucfirst) /* We may be able to get away with changing only the first character, in * place, but not if read-only, etc. Later we may discover more reasons to * not convert in-place. */ - inplace = !SvREADONLY(source) - && ( SvPADTMP(source) - || ( SvTEMP(source) && !SvSMAGICAL(source) - && SvREFCNT(source) == 1)); + inplace = !SvREADONLY(source) && SvPADTMP(source); /* First calculate what the changed first character should be. This affects * whether we can just swap it out, leaving the rest of the string unchanged, @@ -3924,9 +3921,7 @@ PP(pp_uc) SvGETMAGIC(source); - if ((SvPADTMP(source) - || - (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1)) + if ( SvPADTMP(source) && !SvREADONLY(source) && SvPOK(source) && !DO_UTF8(source) && ( @@ -4179,10 +4174,7 @@ PP(pp_lc) SvGETMAGIC(source); - if ( ( SvPADTMP(source) - || ( SvTEMP(source) && !SvSMAGICAL(source) - && SvREFCNT(source) == 1 ) - ) + if ( SvPADTMP(source) && !SvREADONLY(source) && SvPOK(source) && !DO_UTF8(source)) { diff --git a/t/lib/strict/subs b/t/lib/strict/subs index 095adee..bad22c6 100644 --- a/t/lib/strict/subs +++ b/t/lib/strict/subs @@ -458,3 +458,13 @@ use strict 'subs'; EXPECT Bareword "FOO" not allowed while "strict subs" in use at - line 3. Execution of - aborted due to compilation errors. +######## +# [perl #126981] Strict subs vs. multideref +sub CONST () { 'some_key' } +my $h; +my $v1 = $h->{+CONST_TYPO}; +use strict 'subs'; +my $v2 = $h->{+CONST_TYPO}; +EXPECT +Bareword "CONST_TYPO" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. diff --git a/t/op/eval.t b/t/op/eval.t index fcfe675..2906499 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan(tests => 132); +plan(tests => 133); eval 'pass();'; @@ -645,3 +645,15 @@ sub _117941 { package _117941; eval '$a' } delete $::{"_117941::"}; _117941(); pass("eval in freed package does not crash"); + +# RT #127786 +# this used to give an assertion failure + +{ + package DB { + sub f127786 { eval q/\$s/ } + } + my $s; + sub { $s; DB::f127786}->(); + pass("RT #127786"); +} diff --git a/t/op/lc.t b/t/op/lc.t index ffea0ae..9f2bdb0 100644 --- a/t/op/lc.t +++ b/t/op/lc.t @@ -1,6 +1,8 @@ #!./perl # This file is intentionally encoded in latin-1. +# +# Test uc(), lc(), fc(), ucfirst(), lcfirst(), quotemeta() etc BEGIN { chdir 't' if -d 't'; @@ -14,7 +16,7 @@ BEGIN { use feature qw( fc ); -plan tests => 134 + 4 * 256; +plan tests => 139 + 4 * 256; is(lc(undef), "", "lc(undef) is ''"); is(lcfirst(undef), "", "lcfirst(undef) is ''"); @@ -317,6 +319,28 @@ $h{k} = bless[], "\x{130}bcde"; # U+0130 grows with lc() like lc delete $h{k}, qr "^i\x{307}bcde=array\(.*\)", 'lc(TEMP ref) does not produce a corrupt string'; +# List::Util::first() etc sets $_ to an SvTEMP without raising its +# refcount. This was causing lc() etc to unsafely modify in-place. +# see http://nntp.perl.org/group/perl.perl5.porters/228213 + +SKIP: { + skip "no List::Util on miniperl", 5, if is_miniperl; + require List::Util; + my %hl = qw(a 1 b 2 c 3); + my %hu = qw(A 1 B 2 C 3); + my $x; + $x = List::Util::first(sub { uc $_ eq 'A' }, keys %hl); + is($x, "a", "first { uc }"); + $x = List::Util::first(sub { ucfirst $_ eq 'A' }, keys %hl); + is($x, "a", "first { ucfirst }"); + $x = List::Util::first(sub { lc $_ eq 'a' }, keys %hu); + is($x, "A", "first { lc }"); + $x = List::Util::first(sub { lcfirst $_ eq 'a' }, keys %hu); + is($x, "A", "first { lcfirst }"); + $x = List::Util::first(sub { fc $_ eq 'a' }, keys %hu); + is($x, "A", "first { fc }"); +} + my $utf8_locale = find_utf8_ctype_locale(); -- Perl5 Master Repository
