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 use Config ();
  12
  13 plan(tests => 16);
  14
  15 SKIP: {
  16 skip_without_dynamic_extension("Devel::Peek", 2);
  17
  18 my $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     }
  29 EOS
  30
  31 $out =~ s/^ALLOCATED at .*\n//m
  32     if $Config::Config{ccflags} =~ /-DDEBUG_LEAKING_SCALARS/;
  33 like($out, qr/\ASV =/, "check we got dump output"); # [perl #121337]
  34
  35 my $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
  40 unlike($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}" =~ /(.+)/;
  64 is ord substr($1, 1, 1), 0x100, 'get-magic resets utf8cache on match vars';
  65
  66 # Substr lvalues
  67 my $x = "a\x{100}";
  68 my $l = \substr $x, 0;
  69 () = substr $$l, 1, 1;
  70 substr $x, 0, 1, = "\x{100}";
  71 is ord substr($$l, 1, 1), 0x100, 'get-magic resets utf8cache on LVALUEs';
  72
  73 # defelem magic
  74 my %h;
  75 sub {
  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
  86 package 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 }
 107 my $u = UTF8Toggle->new(" \x{c2}7 ");
 108
 109 pos $u = 2;
 110 is pos $u, 2, 'pos on overloaded utf8 toggler';
 111 () = "$u"; # flip flag
 112 pos $u = 2;
 113 is pos $u, 2, 'pos on overloaded utf8 toggler (again)';
 114
 115 () = ord ${\substr $u, 1};
 116 is ord ${\substr($u, 1)}, 0xc2,
 117     'utf8 cache + overloading does not confuse substr lvalues';
 118 () = "$u"; # flip flag
 119 () = ord substr $u, 1;
 120 is 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; }
 126 is $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; }
 132 is $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
 137 use utf8;
 138
 139 #substr
 140 my $globref = \*αabcdefg_::_;
 141 () = substr($$globref, 2, 3);
 142 *_abcdefgα:: = \%αabcdefg_::;
 143 undef %αabcdefg_::;
 144 { no strict; () = *{"_abcdefgα::_"} }
 145 is substr($$globref, 2, 3), "abc", 'no utf8 pos cache on globs';
 146
 147 my $ref = bless [], "αabcd_";
 148 () = substr($ref, 1, 3);
 149 bless $ref, "_abcdα";
 150 is 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_::;
 157 undef %αabcdefg_::;
 158 { no strict; () = *{"_abcdefgα::_"} }
 159 is length($$globref), length("$$globref"), 'no utf8 length cache on globs';
 160
 161 $ref = bless [], "αabcd_";
 162 () = "$ref"; # turn utf8 flag on
 163 () = length $ref;
 164 bless $ref, "α";
 165 is length $ref, length "$ref", 'no utf8 length cache on references';