Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / 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 }