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..19\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 }