In perl.git, the branch maint-5.24 has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/07f0edfcb5a97def4aa61ab608716c584c73fa21?hp=a8b4e7c58df43e20b74f9ff64135f39648707f8e>

- Log -----------------------------------------------------------------
commit 07f0edfcb5a97def4aa61ab608716c584c73fa21
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Fri May 20 20:32:48 2016 -0700

    Another op description correction: & -> &.
    
    The string bitwise ops have dots in them, which should be included
    in the op descriptions.
    
    (cherry picked from commit 118a40c4aa59af9330f4c37e86423a8b7c0d301c)

M       opcode.h
M       regen/opcodes

commit 87ef4ed3fc3f44a18c6ea0372a1375a462925285
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Fri May 20 20:24:50 2016 -0700

    Correct ‘bitiwse’ in two op descriptions
    
    Oops!
    
    (cherry picked from commit 5cb51e4d385f1a78e57460db8c624392985b7678)

M       opcode.h
M       regen/opcodes

commit c574bc68fc9779d5c852c42ec5c00965bca3fc24
Author: Karl Williamson <k...@cpan.org>
Date:   Mon May 23 08:04:53 2016 -0600

    PATCH: [perl #128219] typo in perlrecharclass
    
    Thanks for spotting this.  It was a typo.  Alpha matches XPosixAlpha.
    
    (cherry picked from commit 4cb26c52ed90189e6e3564a4654b869fe4c4d3e6)

M       pod/perlrecharclass.pod

commit 915d6a669585d5e94c5af2e1d2f635883eff7c01
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Fri May 20 21:55:40 2016 -0700

    [perl #128204] Fix crash with @a &.= etc.
    
    The new bitwise operators in their assignment forms were not correctly
    catching things like arrays on the lhs at compile time.
    
    At run time, they would either crash or croak with ‘Can’t coerce
    ARRAY...’.
    
    This commit puts in the correct compile-time check, simply by flagging
    these as scalar modifiers.
    
    (cherry picked from commit 76734a3218e712760695898e424c2369ccdd49c6)

M       op.c
M       t/lib/croak/op

commit cf1efead3fa596a455f799448d561f12007787e1
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Tue May 17 18:16:52 2016 -0700

    [perl #128171] Fix assert fail with /@0{0*->@*/*0
    
    If a syntax error such as * (multiply) followed by an arrow causes the
    parser to pop scopes in trying to recover from the error, it might
    exit the quote-parsing scope (for parsing the regexp) and point the
    lexer’s cursor at the code following the regexp, after the lexer has
    noted to itself that it is expected to parse a postfix dereference
    (PL_expect==XPOSTDEREF).
    
    The code for parsing a postfix dereference has an assertion which
    ends up failing in this case, because the *0 following the regexp,
    having sigil that can come after an arrow, goes through the postfix
    deref function, which complains about the 0 it did not expect.
    
    If we simply remove the assertion, the lexer will continue to emit
    tokens, and we just end up dying (somewhat) gracefully because of the
    syntax error, instead of crashing.
    
    I used a ] in the test instead of a final 0, to avoid a compile-
    time warning.  (Number found where operator expected.)
    
    (cherry picked from commit d674449463a15ac3f36086e3a0bb3a9d02729887)

M       t/base/lex.t
M       toke.c

commit 6a042a6f0333fd9955876d96e93f695d05f85f75
Author: Lukas Mai <l....@web.de>
Date:   Wed May 11 22:15:34 2016 +0200

    fix symbol detection with gcc 6 link-time optimization (RT #128131)
    
    (cherry picked from commit adec5bbf0b66ee5ebc2ba80eda2389bb68e23d86)

M       Configure

commit 9cff6a7672e984d7860a283a811161329f259c62
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Tue May 10 14:14:40 2016 -0700

    [perl #128106] Fix reset with non-globs
    
    reset with a string argument was assuming that anything in a
    stash would be a glob.  It crashed on anything else.
    
    (cherry picked from commit fcd130693a9e7a753f63a08691ff619ad91bf8eb)

M       sv.c
M       t/op/reset.t

commit a3660d0cfef825007244ec5e64168bdde98c91f4
Author: Father Chrysostomos <spr...@cpan.org>
Date:   Sun May 15 13:49:33 2016 -0700

    [perl #128086] Test the prev commit
    
    (cherry picked from commit 7f1bd063e5aa5aeb26ed9c39db6864cc0ecd7a73)

M       t/op/stash.t

commit d958abc7575d5668a4386c8dd0c3c36190318b27
Author: Hugo van der Sanden <h...@crypt.org>
Date:   Sun May 15 13:48:58 2016 -0700

    [perl #128086] Fix precedence in hv_ename_delete
    
    A stash’s array of names may have null for the first entry, in which
    case it is not one of the effective names, and the name count will
    be negative.
    
    The ‘count > 0’ is meant to prevent hv_ename_delete from trying to
    read that entry, but a precedence problem introduced in 4643eb699
    stopped it from doing that.
    
    [This commit message was written by the committer.]
    
    (cherry picked from commit 60a26c797bbff039ea7f861903732e7cceae415a)

M       hv.c

commit 6ac20eff9c194c3ec0d4308d0ee6aae6bf7355e3
Author: Aaron Crane <a...@cpan.org>
Date:   Sun May 15 15:11:12 2016 +0100

    [perl #127952] misoptimization for negated constant-ish on lhs of logop
    
    Negations were being incorrectly deleted from the op tree for an OP_AND or
    OP_OR (corresponding to Perl code with any of `&& || and or`, or postfix
    "if" or "unless") whose left-hand side looks like "!BAREWORD" or "!do {
    'const' }" and whose right-hand side is a non-constant-foldable negation.
    
    The symptom in the reported case was an assertion failure in ck_refassign
    for an srefgen op, caused by such an OP_NOT having been nulled. But other
    cases exist that instead yielded incorrect results.
    
    The underlying cause is that two optimisations in S_new_logop() were
    partially interfering with each other. One of those attempts to optimise
    code like "!$x && !$y" to the equivalent of "!($x || $y)", saving a
    negation op; this is valid by De Morgan's laws. If it detects code of
    this form, it nulls out the negations on each side of the "&&", and makes
    a note to wrap the op it generates inside a new OP_NOT.
    
    The other optimisation looks at the left-hand arm, and if it's a constant at
    compile time, avoids the entire logop in favour of directly evaluating the
    lhs or rhs as appropriate, and eliding whichever arm is no longer needed.
    This optimisation is important for code like this:
    
        use constant DEBUG => …;
        print_debug_output() if DEBUG;
    
    because it allows the entire statement to be eliminated when DEBUG is false.
    
    When both conditions were true simultaneously, the De Morgan optimisation
    was applied before the constant-based arm elision. But the arm elision
    involved returning early from S_new_logop(), so the code later in that
    function that wraps the generated op in a new OP_NOT never had a chance to
    run. This meant that "!X && !Y" when X is constant was being compiled as if
    it were in fact "X || Y", which is clearly incorrect.
    
    This is, however, a very rare situation: it requires the lhs to be an OP_NOT
    that dominates an OP_CONST (possibly with some intervening OP_LINESEQ or
    similar). But OP_NOT is constant-foldable, so that doesn't normally happen.
    The two ways for it to happen are:
    
    - The constant is a bareword (since even though barewords are constants,
      they don't currently participate in constant folding)
    
    - The constant is hidden inside one or more layers of do{} (since that
      serves as a barrier to constant folding, but the arm-elision optimisation
      is smart enough to search recursively through the optree for the real
      constant)
    
    The fix is much simpler than the explanation: apply the optimisations in the
    opposite order, so that when arm elision returns early, the negation ops
    haven't yet been nulled.
    
    (cherry picked from commit f15d05806fb7522031b75cb5a8784727ae03b98a)

M       op.c
M       t/op/lop.t
-----------------------------------------------------------------------

Summary of changes:
 Configure               |  4 ++--
 hv.c                    |  3 ++-
 op.c                    | 44 ++++++++++++++++++++++++++------------------
 opcode.h                |  8 ++++----
 pod/perlrecharclass.pod |  2 +-
 regen/opcodes           |  8 ++++----
 sv.c                    |  2 ++
 t/base/lex.t            |  8 +++++++-
 t/lib/croak/op          | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 t/op/lop.t              | 28 +++++++++++++++++++++++++++-
 t/op/reset.t            | 12 +++++++++++-
 t/op/stash.t            |  9 ++++++++-
 toke.c                  |  1 -
 13 files changed, 142 insertions(+), 35 deletions(-)

diff --git a/Configure b/Configure
index 471771009f..576cea0ab3 100755
--- a/Configure
+++ b/Configure
@@ -6812,13 +6812,13 @@ yes)
                if $contains $tlook $tf >/dev/null 2>&1; then
                        tval=true;
                elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then
-                       echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { 
return &$1; } int main() { if(p() && p() != (void *)main) return(0); else 
return(1); }"> try.c;
+                       echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { 
return &$1; } int main(int argc, char **argv) { if(p() && p() != (void 
*)argv[0]) return(0); else return(1); }"> try.c;
                        $cc -o try $optimize $ccflags $ldflags try.c >/dev/null 
2>&1 $libs && tval=true;
                        $test "$mistrustnm" = run -a -x try && { $run 
./try$_exe >/dev/null 2>&1 || tval=false; };
                        $rm_try;
                fi;
        else
-               echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; 
} int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> 
try.c;
+               echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; 
} int main(int argc, char **argv) { if(p() && p() != (void *)argv[0]) 
return(0); else return(1); }"> try.c;
                $cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 
2>&1 && tval=true;
                $rm_try;
        fi;
diff --git a/hv.c b/hv.c
index 7b5ad95878..55234753ed 100644
--- a/hv.c
+++ b/hv.c
@@ -2476,9 +2476,10 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 
len, U32 flags)
                return;
            }
        if (
-           count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
+           count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
                : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, 
len))
+            )
        ) {
            aux->xhv_name_count = -count;
        }
diff --git a/op.c b/op.c
index 4b6b2271cf..301acc6174 100644
--- a/op.c
+++ b/op.c
@@ -3223,6 +3223,12 @@ S_scalar_mod_type(const OP *o, I32 type)
     case OP_BIT_AND:
     case OP_BIT_XOR:
     case OP_BIT_OR:
+    case OP_NBIT_AND:
+    case OP_NBIT_XOR:
+    case OP_NBIT_OR:
+    case OP_SBIT_AND:
+    case OP_SBIT_XOR:
+    case OP_SBIT_OR:
     case OP_CONCAT:
     case OP_SUBST:
     case OP_TRANS:
@@ -6747,24 +6753,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** 
otherp)
        || type == OP_CUSTOM);
 
     scalarboolean(first);
-    /* optimize AND and OR ops that have NOTs as children */
-    if (first->op_type == OP_NOT
-       && (first->op_flags & OPf_KIDS)
-       && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
-           || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
-       ) {
-       if (type == OP_AND || type == OP_OR) {
-           if (type == OP_AND)
-               type = OP_OR;
-           else
-               type = OP_AND;
-           op_null(first);
-           if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
-               op_null(other);
-               prepend_not = 1; /* prepend a NOT op later */
-           }
-       }
-    }
+
     /* search for a constant op that could let us fold the test */
     if ((cstop = search_const(first))) {
        if (cstop->op_private & OPpCONST_STRICT)
@@ -6864,6 +6853,25 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** 
otherp)
     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
        other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
 
+    /* optimize AND and OR ops that have NOTs as children */
+    if (first->op_type == OP_NOT
+        && (first->op_flags & OPf_KIDS)
+        && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+            || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
+        ) {
+        if (type == OP_AND || type == OP_OR) {
+            if (type == OP_AND)
+                type = OP_OR;
+            else
+                type = OP_AND;
+            op_null(first);
+            if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+                op_null(other);
+                prepend_not = 1; /* prepend a NOT op later */
+            }
+        }
+    }
+
     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
     logop->op_flags |= (U8)flags;
     logop->op_private = (U8)(1 | (flags >> 8));
diff --git a/opcode.h b/opcode.h
index 5ec8f58e70..a77f5cc924 100644
--- a/opcode.h
+++ b/opcode.h
@@ -642,12 +642,12 @@ EXTCONST char* const PL_op_desc[] = {
        "bitwise and (&)",
        "bitwise xor (^)",
        "bitwise or (|)",
-       "numeric bitiwse and (&)",
+       "numeric bitwise and (&)",
        "numeric bitwise xor (^)",
        "numeric bitwise or (|)",
-       "string bitiwse and (&)",
-       "string bitwise xor (^)",
-       "string bitwise or (|)",
+       "string bitwise and (&.)",
+       "string bitwise xor (^.)",
+       "string bitwise or (|.)",
        "negation (-)",
        "integer negation (-)",
        "not",
diff --git a/pod/perlrecharclass.pod b/pod/perlrecharclass.pod
index 7f5a4ef273..89f4a7ef3f 100644
--- a/pod/perlrecharclass.pod
+++ b/pod/perlrecharclass.pod
@@ -863,7 +863,7 @@ Same for the two ASCII-only range forms.
 =back
 
 There are various other synonyms that can be used besides the names
-listed in the table.  For example, C<\p{PosixAlpha}> can be written as
+listed in the table.  For example, C<\p{XPosixAlpha}> can be written as
 C<\p{Alpha}>.  All are listed in
 L<perluniprops/Properties accessible through \p{} and \P{}>.
 
diff --git a/regen/opcodes b/regen/opcodes
index 9ea0753ffe..6238426a67 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -165,12 +165,12 @@ scmp              string comparison (cmp) ck_null         
ifst2   S S
 bit_and                bitwise and (&)         ck_bitop        fst2    S S|
 bit_xor                bitwise xor (^)         ck_bitop        fst2    S S|
 bit_or         bitwise or (|)          ck_bitop        fst2    S S|
-nbit_and       numeric bitiwse and (&) ck_bitop        fsT2    S S|
+nbit_and       numeric bitwise and (&) ck_bitop        fsT2    S S|
 nbit_xor       numeric bitwise xor (^) ck_bitop        fsT2    S S|
 nbit_or                numeric bitwise or (|)  ck_bitop        fsT2    S S|
-sbit_and       string bitiwse and (&)  ck_bitop        fst2    S S|
-sbit_xor       string bitwise xor (^)  ck_bitop        fst2    S S|
-sbit_or                string bitwise or (|)   ck_bitop        fst2    S S|
+sbit_and       string bitwise and (&.) ck_bitop        fst2    S S|
+sbit_xor       string bitwise xor (^.) ck_bitop        fst2    S S|
+sbit_or                string bitwise or (|.)  ck_bitop        fst2    S S|
 
 negate         negation (-)            ck_null         Ifst1   S
 i_negate       integer negation (-)    ck_null         ifst1   S
diff --git a/sv.c b/sv.c
index decc47c3dd..ec5b344127 100644
--- a/sv.c
+++ b/sv.c
@@ -9706,6 +9706,8 @@ Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * 
const stash)
                if (!todo[(U8)*HeKEY(entry)])
                    continue;
                gv = MUTABLE_GV(HeVAL(entry));
+               if (!isGV(gv))
+                   continue;
                sv = GvSV(gv);
                if (sv && !SvREADONLY(sv)) {
                    SV_CHECK_THINKFIRST_COW_DROP(sv);
diff --git a/t/base/lex.t b/t/base/lex.t
index 1aa563d756..fe46f14d0a 100644
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..104\n";
+print "1..105\n";
 
 $x = 'x';
 
@@ -522,3 +522,9 @@ eval q|s##[}#e|;
  eval ('qq{@{[0}*sub{]]}}}=sub{0' . "\c[");
  print "ok $test - 125350\n"; $test++;
 }
+
+{
+ # Used to crash [perl #128171]
+ eval ('/@0{0*->@*/*]');
+ print "ok $test - 128171\n"; $test++;
+}
diff --git a/t/lib/croak/op b/t/lib/croak/op
index cd3a6544e3..439878959e 100644
--- a/t/lib/croak/op
+++ b/t/lib/croak/op
@@ -65,6 +65,54 @@ my main $f;
 EXPECT
 No such class field "c" in variable $f of type main at - line 3.
 ########
+# NAME Num-specific &= on @array
+use feature 'bitwise';
+@a &= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise and (&) at - line 2, near 
"1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME Num-specific |= on @array
+use feature 'bitwise';
+@a |= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise or (|) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME Num-specific ^= on @array
+use feature 'bitwise';
+@a ^= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise xor (^) at - line 2, near 
"1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME &.= on @array
+use feature 'bitwise';
+@a &.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise and (&.) at - line 2, near 
"1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME |.= on @array
+use feature 'bitwise';
+@a |.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise or (|.) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME ^.= on @array
+use feature 'bitwise';
+@a ^.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise xor (^.) at - line 2, near 
"1;"
+Execution of - aborted due to compilation errors.
+########
 # NAME Can't declare conditional
 my($a?$b:$c)
 EXPECT
diff --git a/t/op/lop.t b/t/op/lop.t
index bc4eb85f7e..fe1c4326c9 100644
--- a/t/op/lop.t
+++ b/t/op/lop.t
@@ -10,7 +10,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 17;
+plan tests => 23;
 
 for my $i (undef, 0 .. 2, "", "0 but true") {
     my $true = 1;
@@ -56,3 +56,29 @@ is( $i, 10, 'negation precedence with &&' );
 ++$y;
 $i = !$x && !$x && !$x && $y;
 is( $i, 11, 'negation precedence with &&, multiple operands' );
+
+# [perl #127952]. This relates to OP_AND and OP_OR with a negated constant
+# on the lhs (either a negated bareword, or a negation of a do{} containing
+# a constant) and a negated non-foldable expression on the rhs. These cases
+# yielded 42 or "Bare" or "str" before the bug was fixed.
+{
+    $x = 42;
+
+    $i = !Bare || !$x;
+    is( $i, '', 'neg-bareword on lhs of || with non-foldable neg-true on rhs' 
);
+
+    $i = !Bare && !$x;
+    is( $i, '', 'neg-bareword on lhs of && with non-foldable neg-true on rhs' 
);
+
+    $i = do { !$x if !Bare };
+    is( $i, '', 'neg-bareword on rhs of modifier-if with non-foldable neg-true 
on lhs' );
+
+    $i = do { !$x unless !Bare };
+    is( $i, '', 'neg-bareword on rhs of modifier-unless with non-foldable 
neg-true on lhs' );
+
+    $i = !do { "str" } || !$x;
+    is( $i, '', 'neg-do-const on lhs of || with non-foldable neg-true on rhs' 
);
+
+    $i = !do { "str" } && !$x;
+    is( $i, '', 'neg-do-const on lhs of && with non-foldable neg-true on rhs' 
);
+}
diff --git a/t/op/reset.t b/t/op/reset.t
index db82309e70..227c84a3d9 100644
--- a/t/op/reset.t
+++ b/t/op/reset.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 use strict;
 
-plan tests => 39;
+plan tests => 40;
 
 package aiieee;
 
@@ -140,6 +140,16 @@ for our $z (*_) {
     is $z, "*main::_", 'And the glob still has the right value';
 }
 
+package _128106 {
+    # Crash on non-globs in the stash.
+    sub u;    # stub without proto
+    sub v($); # proto stub
+    sub w{};  # as of 5.22, $::{w} == \&w
+    $::{x} = undef;
+    reset 'u-x';
+    ::ok (1, "no crash on non-globs in the stash");
+}
+
 # This used to crash under threaded builds, because pmops were remembering
 # their stashes by name, rather than by pointer.
 fresh_perl_is( # it crashes more reliably with a smaller script
diff --git a/t/op/stash.t b/t/op/stash.t
index 151b7296f1..b8e0f34966 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 51 );
+plan( tests => 52 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -334,3 +334,10 @@ is runperl(
    ),
    "ok\n",
    '[perl #123847] no crash from *foo::=*bar::=*glob_with_hash';
+
+is runperl(
+    prog => '%h; *::::::=*h; delete $::{q|::|}; print qq|ok\n|',
+    stderr => 1,
+   ),
+   "ok\n",
+   '[perl #128086] no crash from assigning hash to *:::::: & deleting it';
diff --git a/toke.c b/toke.c
index aa814b991d..35d587dff0 100644
--- a/toke.c
+++ b/toke.c
@@ -1939,7 +1939,6 @@ static int
 S_postderef(pTHX_ int const funny, char const next)
 {
     assert(funny == DOLSHARP || strchr("$@%&*", funny));
-    assert(strchr("*[{", next));
     if (next == '*') {
        PL_expect = XOPERATOR;
        if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {

--
Perl5 Master Repository

Reply via email to