Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/re.pm |
Statements | Executed 32 statements in 6.10ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 63µs | 82µs | BEGIN@4 | re::
1 | 1 | 1 | 35µs | 35µs | bits | re::
1 | 1 | 1 | 33µs | 67µs | import | re::
1 | 1 | 1 | 31µs | 59µs | BEGIN@5 | re::
0 | 0 | 0 | 0s | 0s | _load_unload | re::
0 | 0 | 0 | 0s | 0s | setcolor | re::
0 | 0 | 0 | 0s | 0s | unimport | re::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package re; | ||||
2 | |||||
3 | # pragma for controlling the regexp engine | ||||
4 | 2 | 102µs | 2 | 100µs | # spent 82µs (63+18) within re::BEGIN@4 which was called:
# once (63µs+18µs) by B::Deparse::BEGIN@3436 at line 4 # spent 82µs making 1 call to re::BEGIN@4
# spent 18µs making 1 call to strict::import |
5 | 2 | 4.89ms | 2 | 86µs | # spent 59µs (31+28) within re::BEGIN@5 which was called:
# once (31µs+28µs) by B::Deparse::BEGIN@3436 at line 5 # spent 59µs making 1 call to re::BEGIN@5
# spent 28µs making 1 call to warnings::import |
6 | |||||
7 | 1 | 3µs | our $VERSION = "0.18"; | ||
8 | 1 | 31µs | our @ISA = qw(Exporter); | ||
9 | 1 | 6µs | our @EXPORT_OK = ('regmust', | ||
10 | qw(is_regexp regexp_pattern | ||||
11 | regname regnames regnames_count)); | ||||
12 | 1 | 24µs | our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK; | ||
13 | |||||
14 | 1 | 5µs | my %bitmask = ( | ||
15 | taint => 0x00100000, # HINT_RE_TAINT | ||||
16 | eval => 0x00200000, # HINT_RE_EVAL | ||||
17 | ); | ||||
18 | |||||
19 | 1 | 1µs | my $flags_hint = 0x02000000; # HINT_RE_FLAGS | ||
20 | 1 | 600ns | my $PMMOD_SHIFT = 0; | ||
21 | 1 | 21µ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 | p => 1 << ($PMMOD_SHIFT + 4), | ||||
27 | # special cases: | ||||
28 | d => 0, | ||||
29 | l => 1, | ||||
30 | u => 2, | ||||
31 | a => 3, | ||||
32 | aa => 4, | ||||
33 | ); | ||||
34 | |||||
35 | sub setcolor { | ||||
36 | eval { # Ignore errors | ||||
37 | require Term::Cap; | ||||
38 | |||||
39 | my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. | ||||
40 | my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; | ||||
41 | my @props = split /,/, $props; | ||||
42 | my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; | ||||
43 | |||||
44 | $colors =~ s/\0//g; | ||||
45 | $ENV{PERL_RE_COLORS} = $colors; | ||||
46 | }; | ||||
47 | if ($@) { | ||||
48 | $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t'; | ||||
49 | } | ||||
50 | |||||
51 | } | ||||
52 | |||||
53 | 1 | 19µs | my %flags = ( | ||
54 | COMPILE => 0x0000FF, | ||||
55 | PARSE => 0x000001, | ||||
56 | OPTIMISE => 0x000002, | ||||
57 | TRIEC => 0x000004, | ||||
58 | DUMP => 0x000008, | ||||
59 | FLAGS => 0x000010, | ||||
60 | |||||
61 | EXECUTE => 0x00FF00, | ||||
62 | INTUIT => 0x000100, | ||||
63 | MATCH => 0x000200, | ||||
64 | TRIEE => 0x000400, | ||||
65 | |||||
66 | EXTRA => 0xFF0000, | ||||
67 | TRIEM => 0x010000, | ||||
68 | OFFSETS => 0x020000, | ||||
69 | OFFSETSDBG => 0x040000, | ||||
70 | STATE => 0x080000, | ||||
71 | OPTIMISEM => 0x100000, | ||||
72 | STACK => 0x280000, | ||||
73 | BUFFERS => 0x400000, | ||||
74 | GPOS => 0x800000, | ||||
75 | ); | ||||
76 | 1 | 7µs | $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS}); | ||
77 | 1 | 3µs | $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE}; | ||
78 | 1 | 2µs | $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS}; | ||
79 | 1 | 3µs | $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE}; | ||
80 | 1 | 2µs | $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; | ||
81 | 1 | 2µs | $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC}; | ||
82 | |||||
83 | 1 | 13µs | if (defined &DynaLoader::boot_DynaLoader) { | ||
84 | 1 | 2µs | require XSLoader; | ||
85 | 1 | 799µs | 1 | 765µs | XSLoader::load(); # spent 765µs making 1 call to XSLoader::load |
86 | } | ||||
87 | # else we're miniperl | ||||
88 | # We need to work for miniperl, because the XS toolchain uses Text::Wrap, which | ||||
89 | # uses re 'taint'. | ||||
90 | |||||
91 | sub _load_unload { | ||||
92 | my ($on)= @_; | ||||
93 | if ($on) { | ||||
94 | # We call install() every time, as if we didn't, we wouldn't | ||||
95 | # "see" any changes to the color environment var since | ||||
96 | # the last time it was called. | ||||
97 | |||||
98 | # install() returns an integer, which if casted properly | ||||
99 | # in C resolves to a structure containing the regexp | ||||
100 | # hooks. Setting it to a random integer will guarantee | ||||
101 | # segfaults. | ||||
102 | $^H{regcomp} = install(); | ||||
103 | } else { | ||||
104 | delete $^H{regcomp}; | ||||
105 | } | ||||
106 | } | ||||
107 | |||||
108 | # spent 35µs within re::bits which was called:
# once (35µs+0s) by re::import at line 219 | ||||
109 | 7 | 45µs | my $on = shift; | ||
110 | my $bits = 0; | ||||
111 | unless (@_) { | ||||
112 | require Carp; | ||||
113 | Carp::carp("Useless use of \"re\" pragma"); | ||||
114 | } | ||||
115 | ARG: | ||||
116 | foreach my $idx (0..$#_){ | ||||
117 | my $s=$_[$idx]; | ||||
118 | if ($s eq 'Debug' or $s eq 'Debugcolor') { | ||||
119 | setcolor() if $s =~/color/i; | ||||
120 | ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; | ||||
121 | for my $idx ($idx+1..$#_) { | ||||
122 | if ($flags{$_[$idx]}) { | ||||
123 | if ($on) { | ||||
124 | ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]}; | ||||
125 | } else { | ||||
126 | ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]}; | ||||
127 | } | ||||
128 | } else { | ||||
129 | require Carp; | ||||
130 | Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ", | ||||
131 | join(", ",sort keys %flags ) ); | ||||
132 | } | ||||
133 | } | ||||
134 | _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS}); | ||||
135 | last; | ||||
136 | } elsif ($s eq 'debug' or $s eq 'debugcolor') { | ||||
137 | setcolor() if $s =~/color/i; | ||||
138 | _load_unload($on); | ||||
139 | last; | ||||
140 | } elsif (exists $bitmask{$s}) { | ||||
141 | $bits |= $bitmask{$s}; | ||||
142 | } elsif ($EXPORT_OK{$s}) { | ||||
143 | require Exporter; | ||||
144 | re->export_to_level(2, 're', $s); | ||||
145 | } elsif ($s =~ s/^\///) { | ||||
146 | my $reflags = $^H{reflags} || 0; | ||||
147 | my $seen_charset; | ||||
148 | while ($s =~ m/( . )/gx) { | ||||
149 | $_ = $1; | ||||
150 | if (/[adul]/) { | ||||
151 | # The 'a' may be repeated; hide this from the rest of the | ||||
152 | # code by counting and getting rid of all of them, then | ||||
153 | # changing to 'aa' if there is a repeat. | ||||
154 | if ($_ eq 'a') { | ||||
155 | my $sav_pos = pos $s; | ||||
156 | my $a_count = $s =~ s/a//g; | ||||
157 | pos $s = $sav_pos - 1; # -1 because got rid of the 'a' | ||||
158 | if ($a_count > 2) { | ||||
159 | require Carp; | ||||
160 | Carp::carp( | ||||
161 | qq 'The "a" flag may only appear a maximum of twice' | ||||
162 | ); | ||||
163 | } | ||||
164 | elsif ($a_count == 2) { | ||||
165 | $_ = 'aa'; | ||||
166 | } | ||||
167 | } | ||||
168 | if ($on) { | ||||
169 | if ($seen_charset) { | ||||
170 | require Carp; | ||||
171 | if ($seen_charset ne $_) { | ||||
172 | Carp::carp( | ||||
173 | qq 'The "$seen_charset" and "$_" flags ' | ||||
174 | .qq 'are exclusive' | ||||
175 | ); | ||||
176 | } | ||||
177 | else { | ||||
178 | Carp::carp( | ||||
179 | qq 'The "$seen_charset" flag may not appear ' | ||||
180 | .qq 'twice' | ||||
181 | ); | ||||
182 | } | ||||
183 | } | ||||
184 | $^H{reflags_charset} = $reflags{$_}; | ||||
185 | $seen_charset = $_; | ||||
186 | } | ||||
187 | else { | ||||
188 | delete $^H{reflags_charset} | ||||
189 | if defined $^H{reflags_charset} | ||||
190 | && $^H{reflags_charset} == $reflags{$_}; | ||||
191 | } | ||||
192 | } elsif (exists $reflags{$_}) { | ||||
193 | $on | ||||
194 | ? $reflags |= $reflags{$_} | ||||
195 | : ($reflags &= ~$reflags{$_}); | ||||
196 | } else { | ||||
197 | require Carp; | ||||
198 | Carp::carp( | ||||
199 | qq'Unknown regular expression flag "$_"' | ||||
200 | ); | ||||
201 | next ARG; | ||||
202 | } | ||||
203 | } | ||||
204 | ($^H{reflags} = $reflags or defined $^H{reflags_charset}) | ||||
205 | ? $^H |= $flags_hint | ||||
206 | : ($^H &= ~$flags_hint); | ||||
207 | } else { | ||||
208 | require Carp; | ||||
209 | Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", | ||||
210 | join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask), | ||||
211 | ")"); | ||||
212 | } | ||||
213 | } | ||||
214 | $bits; | ||||
215 | } | ||||
216 | |||||
217 | # spent 67µs (33+35) within re::import which was called:
# once (33µs+35µs) by B::Deparse::BEGIN@3436 at line 3436 of B/Deparse.pm | ||||
218 | 2 | 26µs | shift; | ||
219 | 1 | 35µs | $^H |= bits(1, @_); # spent 35µs making 1 call to re::bits | ||
220 | } | ||||
221 | |||||
222 | sub unimport { | ||||
223 | shift; | ||||
224 | $^H &= ~ bits(0, @_); | ||||
225 | } | ||||
226 | |||||
227 | 1 | 94µs | 1; | ||
228 | |||||
229 | __END__ |