t/op/concat.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 # This ok() function is specially written to avoid any concatenation.
   9 my $test = 1;
  10 sub 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
  21 print "1..29\n";
  22
  23 ($a, $b, $c) = qw(foo bar);
  24
  25 ok("$a"     eq "foo",    "verifying assign");
  26 ok("$a$b"   eq "foobar", "basic concatenation");
  27 ok("$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
  91 sub 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
 150 {
 151     # Concatenation needs to preserve UTF8ness of left oper.
 152     my $x = eval"qr/\x{fff}/";
 153     ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" );
 154 }