1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8# This ok() function is specially written to avoid any concatenation. 9my $test = 1; 10sub ok { 11 my($ok, $name) = @_; 12 13 printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; 14 15 printf "# Failed test at line %d\n", (caller)[2] unless $ok; 16 17 $test++; 18 return $ok; 19} 20 21print "1..28\n"; 22 23($a, $b, $c) = qw(foo bar); 24 25ok("$a" eq "foo", "verifying assign"); 26ok("$a$b" eq "foobar", "basic concatenation"); 27ok("$c$a$c" eq "foo", "concatenate undef, fore and aft"); 28 29# Okay, so that wasn't very challenging. Let's go Unicode. 30 31{ 32 # bug id 20000819.004 33 34 $_ = $dx = "\x{10f2}"; 35 s/($dx)/$dx$1/; 36 { 37 ok($_ eq "$dx$dx","bug id 20000819.004, back"); 38 } 39 40 $_ = $dx = "\x{10f2}"; 41 s/($dx)/$1$dx/; 42 { 43 ok($_ eq "$dx$dx","bug id 20000819.004, front"); 44 } 45 46 $dx = "\x{10f2}"; 47 $_ = "\x{10f2}\x{10f2}"; 48 s/($dx)($dx)/$1$2/; 49 { 50 ok($_ eq "$dx$dx","bug id 20000819.004, front and back"); 51 } 52} 53 54{ 55 # bug id 20000901.092 56 # test that undef left and right of utf8 results in a valid string 57 58 my $a; 59 $a .= "\x{1ff}"; 60 ok($a eq "\x{1ff}", "bug id 20000901.092, undef left"); 61 $a .= undef; 62 ok($a eq "\x{1ff}", "bug id 20000901.092, undef right"); 63} 64 65{ 66 # ID 20001020.006 67 68 "x" =~ /(.)/; # unset $2 69 70 # Without the fix this 5.7.0 would croak: 71 # Modification of a read-only value attempted at ... 72 eval {"$2\x{1234}"}; 73 ok(!$@, "bug id 20001020.006, left"); 74 75 # For symmetry with the above. 76 eval {"\x{1234}$2"}; 77 ok(!$@, "bug id 20001020.006, right"); 78 79 *pi = \undef; 80 # This bug existed earlier than the $2 bug, but is fixed with the same 81 # patch. Without the fix this 5.7.0 would also croak: 82 # Modification of a read-only value attempted at ... 83 eval{"$pi\x{1234}"}; 84 ok(!$@, "bug id 20001020.006, constant left"); 85 86 # For symmetry with the above. 87 eval{"\x{1234}$pi"}; 88 ok(!$@, "bug id 20001020.006, constant right"); 89} 90 91sub beq { use bytes; $_[0] eq $_[1]; } 92 93{ 94 # concat should not upgrade its arguments. 95 my($l, $r, $c); 96 97 ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}"); 98 ok(beq($l.$r, $c), "concat utf8 and byte"); 99 ok(beq($l, "\x{101}"), "right not changed after concat u+b"); 100 ok(beq($r, "\x{fe}"), "left not changed after concat u+b"); 101 102 ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}"); 103 ok(beq($l.$r, $c), "concat byte and utf8"); 104 ok(beq($l, "\x{fe}"), "right not changed after concat b+u"); 105 ok(beq($r, "\x{101}"), "left not changed after concat b+u"); 106} 107 108{ 109 my $a; ($a .= 5) . 6; 110 ok($a == 5, '($a .= 5) . 6 - present since 5.000'); 111} 112 113{ 114 # [perl #24508] optree construction bug 115 sub strfoo { "x" } 116 my ($x, $y); 117 $y = ($x = '' . strfoo()) . "y"; 118 ok( "$x,$y" eq "x,xy", 'figures out correct target' ); 119} 120 121{ 122 # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation 123 124 my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X 125 my $u = "\x{100}"; 126 my $b = pack 'a*', "\x{100}"; 127 my $pu = "\xB6\x{100}"; 128 my $up = "\x{100}\xB6"; 129 my $x1 = $p; 130 my $y1 = $u; 131 132 use bytes; 133 ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes"); 134 ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes"); 135 ok(!beq($p.$u, $pu), "perl #26905, left ne unicode"); 136 ok(!beq($u.$p, $up), "perl #26905, right ne unicode"); 137 138 $x1 .= $u; 139 $x2 = $p . $u; 140 $y1 .= $p; 141 $y2 = $u . $p; 142 143 no bytes; 144 ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes"); 145 ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes"); 146 ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars"); 147 ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars"); 148} 149