change#3612 was buggy and failed to build Tk; applied Ilya's

remedy and related tests via private mail

p4raw-link: @3612 on //depot/perl: b162f9ead0a98db35cdcfc8c889e344c040c8d8e

p4raw-id: //depot/perl@3664

diff --git a/op.c b/op.c
index eb4a0ed..858bf00 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5650,17 +5650,21 @@ Perl_peep(pTHX_ register OP *o)
            if (cSVOPo->op_private & OPpCONST_STRICT)
                no_bareword_allowed(o);
            /* FALL THROUGH */
-       case OP_CONCAT:
-       case OP_JOIN:
        case OP_UC:
        case OP_UCFIRST:
        case OP_LC:
        case OP_LCFIRST:
+           if ( o->op_next && o->op_next->op_type == OP_STRINGIFY
+                && !(o->op_next->op_private & OPpTARGET_MY) )
+               null(o->op_next);
+           o->op_seq = PL_op_seqmax++;
+           break;
+       case OP_CONCAT:
+       case OP_JOIN:
        case OP_QUOTEMETA:
            if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
                if (o->op_next->op_private & OPpTARGET_MY) {
-                   if ((o->op_type == OP_CONST) /* no target */
-                       || (o->op_flags & OPf_STACKED) /* chained concats */
+                   if ((o->op_flags & OPf_STACKED) /* chained concats */
                        || (o->op_type == OP_CONCAT
            /* Concat has problems if target is equal to right arg. */
                            && (((LISTOP*)o)->op_first->op_sibling->op_type

diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t
index b2acd65..01e0ba0 100755 (executable)
--- a/t/op/lex_assign.t
+++ b/t/op/lex_assign.t
@@ -22,11 +22,72 @@ $nn = $n = 2;
 sub subb {"in s"}
 
 @INPUT = <DATA>;
-print "1..", (scalar @INPUT), "\n";
+print "1..", (8 + @INPUT), "\n";
 $ord = 0;
 
 sub wrn {"@_"}
 
+# Check correct optimization of ucfirst etc
+$ord++;
+my $a = "AB";
+my $b = "\u\L$a";
+print "not " unless $b eq 'Ab';
+print "ok $ord\n";
+
+# Check correct destruction of objects:
+my $dc = 0;
+sub A::DESTROY {$dc += 1}
+$a=8;
+my $b;
+{ my $c = 6; $b = bless \$c, "A"}
+
+$ord++;
+print "not " unless $dc == 0;
+print "ok $ord\n";
+
+$b = $a+5;
+
+$ord++;
+print "not " unless $dc == 1;
+print "ok $ord\n";
+
+{                              # Check calling STORE
+  my $sc = 0;
+  sub B::TIESCALAR {bless [11], 'B'}
+  sub B::FETCH { -(shift->[0]) }
+  sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
+
+  my $m;
+  tie $m, 'B';
+  $m = 100;
+
+  $ord++;
+  print "not " unless $sc == 1;
+  print "ok $ord\n";
+
+  my $t = 11;
+  $m = $t + 89;
+  
+  $ord++;
+  print "not " unless $sc == 2;
+  print "ok $ord\n";
+
+  $ord++;
+  print "# $m\nnot " unless $m == -117;
+  print "ok $ord\n";
+
+  $m += $t;
+
+  $ord++;
+  print "not " unless $sc == 3;
+  print "ok $ord\n";
+
+  $ord++;
+  print "# $m\nnot " unless $m == 89;
+  print "ok $ord\n";
+
+}
+
 for (@INPUT) {
   $ord++;
   ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;