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

2 files changed, 70 insertions, 5 deletions

diff --git a/op.c b/op.c
index eb4a0ed44b..858bf00f8b 100644
--- 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 b2acd65d75..01e0ba0019 100755
--- 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+(.*))?/;