This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2d10332fc4f23c37be655d27034f259b9345874b
[perl5.git] / t / op / utf8cache.t
1 #!./perl -w
2 # Test for malfunctions of utf8 cache
3
4 BEGIN {
5     chdir 't' if -d 't';
6     @INC = '../lib';
7     require './test.pl';
8 }
9
10 use strict;
11
12 plan(tests => 7);
13
14 SKIP: {
15 skip_without_dynamic_extension("Devel::Peek");
16
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
39 unlike($_, qr{ $utf8magic $utf8magic }x);
40
41 } # SKIP
42
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 }
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});
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;
111 is pos $u, 2, 'pos on overloaded utf8 toggler (again)'