This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix problems with -Dr during global destruction
[perl5.git] / 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