Commit | Line | Data |
---|---|---|
bdaa056b JH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
8e7b2370 JK |
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 | ||
0dee2995 MS |
13 | my $test = 1; |
14 | sub ok { | |
15 | my($ok, $name) = @_; | |
bdaa056b | 16 | |
0dee2995 | 17 | printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; |
bdaa056b | 18 | |
0dee2995 | 19 | printf "# Failed test at line %d\n", (caller)[2] unless $ok; |
bdaa056b | 20 | |
0dee2995 MS |
21 | $test++; |
22 | return $ok; | |
23 | } | |
bdaa056b | 24 | |
ada289e7 | 25 | print "1..31\n"; |
bdaa056b | 26 | |
0dee2995 MS |
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"); | |
bdaa056b | 32 | |
0dee2995 | 33 | # Okay, so that wasn't very challenging. Let's go Unicode. |
bdaa056b JH |
34 | |
35 | { | |
36 | # bug id 20000819.004 | |
37 | ||
38 | $_ = $dx = "\x{10f2}"; | |
39 | s/($dx)/$dx$1/; | |
40 | { | |
0dee2995 | 41 | ok($_ eq "$dx$dx","bug id 20000819.004, back"); |
bdaa056b JH |
42 | } |
43 | ||
44 | $_ = $dx = "\x{10f2}"; | |
45 | s/($dx)/$1$dx/; | |
46 | { | |
0dee2995 | 47 | ok($_ eq "$dx$dx","bug id 20000819.004, front"); |
bdaa056b JH |
48 | } |
49 | ||
50 | $dx = "\x{10f2}"; | |
51 | $_ = "\x{10f2}\x{10f2}"; | |
52 | s/($dx)($dx)/$1$2/; | |
53 | { | |
0dee2995 | 54 | ok($_ eq "$dx$dx","bug id 20000819.004, front and back"); |
bdaa056b JH |
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}"; | |
0dee2995 MS |
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"); | |
bdaa056b JH |
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 ... | |
0dee2995 MS |
76 | eval {"$2\x{1234}"}; |
77 | ok(!$@, "bug id 20001020.006, left"); | |
bdaa056b JH |
78 | |
79 | # For symmetry with the above. | |
0dee2995 MS |
80 | eval {"\x{1234}$2"}; |
81 | ok(!$@, "bug id 20001020.006, right"); | |
bdaa056b JH |
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 ... | |
0dee2995 MS |
87 | eval{"$pi\x{1234}"}; |
88 | ok(!$@, "bug id 20001020.006, constant left"); | |
bdaa056b JH |
89 | |
90 | # For symmetry with the above. | |
0dee2995 MS |
91 | eval{"\x{1234}$pi"}; |
92 | ok(!$@, "bug id 20001020.006, constant right"); | |
bdaa056b | 93 | } |
db79b45b JH |
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 | } | |
0165acc7 AE |
111 | |
112 | { | |
113 | my $a; ($a .= 5) . 6; | |
c3029c66 | 114 | ok($a == 5, '($a .= 5) . 6 - present since 5.000'); |
0165acc7 | 115 | } |
9133b639 RGS |
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 | } | |
90f5826e TS |
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 | } | |
a9c4fd4e AL |
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 | } | |
09219716 GG |
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 | } | |
ada289e7 FC |
166 | |
167 | # [perl #124160] | |
168 | package o { use overload "." => sub { $_[0] }, fallback => 1 } | |
169 | $o = bless [], "o"; | |
170 | ok(ref(CORE::state $y = "a $o b") eq 'o', | |
171 | 'state $y = "foo $bar baz" does not stringify; only concats'); |