xref: /openbsd/gnu/usr.bin/perl/t/re/recompile.t (revision 6f40fd34) 
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
13BEGIN {
14    chdir 't' if -d 't';
15    @INC = ('../lib','.');
16    require './test.pl';
17    skip_all_if_miniperl("no dynamic loading on miniperl, no re");
18}
19
20use strict;
21use warnings;
22
23plan tests => 48;
24
25my $results = runperl(
26			switches => [ '-Dr' ],
27			prog => '1',
28			stderr   => 1,
29		    );
30my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/;
31
32my $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
39sub _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
78sub 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
93sub comp_1 {
94    comp_n(1, @_);
95}
96
97
98comp_1(<<'CODE', 'simple');
99"a" =~ /$_/ for qw(a a a);
100CODE
101
102comp_1(<<'CODE', 'simple qr');
103"a" =~ qr/$_/ for qw(a a a);
104CODE
105
106comp_1(<<'CODE', 'literal utf8');
107"a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}";
108CODE
109
110comp_1(<<'CODE', 'literal utf8 qr');
111"a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}";
112CODE
113
114comp_1(<<'CODE', 'longjmp literal utf8');
115my $x = chr(0x80);
116"a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}";
117CODE
118
119comp_1(<<'CODE', 'longjmp literal utf8 qr');
120my $x = chr(0x80);
121"a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}";
122CODE
123
124comp_1(<<'CODE', 'utf8');
125"a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}';
126CODE
127
128comp_1(<<'CODE', 'utf8 qr');
129"a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}';
130CODE
131
132comp_1(<<'CODE', 'longjmp utf8');
133my $x = chr(0x80);
134"a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}';
135CODE
136
137comp_1(<<'CODE', 'longjmp utf8');
138my $x = chr(0x80);
139"a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}';
140CODE
141
142comp_n(3, <<'CODE', 'mixed utf8');
143"a" =~ /$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
144CODE
145
146comp_n(3, <<'CODE', 'mixed utf8 qr');
147"a" =~ qr/$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
148CODE
149
150# note that that for runtime code, each pattern is compiled twice; the
151# second time to allow the parser to see the code.
152
153comp_n(6, <<'CODE', 'runtime code');
154my $x = '(?{1})';
155BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
156"a" =~ /a$_/ for $x, $x, $x;
157CODE
158
159comp_n(6, <<'CODE', 'runtime code qr');
160my $x = '(?{1})';
161BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
162"a" =~ qr/a$_/ for $x, $x, $x;
163CODE
164
165comp_n(4, <<'CODE', 'embedded code');
166my $x = qr/(?{1})/;
167"a" =~ /a$_/ for $x, $x, $x;
168CODE
169
170comp_n(4, <<'CODE', 'embedded code qr');
171my $x = qr/(?{1})/;
172"a" =~ qr/a$_/ for $x, $x, $x;
173CODE
174
175comp_n(7, <<'CODE', 'mixed code');
176my $x = qr/(?{1})/;
177my $y = '(?{1})';
178BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
179"a" =~ /a$x$_/ for $y, $y, $y;
180CODE
181
182comp_n(7, <<'CODE', 'mixed code qr');
183my $x = qr/(?{1})/;
184my $y = '(?{1})';
185BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
186"a" =~ qr/a$x$_/ for $y, $y, $y;
187CODE
188
189comp_n(6, <<'CODE', 'embedded code qr');
190my $x = qr/a/i;
191my $y = qr/a/;
192"a" =~ qr/a$_/ for $x, $y, $x, $y;
193CODE
194
195comp_n(2, <<'CODE', '(??{"constant"})');
196"bb" =~ /(??{"abc"})/;
197CODE
198
199comp_n(2, <<'CODE', '(??{"folded"."constant"})');
200"bb" =~ /(??{"ab"."c"})/;
201CODE
202
203comp_n(2, <<'CODE', '(??{$preused_scalar})');
204$s = "abc";
205"bb" =~ /(??{$s})/;
206CODE
207
208comp_n(2, <<'CODE', '(??{number})');
209"bb" =~ /(??{123})/;
210CODE
211
212comp_n(2, <<'CODE', '(??{$pvlv_regexp})');
213sub {
214   $_[0] = ${qr/abc/};
215  "bb" =~ /(??{$_[0]})/;
216}->($_[0]);
217CODE
218