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