1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8# ok()/is() functions from other sources (e.g., t/test.pl) may use 9# concatenation, but that is what is being tested in this file. Hence, we 10# place this file in the directory where do not use t/test.pl, and we 11# write functions specially written to avoid any concatenation. 12 13my $test = 1; 14 15sub ok { 16 my($ok, $name) = @_; 17 18 printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; 19 20 printf "# Failed test at line %d\n", (caller)[2] unless $ok; 21 22 $test++; 23 return $ok; 24} 25 26sub is { 27 my($got, $expected, $name) = @_; 28 29 my $ok = $got eq $expected; 30 31 printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; 32 33 if (!$ok) { 34 printf "# Failed test at line %d\n", (caller)[2]; 35 printf "# got: %s\n#expected: %s\n", $got, $expected; 36 } 37 38 $test++; 39 return $ok; 40} 41 42print "1..254\n"; 43 44($a, $b, $c) = qw(foo bar); 45 46ok("$a" eq "foo", "verifying assign"); 47ok("$a$b" eq "foobar", "basic concatenation"); 48ok("$c$a$c" eq "foo", "concatenate undef, fore and aft"); 49 50# Okay, so that wasn't very challenging. Let's go Unicode. 51 52{ 53 # bug id 20000819.004 (#3761) 54 55 $_ = $dx = "\x{10f2}"; 56 s/($dx)/$dx$1/; 57 { 58 ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), back"); 59 } 60 61 $_ = $dx = "\x{10f2}"; 62 s/($dx)/$1$dx/; 63 { 64 ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), front"); 65 } 66 67 $dx = "\x{10f2}"; 68 $_ = "\x{10f2}\x{10f2}"; 69 s/($dx)($dx)/$1$2/; 70 { 71 ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), front and back"); 72 } 73} 74 75{ 76 # bug id 20000901.092 (#4184) 77 # test that undef left and right of utf8 results in a valid string 78 79 my $a; 80 $a .= "\x{1ff}"; 81 ok($a eq "\x{1ff}", "bug id 20000901.092 (#4184), undef left"); 82 $a .= undef; 83 ok($a eq "\x{1ff}", "bug id 20000901.092 (#4184), undef right"); 84} 85 86{ 87 # ID 20001020.006 (#4484) 88 89 "x" =~ /(.)/; # unset $2 90 91 # Without the fix this 5.7.0 would croak: 92 # Modification of a read-only value attempted at ... 93 eval {"$2\x{1234}"}; 94 ok(!$@, "bug id 20001020.006 (#4484), left"); 95 96 # For symmetry with the above. 97 eval {"\x{1234}$2"}; 98 ok(!$@, "bug id 20001020.006 (#4484), right"); 99 100 *pi = \undef; 101 # This bug existed earlier than the $2 bug, but is fixed with the same 102 # patch. Without the fix this 5.7.0 would also croak: 103 # Modification of a read-only value attempted at ... 104 eval{"$pi\x{1234}"}; 105 ok(!$@, "bug id 20001020.006 (#4484), constant left"); 106 107 # For symmetry with the above. 108 eval{"\x{1234}$pi"}; 109 ok(!$@, "bug id 20001020.006 (#4484), constant right"); 110} 111 112sub beq { use bytes; $_[0] eq $_[1]; } 113 114{ 115 # concat should not upgrade its arguments. 116 my($l, $r, $c); 117 118 ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}"); 119 ok(beq($l.$r, $c), "concat utf8 and byte"); 120 ok(beq($l, "\x{101}"), "right not changed after concat u+b"); 121 ok(beq($r, "\x{fe}"), "left not changed after concat u+b"); 122 123 ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}"); 124 ok(beq($l.$r, $c), "concat byte and utf8"); 125 ok(beq($l, "\x{fe}"), "right not changed after concat b+u"); 126 ok(beq($r, "\x{101}"), "left not changed after concat b+u"); 127} 128 129{ 130 my $a; ($a .= 5) . 6; 131 ok($a == 5, '($a .= 5) . 6 - present since 5.000'); 132} 133 134{ 135 # [perl #24508] optree construction bug 136 sub strfoo { "x" } 137 my ($x, $y); 138 $y = ($x = '' . strfoo()) . "y"; 139 ok( "$x,$y" eq "x,xy", 'figures out correct target' ); 140} 141 142{ 143 # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation 144 145 my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X 146 my $u = "\x{100}"; 147 my $b = pack 'a*', "\x{100}"; 148 my $pu = "\xB6\x{100}"; 149 my $up = "\x{100}\xB6"; 150 my $x1 = $p; 151 my $y1 = $u; 152 my ($x2, $x3, $x4, $y2); 153 154 use bytes; 155 ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes"); 156 ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes"); 157 ok(!beq($p.$u, $pu), "perl #26905, left ne unicode"); 158 ok(!beq($u.$p, $up), "perl #26905, right ne unicode"); 159 160 $x1 .= $u; 161 $x2 = $p . $u; 162 $y1 .= $p; 163 $y2 = $u . $p; 164 165 $x3 = $p; $x3 .= $u . $u; 166 $x4 = $p . $u . $u; 167 168 no bytes; 169 ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes"); 170 ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes"); 171 ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars"); 172 ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars"); 173 ok(($x3 eq $x4), "perl #26905, twin, .= vs = . in chars"); 174} 175 176{ 177 # Concatenation needs to preserve UTF8ness of left oper. 178 my $x = eval"qr/\x{fff}/"; 179 ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" ); 180} 181 182{ 183 my $x; 184 $x = "a" . "b"; 185 $x .= "-append-"; 186 ok($x eq "ab-append-", "Appending to something initialized using constant folding"); 187} 188 189# non-POK consts 190 191{ 192 my $a = "a"; 193 my $b; 194 $b = $a . $a . 1; 195 ok($b eq "aa1", "aa1"); 196 $b = 2 . $a . $a; 197 ok($b eq "2aa", "2aa"); 198} 199 200# [perl #124160] 201package o { use overload "." => sub { $_[0] }, fallback => 1 } 202$o = bless [], "o"; 203ok(ref(CORE::state $y = "a $o b") eq 'o', 204 'state $y = "foo $bar baz" does not stringify; only concats'); 205 206 207# multiconcat: utf8 dest with non-utf8 args should grow dest sufficiently. 208# This is mainly for valgrind or ASAN to detect problems with. 209 210{ 211 my $s = "\x{100}"; 212 my $t = "\x80" x 1024; 213 $s .= "-$t-"; 214 ok length($s) == 1027, "utf8 dest with non-utf8 args"; 215} 216 217# target on RHS 218 219{ 220 my $a = "abc"; 221 $a .= $a; 222 ok($a eq 'abcabc', 'append self'); 223 224 $a = "abc"; 225 $a = $a . $a; 226 ok($a eq 'abcabc', 'double self'); 227 228 $a = "abc"; 229 $a .= $a . $a; 230 ok($a eq 'abcabcabc', 'append double self'); 231 232 $a = "abc"; 233 $a = "$a-$a"; 234 ok($a eq 'abc-abc', 'double self with const'); 235 236 $a = "abc"; 237 $a .= "$a-$a"; 238 ok($a eq 'abcabc-abc', 'append double self with const'); 239 240 $a = "abc"; 241 $a .= $a . $a . $a; 242 ok($a eq 'abcabcabcabc', 'append triple self'); 243 244 $a = "abc"; 245 $a = "$a-$a=$a"; 246 ok($a eq 'abc-abc=abc', 'triple self with const'); 247 248 $a = "abc"; 249 $a .= "$a-$a=$a"; 250 ok($a eq 'abcabc-abc=abc', 'append triple self with const'); 251} 252 253# test the sorts of optree which may (or may not) get optimised into 254# a single MULTICONCAT op. It's based on a loop in t/perf/opcount.t, 255# but here the loop is unwound as we would need to use concat to 256# generate the expected results to compare with the actual results, 257# which would rather defeat the object. 258 259{ 260 my ($a1, $a2, $a3) = qw(1 2 3); 261 our $pkg; 262 my $lex; 263 264 is("-", '-', '"-"'); 265 is("-", '-', '"-"'); 266 is("-", '-', '"-"'); 267 is("-", '-', '"-"'); 268 is($a1, '1', '$a1'); 269 is("-".$a1, '-1', '"-".$a1'); 270 is($a1."-", '1-', '$a1."-"'); 271 is("-".$a1."-", '-1-', '"-".$a1."-"'); 272 is("$a1", '1', '"$a1"'); 273 is("-$a1", '-1', '"-$a1"'); 274 is("$a1-", '1-', '"$a1-"'); 275 is("-$a1-", '-1-', '"-$a1-"'); 276 is($a1.$a2, '12', '$a1.$a2'); 277 is($a1."-".$a2, '1-2', '$a1."-".$a2'); 278 is("-".$a1."-".$a2, '-1-2', '"-".$a1."-".$a2'); 279 is($a1."-".$a2."-", '1-2-', '$a1."-".$a2."-"'); 280 is("-".$a1."-".$a2."-", '-1-2-', '"-".$a1."-".$a2."-"'); 281 is("$a1$a2", '12', '"$a1$a2"'); 282 is("$a1-$a2", '1-2', '"$a1-$a2"'); 283 is("-$a1-$a2", '-1-2', '"-$a1-$a2"'); 284 is("$a1-$a2-", '1-2-', '"$a1-$a2-"'); 285 is("-$a1-$a2-", '-1-2-', '"-$a1-$a2-"'); 286 is($a1.$a2.$a3, '123', '$a1.$a2.$a3'); 287 is($a1."-".$a2."-".$a3, '1-2-3', '$a1."-".$a2."-".$a3'); 288 is("-".$a1."-".$a2."-".$a3, '-1-2-3', '"-".$a1."-".$a2."-".$a3'); 289 is($a1."-".$a2."-".$a3."-", '1-2-3-', '$a1."-".$a2."-".$a3."-"'); 290 is("-".$a1."-".$a2."-".$a3."-", '-1-2-3-', '"-".$a1."-".$a2."-".$a3."-"'); 291 is("$a1$a2$a3", '123', '"$a1$a2$a3"'); 292 is("$a1-$a2-$a3", '1-2-3', '"$a1-$a2-$a3"'); 293 is("-$a1-$a2-$a3", '-1-2-3', '"-$a1-$a2-$a3"'); 294 is("$a1-$a2-$a3-", '1-2-3-', '"$a1-$a2-$a3-"'); 295 is("-$a1-$a2-$a3-", '-1-2-3-', '"-$a1-$a2-$a3-"'); 296 $pkg = "-"; 297 is($pkg, '-', '$pkg = "-"'); 298 $pkg = "-"; 299 is($pkg, '-', '$pkg = "-"'); 300 $pkg = "-"; 301 is($pkg, '-', '$pkg = "-"'); 302 $pkg = "-"; 303 is($pkg, '-', '$pkg = "-"'); 304 $pkg = $a1; 305 is($pkg, '1', '$pkg = $a1'); 306 $pkg = "-".$a1; 307 is($pkg, '-1', '$pkg = "-".$a1'); 308 $pkg = $a1."-"; 309 is($pkg, '1-', '$pkg = $a1."-"'); 310 $pkg = "-".$a1."-"; 311 is($pkg, '-1-', '$pkg = "-".$a1."-"'); 312 $pkg = "$a1"; 313 is($pkg, '1', '$pkg = "$a1"'); 314 $pkg = "-$a1"; 315 is($pkg, '-1', '$pkg = "-$a1"'); 316 $pkg = "$a1-"; 317 is($pkg, '1-', '$pkg = "$a1-"'); 318 $pkg = "-$a1-"; 319 is($pkg, '-1-', '$pkg = "-$a1-"'); 320 $pkg = $a1.$a2; 321 is($pkg, '12', '$pkg = $a1.$a2'); 322 $pkg = $a1."-".$a2; 323 is($pkg, '1-2', '$pkg = $a1."-".$a2'); 324 $pkg = "-".$a1."-".$a2; 325 is($pkg, '-1-2', '$pkg = "-".$a1."-".$a2'); 326 $pkg = $a1."-".$a2."-"; 327 is($pkg, '1-2-', '$pkg = $a1."-".$a2."-"'); 328 $pkg = "-".$a1."-".$a2."-"; 329 is($pkg, '-1-2-', '$pkg = "-".$a1."-".$a2."-"'); 330 $pkg = "$a1$a2"; 331 is($pkg, '12', '$pkg = "$a1$a2"'); 332 $pkg = "$a1-$a2"; 333 is($pkg, '1-2', '$pkg = "$a1-$a2"'); 334 $pkg = "-$a1-$a2"; 335 is($pkg, '-1-2', '$pkg = "-$a1-$a2"'); 336 $pkg = "$a1-$a2-"; 337 is($pkg, '1-2-', '$pkg = "$a1-$a2-"'); 338 $pkg = "-$a1-$a2-"; 339 is($pkg, '-1-2-', '$pkg = "-$a1-$a2-"'); 340 $pkg = $a1.$a2.$a3; 341 is($pkg, '123', '$pkg = $a1.$a2.$a3'); 342 $pkg = $a1."-".$a2."-".$a3; 343 is($pkg, '1-2-3', '$pkg = $a1."-".$a2."-".$a3'); 344 $pkg = "-".$a1."-".$a2."-".$a3; 345 is($pkg, '-1-2-3', '$pkg = "-".$a1."-".$a2."-".$a3'); 346 $pkg = $a1."-".$a2."-".$a3."-"; 347 is($pkg, '1-2-3-', '$pkg = $a1."-".$a2."-".$a3."-"'); 348 $pkg = "-".$a1."-".$a2."-".$a3."-"; 349 is($pkg, '-1-2-3-', '$pkg = "-".$a1."-".$a2."-".$a3."-"'); 350 $pkg = "$a1$a2$a3"; 351 is($pkg, '123', '$pkg = "$a1$a2$a3"'); 352 $pkg = "$a1-$a2-$a3"; 353 is($pkg, '1-2-3', '$pkg = "$a1-$a2-$a3"'); 354 $pkg = "-$a1-$a2-$a3"; 355 is($pkg, '-1-2-3', '$pkg = "-$a1-$a2-$a3"'); 356 $pkg = "$a1-$a2-$a3-"; 357 is($pkg, '1-2-3-', '$pkg = "$a1-$a2-$a3-"'); 358 $pkg = "-$a1-$a2-$a3-"; 359 is($pkg, '-1-2-3-', '$pkg = "-$a1-$a2-$a3-"'); 360 $pkg = 'P'; 361 $pkg .= "-"; 362 is($pkg, 'P-', '$pkg .= "-"'); 363 $pkg = 'P'; 364 $pkg .= "-"; 365 is($pkg, 'P-', '$pkg .= "-"'); 366 $pkg = 'P'; 367 $pkg .= "-"; 368 is($pkg, 'P-', '$pkg .= "-"'); 369 $pkg = 'P'; 370 $pkg .= "-"; 371 is($pkg, 'P-', '$pkg .= "-"'); 372 $pkg = 'P'; 373 $pkg .= $a1; 374 is($pkg, 'P1', '$pkg .= $a1'); 375 $pkg = 'P'; 376 $pkg .= "-".$a1; 377 is($pkg, 'P-1', '$pkg .= "-".$a1'); 378 $pkg = 'P'; 379 $pkg .= $a1."-"; 380 is($pkg, 'P1-', '$pkg .= $a1."-"'); 381 $pkg = 'P'; 382 $pkg .= "-".$a1."-"; 383 is($pkg, 'P-1-', '$pkg .= "-".$a1."-"'); 384 $pkg = 'P'; 385 $pkg .= "$a1"; 386 is($pkg, 'P1', '$pkg .= "$a1"'); 387 $pkg = 'P'; 388 $pkg .= "-$a1"; 389 is($pkg, 'P-1', '$pkg .= "-$a1"'); 390 $pkg = 'P'; 391 $pkg .= "$a1-"; 392 is($pkg, 'P1-', '$pkg .= "$a1-"'); 393 $pkg = 'P'; 394 $pkg .= "-$a1-"; 395 is($pkg, 'P-1-', '$pkg .= "-$a1-"'); 396 $pkg = 'P'; 397 $pkg .= $a1.$a2; 398 is($pkg, 'P12', '$pkg .= $a1.$a2'); 399 $pkg = 'P'; 400 $pkg .= $a1."-".$a2; 401 is($pkg, 'P1-2', '$pkg .= $a1."-".$a2'); 402 $pkg = 'P'; 403 $pkg .= "-".$a1."-".$a2; 404 is($pkg, 'P-1-2', '$pkg .= "-".$a1."-".$a2'); 405 $pkg = 'P'; 406 $pkg .= $a1."-".$a2."-"; 407 is($pkg, 'P1-2-', '$pkg .= $a1."-".$a2."-"'); 408 $pkg = 'P'; 409 $pkg .= "-".$a1."-".$a2."-"; 410 is($pkg, 'P-1-2-', '$pkg .= "-".$a1."-".$a2."-"'); 411 $pkg = 'P'; 412 $pkg .= "$a1$a2"; 413 is($pkg, 'P12', '$pkg .= "$a1$a2"'); 414 $pkg = 'P'; 415 $pkg .= "$a1-$a2"; 416 is($pkg, 'P1-2', '$pkg .= "$a1-$a2"'); 417 $pkg = 'P'; 418 $pkg .= "-$a1-$a2"; 419 is($pkg, 'P-1-2', '$pkg .= "-$a1-$a2"'); 420 $pkg = 'P'; 421 $pkg .= "$a1-$a2-"; 422 is($pkg, 'P1-2-', '$pkg .= "$a1-$a2-"'); 423 $pkg = 'P'; 424 $pkg .= "-$a1-$a2-"; 425 is($pkg, 'P-1-2-', '$pkg .= "-$a1-$a2-"'); 426 $pkg = 'P'; 427 $pkg .= $a1.$a2.$a3; 428 is($pkg, 'P123', '$pkg .= $a1.$a2.$a3'); 429 $pkg = 'P'; 430 $pkg .= $a1."-".$a2."-".$a3; 431 is($pkg, 'P1-2-3', '$pkg .= $a1."-".$a2."-".$a3'); 432 $pkg = 'P'; 433 $pkg .= "-".$a1."-".$a2."-".$a3; 434 is($pkg, 'P-1-2-3', '$pkg .= "-".$a1."-".$a2."-".$a3'); 435 $pkg = 'P'; 436 $pkg .= $a1."-".$a2."-".$a3."-"; 437 is($pkg, 'P1-2-3-', '$pkg .= $a1."-".$a2."-".$a3."-"'); 438 $pkg = 'P'; 439 $pkg .= "-".$a1."-".$a2."-".$a3."-"; 440 is($pkg, 'P-1-2-3-', '$pkg .= "-".$a1."-".$a2."-".$a3."-"'); 441 $pkg = 'P'; 442 $pkg .= "$a1$a2$a3"; 443 is($pkg, 'P123', '$pkg .= "$a1$a2$a3"'); 444 $pkg = 'P'; 445 $pkg .= "$a1-$a2-$a3"; 446 is($pkg, 'P1-2-3', '$pkg .= "$a1-$a2-$a3"'); 447 $pkg = 'P'; 448 $pkg .= "-$a1-$a2-$a3"; 449 is($pkg, 'P-1-2-3', '$pkg .= "-$a1-$a2-$a3"'); 450 $pkg = 'P'; 451 $pkg .= "$a1-$a2-$a3-"; 452 is($pkg, 'P1-2-3-', '$pkg .= "$a1-$a2-$a3-"'); 453 $pkg = 'P'; 454 $pkg .= "-$a1-$a2-$a3-"; 455 is($pkg, 'P-1-2-3-', '$pkg .= "-$a1-$a2-$a3-"'); 456 $lex = "-"; 457 is($lex, '-', '$lex = "-"'); 458 $lex = "-"; 459 is($lex, '-', '$lex = "-"'); 460 $lex = "-"; 461 is($lex, '-', '$lex = "-"'); 462 $lex = "-"; 463 is($lex, '-', '$lex = "-"'); 464 $lex = $a1; 465 is($lex, '1', '$lex = $a1'); 466 $lex = "-".$a1; 467 is($lex, '-1', '$lex = "-".$a1'); 468 $lex = $a1."-"; 469 is($lex, '1-', '$lex = $a1."-"'); 470 $lex = "-".$a1."-"; 471 is($lex, '-1-', '$lex = "-".$a1."-"'); 472 $lex = "$a1"; 473 is($lex, '1', '$lex = "$a1"'); 474 $lex = "-$a1"; 475 is($lex, '-1', '$lex = "-$a1"'); 476 $lex = "$a1-"; 477 is($lex, '1-', '$lex = "$a1-"'); 478 $lex = "-$a1-"; 479 is($lex, '-1-', '$lex = "-$a1-"'); 480 $lex = $a1.$a2; 481 is($lex, '12', '$lex = $a1.$a2'); 482 $lex = $a1."-".$a2; 483 is($lex, '1-2', '$lex = $a1."-".$a2'); 484 $lex = "-".$a1."-".$a2; 485 is($lex, '-1-2', '$lex = "-".$a1."-".$a2'); 486 $lex = $a1."-".$a2."-"; 487 is($lex, '1-2-', '$lex = $a1."-".$a2."-"'); 488 $lex = "-".$a1."-".$a2."-"; 489 is($lex, '-1-2-', '$lex = "-".$a1."-".$a2."-"'); 490 $lex = "$a1$a2"; 491 is($lex, '12', '$lex = "$a1$a2"'); 492 $lex = "$a1-$a2"; 493 is($lex, '1-2', '$lex = "$a1-$a2"'); 494 $lex = "-$a1-$a2"; 495 is($lex, '-1-2', '$lex = "-$a1-$a2"'); 496 $lex = "$a1-$a2-"; 497 is($lex, '1-2-', '$lex = "$a1-$a2-"'); 498 $lex = "-$a1-$a2-"; 499 is($lex, '-1-2-', '$lex = "-$a1-$a2-"'); 500 $lex = $a1.$a2.$a3; 501 is($lex, '123', '$lex = $a1.$a2.$a3'); 502 $lex = $a1."-".$a2."-".$a3; 503 is($lex, '1-2-3', '$lex = $a1."-".$a2."-".$a3'); 504 $lex = "-".$a1."-".$a2."-".$a3; 505 is($lex, '-1-2-3', '$lex = "-".$a1."-".$a2."-".$a3'); 506 $lex = $a1."-".$a2."-".$a3."-"; 507 is($lex, '1-2-3-', '$lex = $a1."-".$a2."-".$a3."-"'); 508 $lex = "-".$a1."-".$a2."-".$a3."-"; 509 is($lex, '-1-2-3-', '$lex = "-".$a1."-".$a2."-".$a3."-"'); 510 $lex = "$a1$a2$a3"; 511 is($lex, '123', '$lex = "$a1$a2$a3"'); 512 $lex = "$a1-$a2-$a3"; 513 is($lex, '1-2-3', '$lex = "$a1-$a2-$a3"'); 514 $lex = "-$a1-$a2-$a3"; 515 is($lex, '-1-2-3', '$lex = "-$a1-$a2-$a3"'); 516 $lex = "$a1-$a2-$a3-"; 517 is($lex, '1-2-3-', '$lex = "$a1-$a2-$a3-"'); 518 $lex = "-$a1-$a2-$a3-"; 519 is($lex, '-1-2-3-', '$lex = "-$a1-$a2-$a3-"'); 520 $lex = 'L'; 521 $lex .= "-"; 522 is($lex, 'L-', '$lex .= "-"'); 523 $lex = 'L'; 524 $lex .= "-"; 525 is($lex, 'L-', '$lex .= "-"'); 526 $lex = 'L'; 527 $lex .= "-"; 528 is($lex, 'L-', '$lex .= "-"'); 529 $lex = 'L'; 530 $lex .= "-"; 531 is($lex, 'L-', '$lex .= "-"'); 532 $lex = 'L'; 533 $lex .= $a1; 534 is($lex, 'L1', '$lex .= $a1'); 535 $lex = 'L'; 536 $lex .= "-".$a1; 537 is($lex, 'L-1', '$lex .= "-".$a1'); 538 $lex = 'L'; 539 $lex .= $a1."-"; 540 is($lex, 'L1-', '$lex .= $a1."-"'); 541 $lex = 'L'; 542 $lex .= "-".$a1."-"; 543 is($lex, 'L-1-', '$lex .= "-".$a1."-"'); 544 $lex = 'L'; 545 $lex .= "$a1"; 546 is($lex, 'L1', '$lex .= "$a1"'); 547 $lex = 'L'; 548 $lex .= "-$a1"; 549 is($lex, 'L-1', '$lex .= "-$a1"'); 550 $lex = 'L'; 551 $lex .= "$a1-"; 552 is($lex, 'L1-', '$lex .= "$a1-"'); 553 $lex = 'L'; 554 $lex .= "-$a1-"; 555 is($lex, 'L-1-', '$lex .= "-$a1-"'); 556 $lex = 'L'; 557 $lex .= $a1.$a2; 558 is($lex, 'L12', '$lex .= $a1.$a2'); 559 $lex = 'L'; 560 $lex .= $a1."-".$a2; 561 is($lex, 'L1-2', '$lex .= $a1."-".$a2'); 562 $lex = 'L'; 563 $lex .= "-".$a1."-".$a2; 564 is($lex, 'L-1-2', '$lex .= "-".$a1."-".$a2'); 565 $lex = 'L'; 566 $lex .= $a1."-".$a2."-"; 567 is($lex, 'L1-2-', '$lex .= $a1."-".$a2."-"'); 568 $lex = 'L'; 569 $lex .= "-".$a1."-".$a2."-"; 570 is($lex, 'L-1-2-', '$lex .= "-".$a1."-".$a2."-"'); 571 $lex = 'L'; 572 $lex .= "$a1$a2"; 573 is($lex, 'L12', '$lex .= "$a1$a2"'); 574 $lex = 'L'; 575 $lex .= "$a1-$a2"; 576 is($lex, 'L1-2', '$lex .= "$a1-$a2"'); 577 $lex = 'L'; 578 $lex .= "-$a1-$a2"; 579 is($lex, 'L-1-2', '$lex .= "-$a1-$a2"'); 580 $lex = 'L'; 581 $lex .= "$a1-$a2-"; 582 is($lex, 'L1-2-', '$lex .= "$a1-$a2-"'); 583 $lex = 'L'; 584 $lex .= "-$a1-$a2-"; 585 is($lex, 'L-1-2-', '$lex .= "-$a1-$a2-"'); 586 $lex = 'L'; 587 $lex .= $a1.$a2.$a3; 588 is($lex, 'L123', '$lex .= $a1.$a2.$a3'); 589 $lex = 'L'; 590 $lex .= $a1."-".$a2."-".$a3; 591 is($lex, 'L1-2-3', '$lex .= $a1."-".$a2."-".$a3'); 592 $lex = 'L'; 593 $lex .= "-".$a1."-".$a2."-".$a3; 594 is($lex, 'L-1-2-3', '$lex .= "-".$a1."-".$a2."-".$a3'); 595 $lex = 'L'; 596 $lex .= $a1."-".$a2."-".$a3."-"; 597 is($lex, 'L1-2-3-', '$lex .= $a1."-".$a2."-".$a3."-"'); 598 $lex = 'L'; 599 $lex .= "-".$a1."-".$a2."-".$a3."-"; 600 is($lex, 'L-1-2-3-', '$lex .= "-".$a1."-".$a2."-".$a3."-"'); 601 $lex = 'L'; 602 $lex .= "$a1$a2$a3"; 603 is($lex, 'L123', '$lex .= "$a1$a2$a3"'); 604 $lex = 'L'; 605 $lex .= "$a1-$a2-$a3"; 606 is($lex, 'L1-2-3', '$lex .= "$a1-$a2-$a3"'); 607 $lex = 'L'; 608 $lex .= "-$a1-$a2-$a3"; 609 is($lex, 'L-1-2-3', '$lex .= "-$a1-$a2-$a3"'); 610 $lex = 'L'; 611 $lex .= "$a1-$a2-$a3-"; 612 is($lex, 'L1-2-3-', '$lex .= "$a1-$a2-$a3-"'); 613 $lex = 'L'; 614 $lex .= "-$a1-$a2-$a3-"; 615 is($lex, 'L-1-2-3-', '$lex .= "-$a1-$a2-$a3-"'); 616 { 617 my $l = "-"; 618 is($l, '-', 'my $l = "-"'); 619 } 620 { 621 my $l = "-"; 622 is($l, '-', 'my $l = "-"'); 623 } 624 { 625 my $l = "-"; 626 is($l, '-', 'my $l = "-"'); 627 } 628 { 629 my $l = "-"; 630 is($l, '-', 'my $l = "-"'); 631 } 632 { 633 my $l = $a1; 634 is($l, '1', 'my $l = $a1'); 635 } 636 { 637 my $l = "-".$a1; 638 is($l, '-1', 'my $l = "-".$a1'); 639 } 640 { 641 my $l = $a1."-"; 642 is($l, '1-', 'my $l = $a1."-"'); 643 } 644 { 645 my $l = "-".$a1."-"; 646 is($l, '-1-', 'my $l = "-".$a1."-"'); 647 } 648 { 649 my $l = "$a1"; 650 is($l, '1', 'my $l = "$a1"'); 651 } 652 { 653 my $l = "-$a1"; 654 is($l, '-1', 'my $l = "-$a1"'); 655 } 656 { 657 my $l = "$a1-"; 658 is($l, '1-', 'my $l = "$a1-"'); 659 } 660 { 661 my $l = "-$a1-"; 662 is($l, '-1-', 'my $l = "-$a1-"'); 663 } 664 { 665 my $l = $a1.$a2; 666 is($l, '12', 'my $l = $a1.$a2'); 667 } 668 { 669 my $l = $a1."-".$a2; 670 is($l, '1-2', 'my $l = $a1."-".$a2'); 671 } 672 { 673 my $l = "-".$a1."-".$a2; 674 is($l, '-1-2', 'my $l = "-".$a1."-".$a2'); 675 } 676 { 677 my $l = $a1."-".$a2."-"; 678 is($l, '1-2-', 'my $l = $a1."-".$a2."-"'); 679 } 680 { 681 my $l = "-".$a1."-".$a2."-"; 682 is($l, '-1-2-', 'my $l = "-".$a1."-".$a2."-"'); 683 } 684 { 685 my $l = "$a1$a2"; 686 is($l, '12', 'my $l = "$a1$a2"'); 687 } 688 { 689 my $l = "$a1-$a2"; 690 is($l, '1-2', 'my $l = "$a1-$a2"'); 691 } 692 { 693 my $l = "-$a1-$a2"; 694 is($l, '-1-2', 'my $l = "-$a1-$a2"'); 695 } 696 { 697 my $l = "$a1-$a2-"; 698 is($l, '1-2-', 'my $l = "$a1-$a2-"'); 699 } 700 { 701 my $l = "-$a1-$a2-"; 702 is($l, '-1-2-', 'my $l = "-$a1-$a2-"'); 703 } 704 { 705 my $l = $a1.$a2.$a3; 706 is($l, '123', 'my $l = $a1.$a2.$a3'); 707 } 708 { 709 my $l = $a1."-".$a2."-".$a3; 710 is($l, '1-2-3', 'my $l = $a1."-".$a2."-".$a3'); 711 } 712 { 713 my $l = "-".$a1."-".$a2."-".$a3; 714 is($l, '-1-2-3', 'my $l = "-".$a1."-".$a2."-".$a3'); 715 } 716 { 717 my $l = $a1."-".$a2."-".$a3."-"; 718 is($l, '1-2-3-', 'my $l = $a1."-".$a2."-".$a3."-"'); 719 } 720 { 721 my $l = "-".$a1."-".$a2."-".$a3."-"; 722 is($l, '-1-2-3-', 'my $l = "-".$a1."-".$a2."-".$a3."-"'); 723 } 724 { 725 my $l = "$a1$a2$a3"; 726 is($l, '123', 'my $l = "$a1$a2$a3"'); 727 } 728 { 729 my $l = "$a1-$a2-$a3"; 730 is($l, '1-2-3', 'my $l = "$a1-$a2-$a3"'); 731 } 732 { 733 my $l = "-$a1-$a2-$a3"; 734 is($l, '-1-2-3', 'my $l = "-$a1-$a2-$a3"'); 735 } 736 { 737 my $l = "$a1-$a2-$a3-"; 738 is($l, '1-2-3-', 'my $l = "$a1-$a2-$a3-"'); 739 } 740 { 741 my $l = "-$a1-$a2-$a3-"; 742 is($l, '-1-2-3-', 'my $l = "-$a1-$a2-$a3-"'); 743 } 744} 745 746# multiconcat optimises away scalar assign, and is responsible 747# for handling the assign itself. If the LHS is something weird, 748# make sure it's handled ok 749 750{ 751 my $a = 'a'; 752 my $b = 'b'; 753 my $o = 'o'; 754 755 my $re = qr/abc/; 756 $$re = $a . $b; 757 is($$re, "ab", '$$re = $a . $b'); 758 759 #passing a hash elem to a sub creates a PVLV 760 my $s = sub { $_[0] = $a . $b; }; 761 my %h; 762 $s->($h{foo}); 763 is($h{foo}, "ab", "PVLV"); 764 765 # assigning a string to a typeglob creates an alias 766 $Foo = 'myfoo'; 767 *Bar = ("F" . $o . $o); 768 is($Bar, "myfoo", '*Bar = "Foo"'); 769 770 # while that same typeglob also appearing on the RHS returns 771 # a stringified value 772 773 package QPR { 774 ${'*QPR::Bar*QPR::BarBaz'} = 'myfoobarbaz'; 775 *Bar = (*Bar . *Bar . "Baz"); 776 ::is($Bar, "myfoobarbaz", '*Bar = (*Bar . *Bar . "Baz")'); 777 } 778} 779 780# distinguish between '=' and '.=' where the LHS has the OPf_MOD flag 781 782{ 783 my $foo = "foo"; 784 my $a . $foo; # weird but legal 785 is($a, '', 'my $a . $foo'); 786 my $b; $b .= $foo; 787 is($b, 'foo', 'my $b; $b .= $foo'); 788} 789 790# distinguish between nested appends and concats; the former is 791# affected by the change of value of the target on each concat. 792# This is why multiconcat shouldn't be used in that case 793 794{ 795 my $a = "a"; 796 (($a .= $a) .= $a) .= $a; 797 is($a, "aaaaaaaa", '(($a .= $a) .= $a) .= $a;'); 798} 799 800# check everything works ok near the max arg size of a multiconcat 801 802{ 803 my @a = map "<$_>", 0..99; 804 for my $i (60..68) { # check each side of 64 threshold 805 my $c = join '.', map "\$a[$_]", 0..$i; 806 my $got = eval $c or die $@; 807 my $empty = ''; # don't use a const string in case join'' ever 808 # gets optimised into a multiconcat 809 my $expected = join $empty, @a[0..$i]; 810 is($got, $expected, "long concat chain $i"); 811 } 812} 813 814# RT #132646 815# with adjacent consts, the second const is treated as an arg rather than a 816# consts. Make sure this doesn't exceeed the maximum allowed number of 817# args 818{ 819 my $x = 'X'; 820 my $got = 821 'A' . $x . 'B' . 'C' . $x . 'D' 822 . 'A' . $x . 'B' . 'C' . $x . 'D' 823 . 'A' . $x . 'B' . 'C' . $x . 'D' 824 . 'A' . $x . 'B' . 'C' . $x . 'D' 825 . 'A' . $x . 'B' . 'C' . $x . 'D' 826 . 'A' . $x . 'B' . 'C' . $x . 'D' 827 . 'A' . $x . 'B' . 'C' . $x . 'D' 828 . 'A' . $x . 'B' . 'C' . $x . 'D' 829 . 'A' . $x . 'B' . 'C' . $x . 'D' 830 . 'A' . $x . 'B' . 'C' . $x . 'D' 831 . 'A' . $x . 'B' . 'C' . $x . 'D' 832 . 'A' . $x . 'B' . 'C' . $x . 'D' 833 . 'A' . $x . 'B' . 'C' . $x . 'D' 834 . 'A' . $x . 'B' . 'C' . $x . 'D' 835 . 'A' . $x . 'B' . 'C' . $x . 'D' 836 . 'A' . $x . 'B' . 'C' . $x . 'D' 837 . 'A' . $x . 'B' . 'C' . $x . 'D' 838 ; 839 is ($got, 840 "AXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXD", 841 "RT #132646"); 842} 843 844# RT #132595 845# multiconcat shouldn't affect the order of arg evaluation 846package RT132595 { 847 my $a = "a"; 848 my $i = 0; 849 sub TIESCALAR { bless({}, $_[0]) } 850 sub FETCH { ++$i; $a = "b".$i; "c".$i } 851 my $t; 852 tie $t, "RT132595"; 853 my $res = $a.$t.$a.$t; 854 ::is($res, "b1c1b1c2", "RT #132595"); 855} 856 857# RT #133441 858# multiconcat wasn't seeing a mutator as a mutator 859{ 860 my ($a, $b) = qw(a b); 861 ($a = 'A'.$b) .= 'c'; 862 is($a, "Abc", "RT #133441"); 863} 864