t/opbasic/concat.t

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