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