t/re/recompile.t

   1 #!./perl
   2
   3 # Check that we don't recompile runtime patterns when the pattern hasn't
   4 # changed
   5 #
   6 # Works by checking the debugging output of 'use re debug' and, if
   7 # available, -Dr. We use both to check that the different code paths
   8 # with Perl_foo() versus the my_foo() under ext/re/ don't cause any
   9 # changes.
  10
  11 $| = 1;
  12
  13 BEGIN {
  14     chdir 't' if -d 't';
  15     require './test.pl';
  16     set_up_inc( '../lib', '.' );
  17     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
  18 }
  19
  20 use strict;
  21 use warnings;
  22
  23 plan tests => 48;
  24
  25 my $results = runperl(
  26                         switches => [ '-Dr' ],
  27                         prog => '1',
  28                         stderr   => 1,
  29                     );
  30 my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/;
  31
  32 my $tmpfile = tempfile();
  33
  34
  35 # Check that a pattern triggers a regex compilation exactly N times,
  36 # using either -Dr or 'use re debug'
  37 # This is partially based on _fresh_perl() in test.pl
  38
  39 sub _comp_n {
  40     my ($use_Dr, $n, $prog, $desc) = @_;
  41     open my $tf, ">$tmpfile" or die "Cannot open $tmpfile: $!";
  42
  43     my $switches = [];
  44     if ($use_Dr) {
  45         push @$switches, '-Dr';
  46     }
  47     else {
  48         $prog = qq{use re qw(debug);\n$prog};
  49     }
  50
  51     print $tf $prog;
  52     close $tf or die "Cannot close $tmpfile: $!";
  53     my $results = runperl(
  54                         switches => $switches,
  55                         progfile => $tmpfile,
  56                         stderr   => 1,
  57                     );
  58
  59     my $status = $?;
  60
  61     my $count = () = $results =~ /Final program:/g;
  62     if ($count == $n && !$status) {
  63         pass($desc);
  64     }
  65     else {
  66         fail($desc);
  67         _diag "# COUNT:    $count EXPECTED $n\n";
  68         _diag "# STATUS:   $status\n";
  69         _diag "# SWITCHES: @$switches\n";
  70         _diag "# PROG: \n$prog\n";
  71         # this is verbose; uncomment for debugging
  72         #_diag "# OUTPUT:\n------------------\n $results-------------------\n";
  73     }
  74 }
  75
  76 # Check that a pattern triggers a regex compilation exactly N times,
  77
  78 sub comp_n {
  79     my ($n, $prog, $desc) = @_;
  80     if ($has_Dr) {
  81         _comp_n(1, $n, $prog, "$desc -Dr");
  82     }
  83     else {
  84         SKIP: {
  85             skip("-Dr not compiled in");
  86         }
  87     }
  88     _comp_n(0, @_);
  89 }
  90
  91 # Check that a pattern triggers a regex compilation exactly once.
  92
  93 sub comp_1 {
  94     comp_n(1, @_);
  95 }
  96
  97
  98 comp_1(<<'CODE', 'simple');
  99 "a" =~ /$_/ for qw(a a a);
 100 CODE
 101
 102 comp_1(<<'CODE', 'simple qr');
 103 "a" =~ qr/$_/ for qw(a a a);
 104 CODE
 105
 106 comp_1(<<'CODE', 'literal utf8');
 107 "a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}";
 108 CODE
 109
 110 comp_1(<<'CODE', 'literal utf8 qr');
 111 "a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}";
 112 CODE
 113
 114 comp_1(<<'CODE', 'longjmp literal utf8');
 115 my $x = chr(0x80);
 116 "a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}";
 117 CODE
 118
 119 comp_1(<<'CODE', 'longjmp literal utf8 qr');
 120 my $x = chr(0x80);
 121 "a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}";
 122 CODE
 123
 124 comp_1(<<'CODE', 'utf8');
 125 "a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}';
 126 CODE
 127
 128 comp_1(<<'CODE', 'utf8 qr');
 129 "a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}';
 130 CODE
 131
 132 comp_1(<<'CODE', 'longjmp utf8');
 133 my $x = chr(0x80);
 134 "a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}';
 135 CODE
 136
 137 comp_1(<<'CODE', 'longjmp utf8');
 138 my $x = chr(0x80);
 139 "a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}';
 140 CODE
 141
 142 comp_n(3, <<'CODE', 'mixed utf8');
 143 "a" =~ /$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
 144 CODE
 145
 146 comp_n(3, <<'CODE', 'mixed utf8 qr');
 147 "a" =~ qr/$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
 148 CODE
 149
 150 # note that for runtime code, each pattern is compiled twice; the
 151 # second time to allow the parser to see the code.
 152
 153 comp_n(6, <<'CODE', 'runtime code');
 154 my $x = '(?{1})';
 155 BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
 156 "a" =~ /a$_/ for $x, $x, $x;
 157 CODE
 158
 159 comp_n(6, <<'CODE', 'runtime code qr');
 160 my $x = '(?{1})';
 161 BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
 162 "a" =~ qr/a$_/ for $x, $x, $x;
 163 CODE
 164
 165 comp_n(4, <<'CODE', 'embedded code');
 166 my $x = qr/(?{1})/;
 167 "a" =~ /a$_/ for $x, $x, $x;
 168 CODE
 169
 170 comp_n(4, <<'CODE', 'embedded code qr');
 171 my $x = qr/(?{1})/;
 172 "a" =~ qr/a$_/ for $x, $x, $x;
 173 CODE
 174
 175 comp_n(7, <<'CODE', 'mixed code');
 176 my $x = qr/(?{1})/;
 177 my $y = '(?{1})';
 178 BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
 179 "a" =~ /a$x$_/ for $y, $y, $y;
 180 CODE
 181
 182 comp_n(7, <<'CODE', 'mixed code qr');
 183 my $x = qr/(?{1})/;
 184 my $y = '(?{1})';
 185 BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
 186 "a" =~ qr/a$x$_/ for $y, $y, $y;
 187 CODE
 188
 189 comp_n(6, <<'CODE', 'embedded code qr');
 190 my $x = qr/a/i;
 191 my $y = qr/a/;
 192 "a" =~ qr/a$_/ for $x, $y, $x, $y;
 193 CODE
 194
 195 comp_n(2, <<'CODE', '(??{"constant"})');
 196 "bb" =~ /(??{"abc"})/;
 197 CODE
 198
 199 comp_n(2, <<'CODE', '(??{"folded"."constant"})');
 200 "bb" =~ /(??{"ab"."c"})/;
 201 CODE
 202
 203 comp_n(2, <<'CODE', '(??{$preused_scalar})');
 204 $s = "abc";
 205 "bb" =~ /(??{$s})/;
 206 CODE
 207
 208 comp_n(2, <<'CODE', '(??{number})');
 209 "bb" =~ /(??{123})/;
 210 CODE
 211
 212 comp_n(2, <<'CODE', '(??{$pvlv_regexp})');
 213 sub {
 214    $_[0] = ${qr/abc/};
 215   "bb" =~ /(??{$_[0]})/;
 216 }->($_[0]);
 217 CODE