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 11use strict; 12use warnings; 13 14$| = 1; 15 16 17BEGIN { 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 25plan tests => 48; 26 27my $results = runperl( 28 switches => [ '-Dr' ], 29 prog => '1', 30 stderr => 1, 31 ); 32my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/; 33 34my $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 41sub _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 80sub 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 95sub comp_1 { 96 comp_n(1, @_); 97} 98 99 100comp_1(<<'CODE', 'simple'); 101"a" =~ /$_/ for qw(a a a); 102CODE 103 104comp_1(<<'CODE', 'simple qr'); 105"a" =~ qr/$_/ for qw(a a a); 106CODE 107 108comp_1(<<'CODE', 'literal utf8'); 109"a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}"; 110CODE 111 112comp_1(<<'CODE', 'literal utf8 qr'); 113"a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}"; 114CODE 115 116comp_1(<<'CODE', 'longjmp literal utf8'); 117my $x = chr(0x80); 118"a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}"; 119CODE 120 121comp_1(<<'CODE', 'longjmp literal utf8 qr'); 122my $x = chr(0x80); 123"a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}"; 124CODE 125 126comp_1(<<'CODE', 'utf8'); 127"a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}'; 128CODE 129 130comp_1(<<'CODE', 'utf8 qr'); 131"a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}'; 132CODE 133 134comp_1(<<'CODE', 'longjmp utf8'); 135my $x = chr(0x80); 136"a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}'; 137CODE 138 139comp_1(<<'CODE', 'longjmp utf8'); 140my $x = chr(0x80); 141"a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}'; 142CODE 143 144comp_n(3, <<'CODE', 'mixed utf8'); 145"a" =~ /$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}"; 146CODE 147 148comp_n(3, <<'CODE', 'mixed utf8 qr'); 149"a" =~ qr/$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}"; 150CODE 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 155comp_n(6, <<'CODE', 'runtime code'); 156my $x = '(?{1})'; 157BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" 158"a" =~ /a$_/ for $x, $x, $x; 159CODE 160 161comp_n(6, <<'CODE', 'runtime code qr'); 162my $x = '(?{1})'; 163BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" 164"a" =~ qr/a$_/ for $x, $x, $x; 165CODE 166 167comp_n(4, <<'CODE', 'embedded code'); 168my $x = qr/(?{1})/; 169"a" =~ /a$_/ for $x, $x, $x; 170CODE 171 172comp_n(4, <<'CODE', 'embedded code qr'); 173my $x = qr/(?{1})/; 174"a" =~ qr/a$_/ for $x, $x, $x; 175CODE 176 177comp_n(7, <<'CODE', 'mixed code'); 178my $x = qr/(?{1})/; 179my $y = '(?{1})'; 180BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" 181"a" =~ /a$x$_/ for $y, $y, $y; 182CODE 183 184comp_n(7, <<'CODE', 'mixed code qr'); 185my $x = qr/(?{1})/; 186my $y = '(?{1})'; 187BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" 188"a" =~ qr/a$x$_/ for $y, $y, $y; 189CODE 190 191comp_n(6, <<'CODE', 'embedded code qr'); 192my $x = qr/a/i; 193my $y = qr/a/; 194"a" =~ qr/a$_/ for $x, $y, $x, $y; 195CODE 196 197comp_n(2, <<'CODE', '(??{"constant"})'); 198"bb" =~ /(??{"abc"})/; 199CODE 200 201comp_n(2, <<'CODE', '(??{"folded"."constant"})'); 202"bb" =~ /(??{"ab"."c"})/; 203CODE 204 205comp_n(2, <<'CODE', '(??{$preused_scalar})'); 206$s = "abc"; 207"bb" =~ /(??{$s})/; 208CODE 209 210comp_n(2, <<'CODE', '(??{number})'); 211"bb" =~ /(??{123})/; 212CODE 213 214comp_n(2, <<'CODE', '(??{$pvlv_regexp})'); 215sub { 216 $_[0] = ${qr/abc/}; 217 "bb" =~ /(??{$_[0]})/; 218}->($_[0]); 219CODE 220