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