Commit | Line | Data |
---|---|---|
bdaa056b JH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
0dee2995 MS |
8 | # This ok() function is specially written to avoid any concatenation. |
9 | my $test = 1; | |
10 | sub 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 MS |
17 | $test++; |
18 | return $ok; | |
19 | } | |
bdaa056b | 20 | |
a9c4fd4e | 21 | print "1..29\n"; |
bdaa056b | 22 | |
0dee2995 MS |
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"); | |
bdaa056b | 28 | |
0dee2995 | 29 | # Okay, so that wasn't very challenging. Let's go Unicode. |
bdaa056b JH |
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 JH |
38 | } |
39 | ||
40 | $_ = $dx = "\x{10f2}"; | |
41 | s/($dx)/$1$dx/; | |
42 | { | |
0dee2995 | 43 | ok($_ eq "$dx$dx","bug id 20000819.004, front"); |
bdaa056b JH |
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 JH |
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 MS |
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 JH |
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 MS |
72 | eval {"$2\x{1234}"}; |
73 | ok(!$@, "bug id 20001020.006, left"); | |
bdaa056b JH |
74 | |
75 | # For symmetry with the above. | |
0dee2995 MS |
76 | eval {"\x{1234}$2"}; |
77 | ok(!$@, "bug id 20001020.006, right"); | |
bdaa056b JH |
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 MS |
83 | eval{"$pi\x{1234}"}; |
84 | ok(!$@, "bug id 20001020.006, constant left"); | |
bdaa056b JH |
85 | |
86 | # For symmetry with the above. | |
0dee2995 MS |
87 | eval{"\x{1234}$pi"}; |
88 | ok(!$@, "bug id 20001020.006, constant right"); | |
bdaa056b | 89 | } |
db79b45b JH |
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 | } | |
0165acc7 AE |
107 | |
108 | { | |
109 | my $a; ($a .= 5) . 6; | |
c3029c66 | 110 | ok($a == 5, '($a .= 5) . 6 - present since 5.000'); |
0165acc7 | 111 | } |
9133b639 RGS |
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 TS |
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 AL |
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 | } |