This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pmruntime: make more use of Perl_re_op_compile
[perl5.git] / t / re / recompile.t
CommitLineData
23af30a1
DM
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 => 36;
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) {
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
152comp_n(3, <<'CODE', 'runtime code');
153my $x = '(?{1})';
154BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
155"a" =~ /a$_/ for $x, $x, $x;
156CODE
157
158comp_n(3, <<'CODE', 'runtime code qr');
159my $x = '(?{1})';
160BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
161"a" =~ qr/a$_/ for $x, $x, $x;
162CODE
163
164comp_n(4, <<'CODE', 'embedded code');
165my $x = qr/(?{1})/;
166"a" =~ /a$_/ for $x, $x, $x;
167CODE
168
169comp_n(4, <<'CODE', 'embedded code qr');
170my $x = qr/(?{1})/;
171"a" =~ qr/a$_/ for $x, $x, $x;
172CODE
173
174comp_n(4, <<'CODE', 'mixed code');
175my $x = qr/(?{1})/;
176my $y = '(?{1})';
177BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
178"a" =~ /a$x$_/ for $y, $y, $y;
179CODE
180
181comp_n(4, <<'CODE', 'mixed code qr');
182my $x = qr/(?{1})/;
183my $y = '(?{1})';
184BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
185"a" =~ qr/a$x$_/ for $y, $y, $y;
186CODE