Commit | Line | Data |
---|---|---|
c45bec60 | 1 | #!./perl -w |
fa421ef9 CS |
2 | # Test for malfunctions of utf8 cache |
3 | ||
4 | BEGIN { | |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
c45bec60 | 7 | require './test.pl'; |
fa421ef9 CS |
8 | } |
9 | ||
c45bec60 NC |
10 | use strict; |
11 | ||
fc061ed8 | 12 | plan(tests => 15); |
fa421ef9 | 13 | |
4785469e FC |
14 | SKIP: { |
15 | skip_without_dynamic_extension("Devel::Peek"); | |
16 | ||
fa421ef9 CS |
17 | my $pid = open CHILD, '-|'; |
18 | die "kablam: $!\n" unless defined $pid; | |
19 | unless ($pid) { | |
20 | open STDERR, ">&STDOUT"; | |
21 | $a = "hello \x{1234}"; | |
22 | for (1..2) { | |
23 | bar(substr($a, $_, 1)); | |
24 | } | |
25 | sub bar { | |
26 | $_[0] = "\x{4321}"; | |
27 | Devel::Peek::Dump($_[0]); | |
28 | } | |
29 | exit; | |
30 | } | |
31 | ||
32 | { local $/; $_ = <CHILD> } | |
33 | ||
34 | my $utf8magic = qr{ ^ \s+ MAGIC \s = .* \n | |
35 | \s+ MG_VIRTUAL \s = .* \n | |
36 | \s+ MG_TYPE \s = \s PERL_MAGIC_utf8 .* \n | |
37 | \s+ MG_LEN \s = .* \n }xm; | |
38 | ||
c45bec60 | 39 | unlike($_, qr{ $utf8magic $utf8magic }x); |
88621eaf | 40 | |
4785469e FC |
41 | } # SKIP |
42 | ||
88621eaf DM |
43 | # With bad caching, this code used to go quadratic and take 10s of minutes. |
44 | # The 'test' in this case is simply that it doesn't hang. | |
45 | ||
46 | { | |
47 | local ${^UTF8CACHE} = 1; # enable cache, disable debugging | |
48 | my $x = "\x{100}" x 1000000; | |
49 | while ($x =~ /./g) { | |
50 | my $p = pos($x); | |
51 | } | |
52 | pass("quadratic pos"); | |
53 | } | |
7d1328bb FC |
54 | |
55 | # Get-magic can reallocate the PV. Check that the cache is reset in | |
56 | # such cases. | |
57 | ||
58 | # Regexp vars | |
59 | "\x{100}" =~ /(.+)/; | |
60 | () = substr $1, 0, 1; | |
61 | "a\x{100}" =~ /(.+)/; | |
62 | is ord substr($1, 1, 1), 0x100, 'get-magic resets utf8cache on match vars'; | |
63 | ||
64 | # Substr lvalues | |
65 | my $x = "a\x{100}"; | |
66 | my $l = \substr $x, 0; | |
67 | () = substr $$l, 1, 1; | |
68 | substr $x, 0, 1, = "\x{100}"; | |
69 | is ord substr($$l, 1, 1), 0x100, 'get-magic resets utf8cache on LVALUEs'; | |
70 | ||
71 | # defelem magic | |
72 | my %h; | |
73 | sub { | |
74 | $_[0] = "a\x{100}"; | |
75 | () = ord substr $_[0], 1, 1; | |
76 | $h{k} = "\x{100}"x2; | |
77 | is ord substr($_[0], 1, 1), 0x100, | |
78 | 'get-magic resets uf8cache on defelems'; | |
79 | }->($h{k}); | |
aec43834 FC |
80 | |
81 | ||
82 | # Overloading can also reallocate the PV. | |
83 | ||
84 | package UTF8Toggle { | |
85 | use overload '""' => 'stringify', fallback => 1; | |
86 | ||
87 | sub new { | |
88 | my $class = shift; | |
89 | my $value = shift; | |
90 | my $state = shift||0; | |
91 | return bless [$value, $state], $class; | |
92 | } | |
93 | ||
94 | sub stringify { | |
95 | my $self = shift; | |
96 | $self->[1] = ! $self->[1]; | |
97 | if ($self->[1]) { | |
98 | utf8::downgrade($self->[0]); | |
99 | } else { | |
100 | utf8::upgrade($self->[0]); | |
101 | } | |
102 | $self->[0]; | |
103 | } | |
104 | } | |
105 | my $u = UTF8Toggle->new(" \x{c2}7 "); | |
106 | ||
107 | pos $u = 2; | |
108 | is pos $u, 2, 'pos on overloaded utf8 toggler'; | |
109 | () = "$u"; # flip flag | |
110 | pos $u = 2; | |
4ddea69a FC |
111 | is pos $u, 2, 'pos on overloaded utf8 toggler (again)'; |
112 | ||
113 | () = ord ${\substr $u, 1}; | |
114 | is ord ${\substr($u, 1)}, 0xc2, | |
115 | 'utf8 cache + overloading does not confuse substr lvalues'; | |
116 | () = "$u"; # flip flag | |
117 | () = ord substr $u, 1; | |
118 | is ord substr($u, 1), 0xc2, | |
119 | 'utf8 cache + overloading does not confuse substr lvalues (again)'; | |
d91e94e1 | 120 | |
fc061ed8 FC |
121 | $u = UTF8Toggle->new(" \x{c2}7 "); |
122 | () = ord ${\substr $u, 2}; | |
123 | { no warnings; ${\substr($u, 2, 1)} = 0; } | |
124 | is $u, " \x{c2}0 ", | |
125 | 'utf8 cache + overloading does not confuse substr lvalue assignment'; | |
126 | $u = UTF8Toggle->new(" \x{c2}7 "); | |
127 | () = "$u"; # flip flag | |
128 | () = ord ${\substr $u, 2}; | |
129 | { no warnings; ${\substr($u, 2, 1)} = 0; } | |
130 | is $u, " \x{c2}0 ", | |
131 | 'utf8 cache + overload does not confuse substr lv assignment (again)'; | |
132 | ||
d91e94e1 FC |
133 | |
134 | # Typeglobs and references should not get a cache | |
135 | use utf8; | |
136 | ||
137 | #substr | |
138 | my $globref = \*αabcdefg_::_; | |
139 | () = substr($$globref, 2, 3); | |
140 | *_abcdefgα:: = \%αabcdefg_::; | |
141 | undef %αabcdefg_::; | |
142 | { no strict; () = *{"_abcdefgα::_"} } | |
143 | is substr($$globref, 2, 3), "abc", 'no utf8 pos cache on globs'; | |
144 | ||
145 | my $ref = bless [], "αabcd_"; | |
146 | () = substr($ref, 1, 3); | |
147 | bless $ref, "_abcdα"; | |
148 | is substr($ref, 1, 3), "abc", 'no utf8 pos cache on references'; | |
149 | ||
150 | #length | |
151 | $globref = \*αabcdefg_::_; | |
152 | () = "$$globref"; # turn utf8 flag on | |
153 | () = length($$globref); | |
154 | *_abcdefgα:: = \%αabcdefg_::; | |
155 | undef %αabcdefg_::; | |
156 | { no strict; () = *{"_abcdefgα::_"} } | |
157 | is length($$globref), length("$$globref"), 'no utf8 length cache on globs'; | |
158 | ||
159 | $ref = bless [], "αabcd_"; | |
160 | () = "$ref"; # turn utf8 flag on | |
161 | () = length $ref; | |
162 | bless $ref, "α"; | |
163 | is length $ref, length "$ref", 'no utf8 length cache on references'; |