← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:22 2010

File/opt/wise/lib/perl5/5.10.0/x86_64-linux-thread-multi/re.pm
Statements Executed30
Total Time0.001181 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.1e-52.1e-5re::bits
1112.1e-54.2e-5re::import
00000re::BEGIN
00000re::_do_install
00000re::_load_unload
00000re::setcolor
00000re::unimport

LineStmts.Exclusive
Time
Avg.Code
1package re;
2
3# pragma for controlling the regex engine
433.8e-51.3e-5use strict;
# spent 22µs making 1 call to strict::import
530.001040.00035use warnings;
# spent 51µs making 1 call to warnings::import
6
711.0e-61.0e-6our $VERSION = "0.08";
811.1e-51.1e-5our @ISA = qw(Exporter);
912.0e-62.0e-6our @EXPORT_OK = qw(is_regexp regexp_pattern regmust
10 regname regnames regnames_count);
1111.0e-51.0e-5our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
12
13# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
14#
15# If you modify these values see comment below!
16
1714.0e-64.0e-6my %bitmask = (
18 taint => 0x00100000, # HINT_RE_TAINT
19 eval => 0x00200000, # HINT_RE_EVAL
20);
21
22# - File::Basename contains a literal for 'taint' as a fallback. If
23# taint is changed here, File::Basename must be updated as well.
24#
25# - ExtUtils::ParseXS uses a hardcoded
26# BEGIN { $^H |= 0x00200000 }
27# in it to allow re.xs to be built. So if 'eval' is changed here then
28# ExtUtils::ParseXS must be changed as well.
29#
30# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
31
32sub setcolor {
33 eval { # Ignore errors
34 require Term::Cap;
35
36 my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
37 my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
38 my @props = split /,/, $props;
39 my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
40
41 $colors =~ s/\0//g;
42 $ENV{PERL_RE_COLORS} = $colors;
43 };
44 if ($@) {
45 $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
46 }
47
48}
49
5011.0e-51.0e-5my %flags = (
51 COMPILE => 0x0000FF,
52 PARSE => 0x000001,
53 OPTIMISE => 0x000002,
54 TRIEC => 0x000004,
55 DUMP => 0x000008,
56 FLAGS => 0x000010,
57
58 EXECUTE => 0x00FF00,
59 INTUIT => 0x000100,
60 MATCH => 0x000200,
61 TRIEE => 0x000400,
62
63 EXTRA => 0xFF0000,
64 TRIEM => 0x010000,
65 OFFSETS => 0x020000,
66 OFFSETSDBG => 0x040000,
67 STATE => 0x080000,
68 OPTIMISEM => 0x100000,
69 STACK => 0x280000,
70 BUFFERS => 0x400000,
71);
7213.0e-63.0e-6$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
7312.0e-62.0e-6$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
7411.0e-61.0e-6$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
7512.0e-62.0e-6$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
7612.0e-62.0e-6$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
7711.0e-61.0e-6$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
78
79100my $installed;
8011.0e-61.0e-6my $installed_error;
81
82sub _do_install {
83 if ( ! defined($installed) ) {
84 require XSLoader;
85 $installed = eval { XSLoader::load('re', $VERSION) } || 0;
86 $installed_error = $@;
87 }
88}
89
90sub _load_unload {
91 my ($on)= @_;
92 if ($on) {
93 _do_install();
94 if ( ! $installed ) {
95 die "'re' not installed!? ($installed_error)";
96 } else {
97 # We call install() every time, as if we didn't, we wouldn't
98 # "see" any changes to the color environment var since
99 # the last time it was called.
100
101 # install() returns an integer, which if casted properly
102 # in C resolves to a structure containing the regex
103 # hooks. Setting it to a random integer will guarantee
104 # segfaults.
105 $^H{regcomp} = install();
106 }
107 } else {
108 delete $^H{regcomp};
109 }
110}
111
112
# spent 21µs within re::bits which was called # once (21µs+0) by re::import at line 161
sub bits {
11372.6e-53.7e-6 my $on = shift;
114 my $bits = 0;
115 unless (@_) {
116 require Carp;
117 Carp::carp("Useless use of \"re\" pragma");
118 }
119 foreach my $idx (0..$#_){
120 my $s=$_[$idx];
121 if ($s eq 'Debug' or $s eq 'Debugcolor') {
122 setcolor() if $s =~/color/i;
123 ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
124 for my $idx ($idx+1..$#_) {
125 if ($flags{$_[$idx]}) {
126 if ($on) {
127 ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
128 } else {
129 ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
130 }
131 } else {
132 require Carp;
133 Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
134 join(", ",sort keys %flags ) );
135 }
136 }
137 _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
138 last;
139 } elsif ($s eq 'debug' or $s eq 'debugcolor') {
140 setcolor() if $s =~/color/i;
141 _load_unload($on);
142 last;
143 } elsif (exists $bitmask{$s}) {
144 $bits |= $bitmask{$s};
145 } elsif ($EXPORT_OK{$s}) {
146 _do_install();
147 require Exporter;
148 re->export_to_level(2, 're', $s);
149 } else {
150 require Carp;
151 Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
152 join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
153 ")");
154 }
155 }
156 $bits;
157}
158
159
# spent 42µs (21+21) within re::import which was called # once (21µs+21µs) at line 46 of /opt/wise/lib/perl5/5.10.0/File/Basename.pm
sub import {
16028.0e-64.0e-6 shift;
161 $^H |= bits(1, @_);
# spent 21µs making 1 call to re::bits
162}
163
164sub unimport {
165 shift;
166 $^H &= ~ bits(0, @_);
167}
168
16912.3e-52.3e-51;
170
171__END__
172
173=head1 NAME
174
175re - Perl pragma to alter regular expression behaviour
176
177=head1 SYNOPSIS
178
179 use re 'taint';
180 ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here
181
182 $pat = '(?{ $foo = 1 })';
183 use re 'eval';
184 /foo${pat}bar/; # won't fail (when not under -T switch)
185
186 {
187 no re 'taint'; # the default
188 ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
189
190 no re 'eval'; # the default
191 /foo${pat}bar/; # disallowed (with or without -T switch)
192 }
193
194 use re 'debug'; # output debugging info during
195 /^(.*)$/s; # compile and run time
196
197
198 use re 'debugcolor'; # same as 'debug', but with colored output
199 ...
200
201 use re qw(Debug All); # Finer tuned debugging options.
202 use re qw(Debug More);
203 no re qw(Debug ALL); # Turn of all re debugging in this scope
204
205 use re qw(is_regexp regexp_pattern); # import utility functions
206 my ($pat,$mods)=regexp_pattern(qr/foo/i);
207 if (is_regexp($obj)) {
208 print "Got regexp: ",
209 scalar regexp_pattern($obj); # just as perl would stringify it
210 } # but no hassle with blessed re's.
211
212(We use $^X in these examples because it's tainted by default.)
213
214=head1 DESCRIPTION
215
216=head2 'taint' mode
217
218When C<use re 'taint'> is in effect, and a tainted string is the target
219of a regex, the regex memories (or values returned by the m// operator
220in list context) are tainted. This feature is useful when regex operations
221on tainted data aren't meant to extract safe substrings, but to perform
222other transformations.
223
224=head2 'eval' mode
225
226When C<use re 'eval'> is in effect, a regex is allowed to contain
227C<(?{ ... })> zero-width assertions even if regular expression contains
228variable interpolation. That is normally disallowed, since it is a
229potential security risk. Note that this pragma is ignored when the regular
230expression is obtained from tainted data, i.e. evaluation is always
231disallowed with tainted regular expressions. See L<perlre/(?{ code })>.
232
233For the purpose of this pragma, interpolation of precompiled regular
234expressions (i.e., the result of C<qr//>) is I<not> considered variable
235interpolation. Thus:
236
237 /foo${pat}bar/
238
239I<is> allowed if $pat is a precompiled regular expression, even
240if $pat contains C<(?{ ... })> assertions.
241
242=head2 'debug' mode
243
244When C<use re 'debug'> is in effect, perl emits debugging messages when
245compiling and using regular expressions. The output is the same as that
246obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
247B<-Dr> switch. It may be quite voluminous depending on the complexity
248of the match. Using C<debugcolor> instead of C<debug> enables a
249form of output that can be used to get a colorful display on terminals
250that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
251comma-separated list of C<termcap> properties to use for highlighting
252strings on/off, pre-point part on/off.
253See L<perldebug/"Debugging regular expressions"> for additional info.
254
255As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
256lexically scoped, as the other directives are. However they have both
257compile-time and run-time effects.
258
259See L<perlmodlib/Pragmatic Modules>.
260
261=head2 'Debug' mode
262
263Similarly C<use re 'Debug'> produces debugging output, the difference
264being that it allows the fine tuning of what debugging output will be
265emitted. Options are divided into three groups, those related to
266compilation, those related to execution and those related to special
267purposes. The options are as follows:
268
269=over 4
270
271=item Compile related options
272
273=over 4
274
275=item COMPILE
276
277Turns on all compile related debug options.
278
279=item PARSE
280
281Turns on debug output related to the process of parsing the pattern.
282
283=item OPTIMISE
284
285Enables output related to the optimisation phase of compilation.
286
287=item TRIEC
288
289Detailed info about trie compilation.
290
291=item DUMP
292
293Dump the final program out after it is compiled and optimised.
294
295=back
296
297=item Execute related options
298
299=over 4
300
301=item EXECUTE
302
303Turns on all execute related debug options.
304
305=item MATCH
306
307Turns on debugging of the main matching loop.
308
309=item TRIEE
310
311Extra debugging of how tries execute.
312
313=item INTUIT
314
315Enable debugging of start point optimisations.
316
317=back
318
319=item Extra debugging options
320
321=over 4
322
323=item EXTRA
324
325Turns on all "extra" debugging options.
326
327=item BUFFERS
328
329Enable debugging the capture buffer storage during match. Warning,
330this can potentially produce extremely large output.
331
332=item TRIEM
333
334Enable enhanced TRIE debugging. Enhances both TRIEE
335and TRIEC.
336
337=item STATE
338
339Enable debugging of states in the engine.
340
341=item STACK
342
343Enable debugging of the recursion stack in the engine. Enabling
344or disabling this option automatically does the same for debugging
345states as well. This output from this can be quite large.
346
347=item OPTIMISEM
348
349Enable enhanced optimisation debugging and start point optimisations.
350Probably not useful except when debugging the regex engine itself.
351
352=item OFFSETS
353
354Dump offset information. This can be used to see how regops correlate
355to the pattern. Output format is
356
357 NODENUM:POSITION[LENGTH]
358
359Where 1 is the position of the first char in the string. Note that position
360can be 0, or larger than the actual length of the pattern, likewise length
361can be zero.
362
363=item OFFSETSDBG
364
365Enable debugging of offsets information. This emits copious
366amounts of trace information and doesn't mesh well with other
367debug options.
368
369Almost definitely only useful to people hacking
370on the offsets part of the debug engine.
371
372=back
373
374=item Other useful flags
375
376These are useful shortcuts to save on the typing.
377
378=over 4
379
380=item ALL
381
382Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
383
384=item All
385
386Enable DUMP and all execute options. Equivalent to:
387
388 use re 'debug';
389
390=item MORE
391
392=item More
393
394Enable TRIEM and all execute compile and execute options.
395
396=back
397
398=back
399
400As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
401lexically scoped, as the other directives are. However they have both
402compile-time and run-time effects.
403
404=head2 Exportable Functions
405
406As of perl 5.9.5 're' debug contains a number of utility functions that
407may be optionally exported into the caller's namespace. They are listed
408below.
409
410=over 4
411
412=item is_regexp($ref)
413
414Returns true if the argument is a compiled regular expression as returned
415by C<qr//>, false if it is not.
416
417This function will not be confused by overloading or blessing. In
418internals terms, this extracts the regexp pointer out of the
419PERL_MAGIC_qr structure so it it cannot be fooled.
420
421=item regexp_pattern($ref)
422
423If the argument is a compiled regular expression as returned by C<qr//>,
424then this function returns the pattern.
425
426In list context it returns a two element list, the first element
427containing the pattern and the second containing the modifiers used when
428the pattern was compiled.
429
430 my ($pat, $mods) = regexp_pattern($ref);
431
432In scalar context it returns the same as perl would when strigifying a raw
433C<qr//> with the same pattern inside. If the argument is not a compiled
434reference then this routine returns false but defined in scalar context,
435and the empty list in list context. Thus the following
436
437 if (regexp_pattern($ref) eq '(?i-xsm:foo)')
438
439will be warning free regardless of what $ref actually is.
440
441Like C<is_regexp> this function will not be confused by overloading
442or blessing of the object.
443
444=item regmust($ref)
445
446If the argument is a compiled regular expression as returned by C<qr//>,
447then this function returns what the optimiser consiers to be the longest
448anchored fixed string and longest floating fixed string in the pattern.
449
450A I<fixed string> is defined as being a substring that must appear for the
451pattern to match. An I<anchored fixed string> is a fixed string that must
452appear at a particular offset from the beginning of the match. A I<floating
453fixed string> is defined as a fixed string that can appear at any point in
454a range of positions relative to the start of the match. For example,
455
456 my $qr = qr/here .* there/x;
457 my ($anchored, $floating) = regmust($qr);
458 print "anchored:'$anchored'\nfloating:'$floating'\n";
459
460results in
461
462 anchored:'here'
463 floating:'there'
464
465Because the C<here> is before the C<.*> in the pattern, its position
466can be determined exactly. That's not true, however, for the C<there>;
467it could appear at any point after where the anchored string appeared.
468Perl uses both for its optimisations, prefering the longer, or, if they are
469equal, the floating.
470
471B<NOTE:> This may not necessarily be the definitive longest anchored and
472floating string. This will be what the optimiser of the Perl that you
473are using thinks is the longest. If you believe that the result is wrong
474please report it via the L<perlbug> utility.
475
476=item regname($name,$all)
477
478Returns the contents of a named buffer of the last successful match. If
479$all is true, then returns an array ref containing one entry per buffer,
480otherwise returns the first defined buffer.
481
482=item regnames($all)
483
484Returns a list of all of the named buffers defined in the last successful
485match. If $all is true, then it returns all names defined, if not it returns
486only names which were involved in the match.
487
488=item regnames_count()
489
490Returns the number of distinct names defined in the pattern used
491for the last successful match.
492
493B<Note:> this result is always the actual number of distinct
494named buffers defined, it may not actually match that which is
495returned by C<regnames()> and related routines when those routines
496have not been called with the $all parameter set.
497
498=back
499
500=head1 SEE ALSO
501
502L<perlmodlib/Pragmatic Modules>.
503
504=cut