← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:05 2021

Filename/usr/local/lib/perl5/5.32/mach/re.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sre::::BEGIN@4re::BEGIN@4
0000s0sre::::BEGIN@5re::BEGIN@5
0000s0sre::::_load_unloadre::_load_unload
0000s0sre::::bitsre::bits
0000s0sre::::importre::import
0000s0sre::::setcolorre::setcolor
0000s0sre::::unimportre::unimport
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package re;
2
3# pragma for controlling the regexp engine
4use strict;
5use warnings;
6
7our $VERSION = "0.40";
8our @ISA = qw(Exporter);
9our @EXPORT_OK = ('regmust',
10 qw(is_regexp regexp_pattern
11 regname regnames regnames_count));
12our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
13
14my %bitmask = (
15 taint => 0x00100000, # HINT_RE_TAINT
16 eval => 0x00200000, # HINT_RE_EVAL
17);
18
19my $flags_hint = 0x02000000; # HINT_RE_FLAGS
20my $PMMOD_SHIFT = 0;
21my %reflags = (
22 m => 1 << ($PMMOD_SHIFT + 0),
23 s => 1 << ($PMMOD_SHIFT + 1),
24 i => 1 << ($PMMOD_SHIFT + 2),
25 x => 1 << ($PMMOD_SHIFT + 3),
26 xx => 1 << ($PMMOD_SHIFT + 4),
27 n => 1 << ($PMMOD_SHIFT + 5),
28 p => 1 << ($PMMOD_SHIFT + 6),
29 strict => 1 << ($PMMOD_SHIFT + 10),
30# special cases:
31 d => 0,
32 l => 1,
33 u => 2,
34 a => 3,
35 aa => 4,
36);
37
38sub setcolor {
39 eval { # Ignore errors
40 require Term::Cap;
41
42 my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
43 my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
44 my @props = split /,/, $props;
45 my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
46
47 $colors =~ s/\0//g;
48 $ENV{PERL_RE_COLORS} = $colors;
49 };
50 if ($@) {
51 $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
52 }
53
54}
55
56my %flags = (
57 COMPILE => 0x0000FF,
58 PARSE => 0x000001,
59 OPTIMISE => 0x000002,
60 TRIEC => 0x000004,
61 DUMP => 0x000008,
62 FLAGS => 0x000010,
63 TEST => 0x000020,
64
65 EXECUTE => 0x00FF00,
66 INTUIT => 0x000100,
67 MATCH => 0x000200,
68 TRIEE => 0x000400,
69
70 EXTRA => 0x3FF0000,
71 TRIEM => 0x0010000,
72 OFFSETS => 0x0020000,
73 OFFSETSDBG => 0x0040000,
74 STATE => 0x0080000,
75 OPTIMISEM => 0x0100000,
76 STACK => 0x0280000,
77 BUFFERS => 0x0400000,
78 GPOS => 0x0800000,
79 DUMP_PRE_OPTIMIZE => 0x1000000,
80 WILDCARD => 0x2000000,
81);
82$flags{ALL} = -1 & ~($flags{OFFSETS}
83 |$flags{OFFSETSDBG}
84 |$flags{BUFFERS}
85 |$flags{DUMP_PRE_OPTIMIZE}
86 |$flags{WILDCARD}
87 );
88$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
89$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
90$flags{More} = $flags{MORE} =
91 $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
92$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
93$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
94
95if (defined &DynaLoader::boot_DynaLoader) {
96 require XSLoader;
97 XSLoader::load();
98}
99# else we're miniperl
100# We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
101# uses re 'taint'.
102
103sub _load_unload {
104 my ($on)= @_;
105 if ($on) {
106 # We call install() every time, as if we didn't, we wouldn't
107 # "see" any changes to the color environment var since
108 # the last time it was called.
109
110 # install() returns an integer, which if casted properly
111 # in C resolves to a structure containing the regexp
112 # hooks. Setting it to a random integer will guarantee
113 # segfaults.
114 $^H{regcomp} = install();
115 } else {
116 delete $^H{regcomp};
117 }
118}
119
120sub bits {
121 my $on = shift;
122 my $bits = 0;
123 my $turning_all_off = ! @_ && ! $on;
124 my $seen_Debug = 0;
125 my $seen_debug = 0;
126 if ($turning_all_off) {
127
128 # Pretend were called with certain parameters, which are best dealt
129 # with that way.
130 push @_, keys %bitmask; # taint and eval
131 push @_, 'strict';
132 }
133
134 # Process each subpragma parameter
135 ARG:
136 foreach my $idx (0..$#_){
137 my $s=$_[$idx];
138 if ($s eq 'Debug' or $s eq 'Debugcolor') {
139 if (! $seen_Debug) {
140 $seen_Debug = 1;
141
142 # Reset to nothing, and then add what follows. $seen_Debug
143 # allows, though unlikely someone would do it, more than one
144 # Debug and flags in the arguments
145 ${^RE_DEBUG_FLAGS} = 0;
146 }
147 setcolor() if $s =~/color/i;
148 for my $idx ($idx+1..$#_) {
149 if ($flags{$_[$idx]}) {
150 if ($on) {
151 ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
152 } else {
153 ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
154 }
155 } else {
156 require Carp;
157 Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
158 join(", ",sort keys %flags ) );
159 }
160 }
161 _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
162 last;
163 } elsif ($s eq 'debug' or $s eq 'debugcolor') {
164
165 # These default flags should be kept in sync with the same values
166 # in regcomp.h
167 ${^RE_DEBUG_FLAGS} = $flags{'EXECUTE'} | $flags{'DUMP'};
168 setcolor() if $s =~/color/i;
169 _load_unload($on);
170 $seen_debug = 1;
171 } elsif (exists $bitmask{$s}) {
172 $bits |= $bitmask{$s};
173 } elsif ($EXPORT_OK{$s}) {
174 require Exporter;
175 re->export_to_level(2, 're', $s);
176 } elsif ($s eq 'strict') {
177 if ($on) {
178 $^H{reflags} |= $reflags{$s};
179 warnings::warnif('experimental::re_strict',
180 "\"use re 'strict'\" is experimental");
181
182 # Turn on warnings if not already done.
183 if (! warnings::enabled('regexp')) {
184 require warnings;
185 warnings->import('regexp');
186 $^H{re_strict} = 1;
187 }
188 }
189 else {
190 $^H{reflags} &= ~$reflags{$s} if $^H{reflags};
191
192 # Turn off warnings if we turned them on.
193 warnings->unimport('regexp') if $^H{re_strict};
194 }
195 if ($^H{reflags}) {
196 $^H |= $flags_hint;
197 }
198 else {
199 $^H &= ~$flags_hint;
200 }
201 } elsif ($s =~ s/^\///) {
202 my $reflags = $^H{reflags} || 0;
203 my $seen_charset;
204 my $x_count = 0;
205 while ($s =~ m/( . )/gx) {
206 local $_ = $1;
207 if (/[adul]/) {
208 # The 'a' may be repeated; hide this from the rest of the
209 # code by counting and getting rid of all of them, then
210 # changing to 'aa' if there is a repeat.
211 if ($_ eq 'a') {
212 my $sav_pos = pos $s;
213 my $a_count = $s =~ s/a//g;
214 pos $s = $sav_pos - 1; # -1 because got rid of the 'a'
215 if ($a_count > 2) {
216 require Carp;
217 Carp::carp(
218 qq 'The "a" flag may only appear a maximum of twice'
219 );
220 }
221 elsif ($a_count == 2) {
222 $_ = 'aa';
223 }
224 }
225 if ($on) {
226 if ($seen_charset) {
227 require Carp;
228 if ($seen_charset ne $_) {
229 Carp::carp(
230 qq 'The "$seen_charset" and "$_" flags '
231 .qq 'are exclusive'
232 );
233 }
234 else {
235 Carp::carp(
236 qq 'The "$seen_charset" flag may not appear '
237 .qq 'twice'
238 );
239 }
240 }
241 $^H{reflags_charset} = $reflags{$_};
242 $seen_charset = $_;
243 }
244 else {
245 delete $^H{reflags_charset}
246 if defined $^H{reflags_charset}
247 && $^H{reflags_charset} == $reflags{$_};
248 }
249 } elsif (exists $reflags{$_}) {
250 if ($_ eq 'x') {
251 $x_count++;
252 if ($x_count > 2) {
253 require Carp;
254 Carp::carp(
255 qq 'The "x" flag may only appear a maximum of twice'
256 );
257 }
258 elsif ($x_count == 2) {
259 $_ = 'xx'; # First time through got the /x
260 }
261 }
262
263 $on
264 ? $reflags |= $reflags{$_}
265 : ($reflags &= ~$reflags{$_});
266 } else {
267 require Carp;
268 Carp::carp(
269 qq'Unknown regular expression flag "$_"'
270 );
271 next ARG;
272 }
273 }
274 ($^H{reflags} = $reflags or defined $^H{reflags_charset})
275 ? $^H |= $flags_hint
276 : ($^H &= ~$flags_hint);
277 } else {
278 require Carp;
279 if ($seen_debug && defined $flags{$s}) {
280 Carp::carp("Use \"Debug\" not \"debug\", to list debug types"
281 . " in \"re\". \"$s\" ignored");
282 }
283 else {
284 Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
285 join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
286 ")");
287 }
288 }
289 }
290
291 if ($turning_all_off) {
292 _load_unload(0);
293 $^H{reflags} = 0;
294 $^H{reflags_charset} = 0;
295 $^H &= ~$flags_hint;
296 }
297
298 $bits;
299}
300
301sub import {
302 shift;
303 $^H |= bits(1, @_);
304}
305
306sub unimport {
307 shift;
308 $^H &= ~ bits(0, @_);
309}
310
3111;
312
313__END__