t/opbasic/concat.t

   1 #!./perl
   2
   3 BEGIN {
   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
  13 my $test = 1;
  14
  15 sub 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
  26 sub 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
  42 print "1..251\n";
  43
  44 ($a, $b, $c) = qw(foo bar);
  45
  46 ok("$a"     eq "foo",    "verifying assign");
  47 ok("$a$b"   eq "foobar", "basic concatenation");
  48 ok("$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
 112 sub 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]
 201 package o { use overload "." => sub { $_[0] }, fallback => 1 }
 202 $o = bless [], "o";
 203 ok(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 }