| Filename | /home/s1/perl5/perlbrew/perls/perl-5.22.1/lib/5.22.1/x86_64-linux/re.pm |
| Statements | Executed 36 statements in 1.83ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 18µs | 21µs | re::BEGIN@4 |
| 1 | 1 | 1 | 12µs | 12µs | re::bits |
| 1 | 1 | 1 | 8µs | 14µs | re::BEGIN@5 |
| 1 | 1 | 1 | 8µs | 20µs | re::import |
| 0 | 0 | 0 | 0s | 0s | re::_load_unload |
| 0 | 0 | 0 | 0s | 0s | re::setcolor |
| 0 | 0 | 0 | 0s | 0s | re::unimport |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package re; | ||||
| 2 | |||||
| 3 | # pragma for controlling the regexp engine | ||||
| 4 | 2 | 29µs | 2 | 24µs | # spent 21µs (18+3) within re::BEGIN@4 which was called:
# once (18µs+3µs) by DateTime::Format::Alami::BEGIN@114 at line 4 # spent 21µs making 1 call to re::BEGIN@4
# spent 3µs making 1 call to strict::import |
| 5 | 2 | 1.40ms | 2 | 19µs | # spent 14µs (8+5) within re::BEGIN@5 which was called:
# once (8µs+5µs) by DateTime::Format::Alami::BEGIN@114 at line 5 # spent 14µs making 1 call to re::BEGIN@5
# spent 5µs making 1 call to warnings::import |
| 6 | |||||
| 7 | 1 | 600ns | our $VERSION = "0.32"; | ||
| 8 | 1 | 8µs | our @ISA = qw(Exporter); | ||
| 9 | 1 | 1µs | our @EXPORT_OK = ('regmust', | ||
| 10 | qw(is_regexp regexp_pattern | ||||
| 11 | regname regnames regnames_count)); | ||||
| 12 | 1 | 6µs | our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK; | ||
| 13 | |||||
| 14 | 1 | 900ns | my %bitmask = ( | ||
| 15 | taint => 0x00100000, # HINT_RE_TAINT | ||||
| 16 | eval => 0x00200000, # HINT_RE_EVAL | ||||
| 17 | ); | ||||
| 18 | |||||
| 19 | 1 | 300ns | my $flags_hint = 0x02000000; # HINT_RE_FLAGS | ||
| 20 | 1 | 100ns | my $PMMOD_SHIFT = 0; | ||
| 21 | 1 | 6µs | my %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 | n => 1 << ($PMMOD_SHIFT + 5), | ||||
| 27 | p => 1 << ($PMMOD_SHIFT + 6), | ||||
| 28 | strict => 1 << ($PMMOD_SHIFT + 10), | ||||
| 29 | # special cases: | ||||
| 30 | d => 0, | ||||
| 31 | l => 1, | ||||
| 32 | u => 2, | ||||
| 33 | a => 3, | ||||
| 34 | aa => 4, | ||||
| 35 | ); | ||||
| 36 | |||||
| 37 | sub setcolor { | ||||
| 38 | eval { # Ignore errors | ||||
| 39 | require Term::Cap; | ||||
| 40 | |||||
| 41 | my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. | ||||
| 42 | my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; | ||||
| 43 | my @props = split /,/, $props; | ||||
| 44 | my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; | ||||
| 45 | |||||
| 46 | $colors =~ s/\0//g; | ||||
| 47 | $ENV{PERL_RE_COLORS} = $colors; | ||||
| 48 | }; | ||||
| 49 | if ($@) { | ||||
| 50 | $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t'; | ||||
| 51 | } | ||||
| 52 | |||||
| 53 | } | ||||
| 54 | |||||
| 55 | 1 | 7µs | my %flags = ( | ||
| 56 | COMPILE => 0x0000FF, | ||||
| 57 | PARSE => 0x000001, | ||||
| 58 | OPTIMISE => 0x000002, | ||||
| 59 | TRIEC => 0x000004, | ||||
| 60 | DUMP => 0x000008, | ||||
| 61 | FLAGS => 0x000010, | ||||
| 62 | TEST => 0x000020, | ||||
| 63 | |||||
| 64 | EXECUTE => 0x00FF00, | ||||
| 65 | INTUIT => 0x000100, | ||||
| 66 | MATCH => 0x000200, | ||||
| 67 | TRIEE => 0x000400, | ||||
| 68 | |||||
| 69 | EXTRA => 0xFF0000, | ||||
| 70 | TRIEM => 0x010000, | ||||
| 71 | OFFSETS => 0x020000, | ||||
| 72 | OFFSETSDBG => 0x040000, | ||||
| 73 | STATE => 0x080000, | ||||
| 74 | OPTIMISEM => 0x100000, | ||||
| 75 | STACK => 0x280000, | ||||
| 76 | BUFFERS => 0x400000, | ||||
| 77 | GPOS => 0x800000, | ||||
| 78 | ); | ||||
| 79 | 1 | 1µs | $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS}); | ||
| 80 | 1 | 600ns | $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE}; | ||
| 81 | 1 | 500ns | $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS}; | ||
| 82 | 1 | 700ns | $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE}; | ||
| 83 | 1 | 400ns | $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; | ||
| 84 | 1 | 400ns | $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC}; | ||
| 85 | |||||
| 86 | 1 | 800ns | if (defined &DynaLoader::boot_DynaLoader) { | ||
| 87 | 1 | 600ns | require XSLoader; | ||
| 88 | 1 | 320µs | 1 | 312µs | XSLoader::load(); # spent 312µs making 1 call to XSLoader::load |
| 89 | } | ||||
| 90 | # else we're miniperl | ||||
| 91 | # We need to work for miniperl, because the XS toolchain uses Text::Wrap, which | ||||
| 92 | # uses re 'taint'. | ||||
| 93 | |||||
| 94 | sub _load_unload { | ||||
| 95 | my ($on)= @_; | ||||
| 96 | if ($on) { | ||||
| 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 regexp | ||||
| 103 | # hooks. Setting it to a random integer will guarantee | ||||
| 104 | # segfaults. | ||||
| 105 | $^H{regcomp} = install(); | ||||
| 106 | } else { | ||||
| 107 | delete $^H{regcomp}; | ||||
| 108 | } | ||||
| 109 | } | ||||
| 110 | |||||
| 111 | # spent 12µs within re::bits which was called:
# once (12µs+0s) by re::import at line 275 | ||||
| 112 | 1 | 200ns | my $on = shift; | ||
| 113 | 1 | 200ns | my $bits = 0; | ||
| 114 | 1 | 700ns | my $turning_all_off = ! @_ && ! $on; | ||
| 115 | 1 | 200ns | my %seen; # Has flag already been seen? | ||
| 116 | 1 | 200ns | if ($turning_all_off) { | ||
| 117 | |||||
| 118 | # Pretend were called with certain parameters, which are best dealt | ||||
| 119 | # with that way. | ||||
| 120 | push @_, keys %bitmask; # taint and eval | ||||
| 121 | push @_, 'strict'; | ||||
| 122 | } | ||||
| 123 | |||||
| 124 | # Process each subpragma parameter | ||||
| 125 | ARG: | ||||
| 126 | 1 | 5µs | foreach my $idx (0..$#_){ | ||
| 127 | 1 | 700ns | my $s=$_[$idx]; | ||
| 128 | 1 | 2µs | if ($s eq 'Debug' or $s eq 'Debugcolor') { | ||
| 129 | setcolor() if $s =~/color/i; | ||||
| 130 | ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; | ||||
| 131 | for my $idx ($idx+1..$#_) { | ||||
| 132 | if ($flags{$_[$idx]}) { | ||||
| 133 | if ($on) { | ||||
| 134 | ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]}; | ||||
| 135 | } else { | ||||
| 136 | ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]}; | ||||
| 137 | } | ||||
| 138 | } else { | ||||
| 139 | require Carp; | ||||
| 140 | Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ", | ||||
| 141 | join(", ",sort keys %flags ) ); | ||||
| 142 | } | ||||
| 143 | } | ||||
| 144 | _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS}); | ||||
| 145 | last; | ||||
| 146 | } elsif ($s eq 'debug' or $s eq 'debugcolor') { | ||||
| 147 | setcolor() if $s =~/color/i; | ||||
| 148 | _load_unload($on); | ||||
| 149 | last; | ||||
| 150 | } elsif (exists $bitmask{$s}) { | ||||
| 151 | $bits |= $bitmask{$s}; | ||||
| 152 | } elsif ($EXPORT_OK{$s}) { | ||||
| 153 | require Exporter; | ||||
| 154 | re->export_to_level(2, 're', $s); | ||||
| 155 | } elsif ($s eq 'strict') { | ||||
| 156 | if ($on) { | ||||
| 157 | $^H{reflags} |= $reflags{$s}; | ||||
| 158 | warnings::warnif('experimental::re_strict', | ||||
| 159 | "\"use re 'strict'\" is experimental"); | ||||
| 160 | |||||
| 161 | # Turn on warnings if not already done. | ||||
| 162 | if (! warnings::enabled('regexp')) { | ||||
| 163 | require warnings; | ||||
| 164 | warnings->import('regexp'); | ||||
| 165 | $^H{re_strict} = 1; | ||||
| 166 | } | ||||
| 167 | } | ||||
| 168 | else { | ||||
| 169 | $^H{reflags} &= ~$reflags{$s} if $^H{reflags}; | ||||
| 170 | |||||
| 171 | # Turn off warnings if we turned them on. | ||||
| 172 | warnings->unimport('regexp') if $^H{re_strict}; | ||||
| 173 | } | ||||
| 174 | if ($^H{reflags}) { | ||||
| 175 | $^H |= $flags_hint; | ||||
| 176 | } | ||||
| 177 | else { | ||||
| 178 | $^H &= ~$flags_hint; | ||||
| 179 | } | ||||
| 180 | } elsif ($s =~ s/^\///) { | ||||
| 181 | my $reflags = $^H{reflags} || 0; | ||||
| 182 | my $seen_charset; | ||||
| 183 | while ($s =~ m/( . )/gx) { | ||||
| 184 | local $_ = $1; | ||||
| 185 | if (/[adul]/) { | ||||
| 186 | # The 'a' may be repeated; hide this from the rest of the | ||||
| 187 | # code by counting and getting rid of all of them, then | ||||
| 188 | # changing to 'aa' if there is a repeat. | ||||
| 189 | if ($_ eq 'a') { | ||||
| 190 | my $sav_pos = pos $s; | ||||
| 191 | my $a_count = $s =~ s/a//g; | ||||
| 192 | pos $s = $sav_pos - 1; # -1 because got rid of the 'a' | ||||
| 193 | if ($a_count > 2) { | ||||
| 194 | require Carp; | ||||
| 195 | Carp::carp( | ||||
| 196 | qq 'The "a" flag may only appear a maximum of twice' | ||||
| 197 | ); | ||||
| 198 | } | ||||
| 199 | elsif ($a_count == 2) { | ||||
| 200 | $_ = 'aa'; | ||||
| 201 | } | ||||
| 202 | } | ||||
| 203 | if ($on) { | ||||
| 204 | if ($seen_charset) { | ||||
| 205 | require Carp; | ||||
| 206 | if ($seen_charset ne $_) { | ||||
| 207 | Carp::carp( | ||||
| 208 | qq 'The "$seen_charset" and "$_" flags ' | ||||
| 209 | .qq 'are exclusive' | ||||
| 210 | ); | ||||
| 211 | } | ||||
| 212 | else { | ||||
| 213 | Carp::carp( | ||||
| 214 | qq 'The "$seen_charset" flag may not appear ' | ||||
| 215 | .qq 'twice' | ||||
| 216 | ); | ||||
| 217 | } | ||||
| 218 | } | ||||
| 219 | $^H{reflags_charset} = $reflags{$_}; | ||||
| 220 | $seen_charset = $_; | ||||
| 221 | } | ||||
| 222 | else { | ||||
| 223 | delete $^H{reflags_charset} | ||||
| 224 | if defined $^H{reflags_charset} | ||||
| 225 | && $^H{reflags_charset} == $reflags{$_}; | ||||
| 226 | } | ||||
| 227 | } elsif (exists $reflags{$_}) { | ||||
| 228 | $seen{$_}++; | ||||
| 229 | $on | ||||
| 230 | ? $reflags |= $reflags{$_} | ||||
| 231 | : ($reflags &= ~$reflags{$_}); | ||||
| 232 | } else { | ||||
| 233 | require Carp; | ||||
| 234 | Carp::carp( | ||||
| 235 | qq'Unknown regular expression flag "$_"' | ||||
| 236 | ); | ||||
| 237 | next ARG; | ||||
| 238 | } | ||||
| 239 | } | ||||
| 240 | ($^H{reflags} = $reflags or defined $^H{reflags_charset}) | ||||
| 241 | ? $^H |= $flags_hint | ||||
| 242 | : ($^H &= ~$flags_hint); | ||||
| 243 | } else { | ||||
| 244 | require Carp; | ||||
| 245 | Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", | ||||
| 246 | join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask), | ||||
| 247 | ")"); | ||||
| 248 | } | ||||
| 249 | } | ||||
| 250 | 1 | 200ns | if (exists $seen{'x'} && $seen{'x'} > 1 | ||
| 251 | && (warnings::enabled("deprecated") | ||||
| 252 | || warnings::enabled("regexp"))) | ||||
| 253 | { | ||||
| 254 | my $message = "Having more than one /x regexp modifier is deprecated"; | ||||
| 255 | if (warnings::enabled("deprecated")) { | ||||
| 256 | warnings::warn("deprecated", $message); | ||||
| 257 | } | ||||
| 258 | else { | ||||
| 259 | warnings::warn("regexp", $message); | ||||
| 260 | } | ||||
| 261 | } | ||||
| 262 | |||||
| 263 | 1 | 200ns | if ($turning_all_off) { | ||
| 264 | _load_unload(0); | ||||
| 265 | $^H{reflags} = 0; | ||||
| 266 | $^H{reflags_charset} = 0; | ||||
| 267 | $^H &= ~$flags_hint; | ||||
| 268 | } | ||||
| 269 | |||||
| 270 | 1 | 6µs | $bits; | ||
| 271 | } | ||||
| 272 | |||||
| 273 | # spent 20µs (8+12) within re::import which was called:
# once (8µs+12µs) by DateTime::Format::Alami::BEGIN@114 at line 114 of lib/DateTime/Format/Alami.pm | ||||
| 274 | 1 | 200ns | shift; | ||
| 275 | 1 | 5µs | 1 | 12µs | $^H |= bits(1, @_); # spent 12µs making 1 call to re::bits |
| 276 | } | ||||
| 277 | |||||
| 278 | sub unimport { | ||||
| 279 | shift; | ||||
| 280 | $^H &= ~ bits(0, @_); | ||||
| 281 | } | ||||
| 282 | |||||
| 283 | 1 | 23µs | 1; | ||
| 284 | |||||
| 285 | __END__ |