| File | /usr/lib/perl/5.10/re.pm |
| Statements Executed | 39 |
| Total Time | 0.0011968 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 2 | 1 | 1 | 32µs | 32µs | re::bits |
| 2 | 2 | 2 | 20µs | 53µs | re::import |
| 0 | 0 | 0 | 0s | 0s | re::BEGIN |
| 0 | 0 | 0 | 0s | 0s | re::_do_install |
| 0 | 0 | 0 | 0s | 0s | re::_load_unload |
| 0 | 0 | 0 | 0s | 0s | re::setcolor |
| 0 | 0 | 0 | 0s | 0s | re::unimport |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | package re; | |||
| 2 | ||||
| 3 | # pragma for controlling the regex engine | |||
| 4 | 3 | 32µs | 10µs | use strict; # spent 12µs making 1 call to strict::import |
| 5 | 3 | 1.05ms | 351µs | use warnings; # spent 24µs making 1 call to warnings::import |
| 6 | ||||
| 7 | 1 | 700ns | 700ns | our $VERSION = "0.08"; |
| 8 | 1 | 9µs | 9µs | our @ISA = qw(Exporter); |
| 9 | 1 | 2µs | 2µs | our @EXPORT_OK = qw(is_regexp regexp_pattern regmust |
| 10 | regname regnames regnames_count); | |||
| 11 | 1 | 13µs | 13µs | our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK; |
| 12 | ||||
| 13 | # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING *** | |||
| 14 | # | |||
| 15 | # If you modify these values see comment below! | |||
| 16 | ||||
| 17 | 1 | 2µs | 2µs | my %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 | ||||
| 32 | sub 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 | ||||
| 50 | 1 | 8µs | 8µs | my %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 | ); | |||
| 72 | 1 | 2µs | 2µs | $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS}); |
| 73 | 1 | 1µs | 1µs | $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE}; |
| 74 | 1 | 1µs | 1µs | $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE}; |
| 75 | 1 | 2µs | 2µs | $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE}; |
| 76 | 1 | 1µs | 1µs | $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; |
| 77 | 1 | 1µs | 1µs | $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC}; |
| 78 | ||||
| 79 | 1 | 200ns | 200ns | my $installed; |
| 80 | 1 | 200ns | 200ns | my $installed_error; |
| 81 | ||||
| 82 | sub _do_install { | |||
| 83 | if ( ! defined($installed) ) { | |||
| 84 | require XSLoader; | |||
| 85 | $installed = eval { XSLoader::load('re', $VERSION) } || 0; | |||
| 86 | $installed_error = $@; | |||
| 87 | } | |||
| 88 | } | |||
| 89 | ||||
| 90 | sub _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 32µs within re::bits which was called 2 times, avg 16µs/call:
# 2 times (32µs+0s) by re::import at line 161, avg 16µs/call | |||
| 113 | 14 | 25µs | 2µs | 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 53µs (20+32) within re::import which was called 2 times, avg 26µs/call:
# once (10µs+18µs) at line 46 of /usr/share/perl/5.10/File/Basename.pm
# once (10µs+15µs) at line 596 of /usr/local/lib/perl/5.10.0/Moose/Util/TypeConstraints.pm | |||
| 160 | 4 | 16µs | 4µs | shift; |
| 161 | $^H |= bits(1, @_); # spent 32µs making 2 calls to re::bits, avg 16µs/call | |||
| 162 | } | |||
| 163 | ||||
| 164 | sub unimport { | |||
| 165 | shift; | |||
| 166 | $^H &= ~ bits(0, @_); | |||
| 167 | } | |||
| 168 | ||||
| 169 | 1 | 28µs | 28µs | 1; |
| 170 | ||||
| 171 | __END__ | |||
| 172 |