X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fconcat.t;h=865a498f221bfeaa24d162255c7919b540f3435c;hb=b36bdecab13f885c556206f71bfc47083b33107e;hp=76074e0f28f1a8ecba43e7c5c1f9004a3ecfd444;hpb=bdaa056b11e48cf62d10e60a3fb881684257f1fc;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/concat.t b/t/op/concat.t
index 76074e0..865a498 100644
--- a/t/op/concat.t
+++ b/t/op/concat.t
@@ -5,22 +5,28 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..11\n";
+# This ok() function is specially written to avoid any concatenation.
+my $test = 1;
+sub ok {
+    my($ok, $name) = @_;
 
-($a, $b, $c) = qw(foo bar);
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
+
+    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
 
-print "not " unless "$a" eq "foo";
-print "ok 1\n";
+    $test++;
+    return $ok;
+}
 
-print "not " unless "$a$b" eq "foobar";
-print "ok 2\n";
+print "1..20\n";
 
-print "not " unless "$c$a$c" eq "foo";
-print "ok 3\n";
+($a, $b, $c) = qw(foo bar);
 
-# Okay, so that wasn't very challenging.  Let's go Unicode.
+ok("$a"     eq "foo",    "verifying assign");
+ok("$a$b"   eq "foobar", "basic concatenation");
+ok("$c$a$c" eq "foo",    "concatenate undef, fore and aft");
 
-my $test = 4;
+# Okay, so that wasn't very challenging.  Let's go Unicode.
 
 {
     # bug id 20000819.004 
@@ -28,29 +34,20 @@ my $test = 4;
     $_ = $dx = "\x{10f2}";
     s/($dx)/$dx$1/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, back");
     }
 
     $_ = $dx = "\x{10f2}";
     s/($dx)/$1$dx/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front");
     }
 
     $dx = "\x{10f2}";
     $_  = "\x{10f2}\x{10f2}";
     s/($dx)($dx)/$1$2/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front and back");
     }
 }
 
@@ -60,9 +57,9 @@ my $test = 4;
 
     my $a;
     $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
-    $test++;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef left");
+    $a .= undef;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef right");
 }
 
 {
@@ -72,29 +69,51 @@ my $test = 4;
 
     # Without the fix this 5.7.0 would croak:
     # Modification of a read-only value attempted at ...
-    "$2\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval {"$2\x{1234}"};
+    ok(!$@, "bug id 20001020.006, left");
 
     # For symmetry with the above.
-    "\x{1234}$2";
-
-    print "ok $test\n";
-    $test++;
+    eval {"\x{1234}$2"};
+    ok(!$@, "bug id 20001020.006, right");
 
     *pi = \undef;
     # This bug existed earlier than the $2 bug, but is fixed with the same
     # patch. Without the fix this 5.7.0 would also croak:
     # Modification of a read-only value attempted at ...
-    "$pi\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval{"$pi\x{1234}"};
+    ok(!$@, "bug id 20001020.006, constant left");
 
     # For symmetry with the above.
-    "\x{1234}$pi";
+    eval{"\x{1234}$pi"};
+    ok(!$@, "bug id 20001020.006, constant right");
+}
 
-    print "ok $test\n";
-    $test++;
+sub beq { use bytes; $_[0] eq $_[1]; }
+
+{
+    # concat should not upgrade its arguments.
+    my($l, $r, $c);
+
+    ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}");
+    ok(beq($l.$r, $c), "concat utf8 and byte");
+    ok(beq($l, "\x{101}"), "right not changed after concat u+b");
+    ok(beq($r, "\x{fe}"), "left not changed after concat u+b");
+
+    ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}");
+    ok(beq($l.$r, $c), "concat byte and utf8");
+    ok(beq($l, "\x{fe}"), "right not changed after concat b+u");
+    ok(beq($r, "\x{101}"), "left not changed after concat b+u");
+}
+
+{
+    my $a; ($a .= 5) . 6;
+    ok($a == 5, '($a .= 5) . 6 - present since 5.000');
+}
+
+{
+    # [perl #24508] optree construction bug
+    sub strfoo { "x" }
+    my ($x, $y);
+    $y = ($x = '' . strfoo()) . "y";
+    ok( "$x,$y" eq "x,xy", 'figures out correct target' );
 }