Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / concat.t
CommitLineData
bdaa056b 1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
0dee2995 8# This ok() function is specially written to avoid any concatenation.
9my $test = 1;
10sub ok {
11 my($ok, $name) = @_;
bdaa056b 12
0dee2995 13 printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
bdaa056b 14
0dee2995 15 printf "# Failed test at line %d\n", (caller)[2] unless $ok;
bdaa056b 16
0dee2995 17 $test++;
18 return $ok;
19}
bdaa056b 20
a9c4fd4e 21print "1..29\n";
bdaa056b 22
0dee2995 23($a, $b, $c) = qw(foo bar);
24
25ok("$a" eq "foo", "verifying assign");
26ok("$a$b" eq "foobar", "basic concatenation");
27ok("$c$a$c" eq "foo", "concatenate undef, fore and aft");
bdaa056b 28
0dee2995 29# Okay, so that wasn't very challenging. Let's go Unicode.
bdaa056b 30
31{
32 # bug id 20000819.004
33
34 $_ = $dx = "\x{10f2}";
35 s/($dx)/$dx$1/;
36 {
0dee2995 37 ok($_ eq "$dx$dx","bug id 20000819.004, back");
bdaa056b 38 }
39
40 $_ = $dx = "\x{10f2}";
41 s/($dx)/$1$dx/;
42 {
0dee2995 43 ok($_ eq "$dx$dx","bug id 20000819.004, front");
bdaa056b 44 }
45
46 $dx = "\x{10f2}";
47 $_ = "\x{10f2}\x{10f2}";
48 s/($dx)($dx)/$1$2/;
49 {
0dee2995 50 ok($_ eq "$dx$dx","bug id 20000819.004, front and back");
bdaa056b 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}";
0dee2995 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");
bdaa056b 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 ...
0dee2995 72 eval {"$2\x{1234}"};
73 ok(!$@, "bug id 20001020.006, left");
bdaa056b 74
75 # For symmetry with the above.
0dee2995 76 eval {"\x{1234}$2"};
77 ok(!$@, "bug id 20001020.006, right");
bdaa056b 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 ...
0dee2995 83 eval{"$pi\x{1234}"};
84 ok(!$@, "bug id 20001020.006, constant left");
bdaa056b 85
86 # For symmetry with the above.
0dee2995 87 eval{"\x{1234}$pi"};
88 ok(!$@, "bug id 20001020.006, constant right");
bdaa056b 89}
db79b45b 90
91sub 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}
0165acc7 107
108{
109 my $a; ($a .= 5) . 6;
c3029c66 110 ok($a == 5, '($a .= 5) . 6 - present since 5.000');
0165acc7 111}
9133b639 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}
90f5826e 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}
a9c4fd4e 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}