← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:57:00 2010

File /usr/local/lib/perl5/5.8.8/warnings.pm
Statements Executed 525
Statement Execution Time 9.00ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
3232313.82ms3.82mswarnings::::importwarnings::import
333291µs291µswarnings::::unimportwarnings::unimport
0000s0swarnings::::BEGINwarnings::BEGIN
0000s0swarnings::::Croakerwarnings::Croaker
0000s0swarnings::::__chkwarnings::__chk
0000s0swarnings::::bitswarnings::bits
0000s0swarnings::::enabledwarnings::enabled
0000s0swarnings::::warnwarnings::warn
0000s0swarnings::::warnifwarnings::warnif
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# -*- buffer-read-only: t -*-
2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
3# This file was created by warnings.pl
4# Any changes made here will be lost.
5#
6
7package warnings;
8
916µsour $VERSION = '1.05';
10
11=head1 NAME
12
13warnings - Perl pragma to control optional warnings
14
15=head1 SYNOPSIS
16
17 use warnings;
18 no warnings;
19
20 use warnings "all";
21 no warnings "all";
22
23 use warnings::register;
24 if (warnings::enabled()) {
25 warnings::warn("some warning");
26 }
27
28 if (warnings::enabled("void")) {
29 warnings::warn("void", "some warning");
30 }
31
32 if (warnings::enabled($object)) {
33 warnings::warn($object, "some warning");
34 }
35
36 warnings::warnif("some warning");
37 warnings::warnif("void", "some warning");
38 warnings::warnif($object, "some warning");
39
40=head1 DESCRIPTION
41
42The C<warnings> pragma is a replacement for the command line flag C<-w>,
43but the pragma is limited to the enclosing block, while the flag is global.
44See L<perllexwarn> for more information.
45
46If no import list is supplied, all possible warnings are either enabled
47or disabled.
48
49A number of functions are provided to assist module authors.
50
51=over 4
52
53=item use warnings::register
54
55Creates a new warnings category with the same name as the package where
56the call to the pragma is used.
57
58=item warnings::enabled()
59
60Use the warnings category with the same name as the current package.
61
62Return TRUE if that warnings category is enabled in the calling module.
63Otherwise returns FALSE.
64
65=item warnings::enabled($category)
66
67Return TRUE if the warnings category, C<$category>, is enabled in the
68calling module.
69Otherwise returns FALSE.
70
71=item warnings::enabled($object)
72
73Use the name of the class for the object reference, C<$object>, as the
74warnings category.
75
76Return TRUE if that warnings category is enabled in the first scope
77where the object is used.
78Otherwise returns FALSE.
79
80=item warnings::warn($message)
81
82Print C<$message> to STDERR.
83
84Use the warnings category with the same name as the current package.
85
86If that warnings category has been set to "FATAL" in the calling module
87then die. Otherwise return.
88
89=item warnings::warn($category, $message)
90
91Print C<$message> to STDERR.
92
93If the warnings category, C<$category>, has been set to "FATAL" in the
94calling module then die. Otherwise return.
95
96=item warnings::warn($object, $message)
97
98Print C<$message> to STDERR.
99
100Use the name of the class for the object reference, C<$object>, as the
101warnings category.
102
103If that warnings category has been set to "FATAL" in the scope where C<$object>
104is first used then die. Otherwise return.
105
106
107=item warnings::warnif($message)
108
109Equivalent to:
110
111 if (warnings::enabled())
112 { warnings::warn($message) }
113
114=item warnings::warnif($category, $message)
115
116Equivalent to:
117
118 if (warnings::enabled($category))
119 { warnings::warn($category, $message) }
120
121=item warnings::warnif($object, $message)
122
123Equivalent to:
124
125 if (warnings::enabled($object))
126 { warnings::warn($object, $message) }
127
128=back
129
130See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
131
132=cut
133
13434.20msuse Carp ();
135
136147µsour %Offsets = (
137
138 # Warnings Categories added in Perl 5.008
139
140 'all' => 0,
141 'closure' => 2,
142 'deprecated' => 4,
143 'exiting' => 6,
144 'glob' => 8,
145 'io' => 10,
146 'closed' => 12,
147 'exec' => 14,
148 'layer' => 16,
149 'newline' => 18,
150 'pipe' => 20,
151 'unopened' => 22,
152 'misc' => 24,
153 'numeric' => 26,
154 'once' => 28,
155 'overflow' => 30,
156 'pack' => 32,
157 'portable' => 34,
158 'recursion' => 36,
159 'redefine' => 38,
160 'regexp' => 40,
161 'severe' => 42,
162 'debugging' => 44,
163 'inplace' => 46,
164 'internal' => 48,
165 'malloc' => 50,
166 'signal' => 52,
167 'substr' => 54,
168 'syntax' => 56,
169 'ambiguous' => 58,
170 'bareword' => 60,
171 'digit' => 62,
172 'parenthesis' => 64,
173 'precedence' => 66,
174 'printf' => 68,
175 'prototype' => 70,
176 'qw' => 72,
177 'reserved' => 74,
178 'semicolon' => 76,
179 'taint' => 78,
180 'threads' => 80,
181 'uninitialized' => 82,
182 'unpack' => 84,
183 'untie' => 86,
184 'utf8' => 88,
185 'void' => 90,
186 'y2k' => 92,
187 );
188
189134µsour %Bits = (
190 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
191 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
192 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
193 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
194 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
195 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
196 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
197 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
198 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
199 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
200 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
201 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
202 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
203 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
204 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
205 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
206 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
207 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
208 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
209 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
210 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
211 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
212 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
213 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
214 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
215 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
216 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
217 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
218 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
219 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
220 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
221 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
222 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
223 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
224 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
225 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
226 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
227 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
228 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
229 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
230 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
231 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
232 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
233 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
234 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
235 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
236 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
237 );
238
239130µsour %DeadBits = (
240 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
241 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
242 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
243 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
244 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
245 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
246 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
247 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
248 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
249 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
250 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
251 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
252 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
253 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
254 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
255 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
256 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
257 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
258 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
259 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
260 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
261 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
262 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
263 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
264 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
265 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
266 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
267 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
268 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
269 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
270 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
271 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
272 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
273 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
274 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
275 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
276 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
277 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
278 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
279 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
280 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
281 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
282 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
283 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
284 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
285 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
286 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
287 );
288
28915µs$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
29015µs$LAST_BIT = 94 ;
29114µs$BYTES = 12 ;
292
293225µs$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
294
295sub Croaker
296{
297 local $Carp::CarpInternal{'warnings'};
298 delete $Carp::CarpInternal{'warnings'};
299 Carp::croak(@_);
300}
301
302sub bits
303{
304 # called from B::Deparse.pm
305
306 push @_, 'all' unless @_;
307
308 my $mask;
309 my $catmask ;
310 my $fatal = 0 ;
311 my $no_fatal = 0 ;
312
313 foreach my $word ( @_ ) {
314 if ($word eq 'FATAL') {
315 $fatal = 1;
316 $no_fatal = 0;
317 }
318 elsif ($word eq 'NONFATAL') {
319 $fatal = 0;
320 $no_fatal = 1;
321 }
322 elsif ($catmask = $Bits{$word}) {
323 $mask |= $catmask ;
324 $mask |= $DeadBits{$word} if $fatal ;
325 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
326 }
327 else
328 { Croaker("Unknown warnings category '$word'")}
329 }
330
331 return $mask ;
332}
333
334sub import
335
# spent 3.82ms within warnings::import which was called 32 times, avg 119µs/call: # once (218µs+0s) by Net::HTTP::Methods::zlib_ok at line 4 of File/GlobMapper.pm # once (138µs+0s) by Class::DBI::_require_class at line 80 of Class/DBI/Search/Basic.pm # once (131µs+0s) by base::import at line 3 of SQL/Abstract/Limit.pm # once (123µs+0s) by WWW::Google::PageRank::BEGIN at line 6 of WWW/Google/PageRank.pm # once (121µs+0s) by Net::HTTP::Methods::zlib_ok at line 4 of IO/Compress/Base/Common.pm # once (120µs+0s) by DBI::_load_class at line 6 of DBIx/ContextualFetch.pm # once (120µs+0s) by base::import at line 4 of Class/DBI/Relationship.pm # once (119µs+0s) by Net::HTTP::Methods::zlib_ok at line 4 of IO/Compress/Gzip/Constants.pm # once (119µs+0s) by base::import at line 6 of Class/DBI/Plugin/RetrieveAll.pm # once (118µs+0s) by Class::DBI::_require_class at line 4 of Class/DBI/SQL/Transformer.pm # once (118µs+0s) by Net::HTTP::Methods::zlib_ok at line 498 of IO/Compress/Base/Common.pm # once (118µs+0s) by DBI::install_driver at line 14 of DBD/Pg.pm # once (117µs+0s) by Net::HTTP::Methods::zlib_ok at line 7 of IO/Compress/Gzip.pm # once (117µs+0s) by Net::HTTP::Methods::zlib_ok at line 4 of IO/Compress/Adapter/Deflate.pm # once (117µs+0s) by Class::DBI::_require_class at line 4 of Class/DBI/Relationship/HasMany.pm # once (116µs+0s) by base::import at line 59 of Class/DBI/Cascade/None.pm # once (115µs+0s) by base::import at line 3 of Class/DBI/Plugin/Pager.pm # once (114µs+0s) by Net::HTTP::Methods::zlib_ok at line 6 of IO/Compress/Zlib/Extra.pm # once (114µs+0s) by Net::HTTP::Methods::zlib_ok at line 5 of IO/Uncompress/RawInflate.pm # once (114µs+0s) by Class::DBI::_require_class at line 15 of Class/DBI/Cascade/Delete.pm # once (114µs+0s) by Class::DBI::_require_class at line 4 of Class/DBI/Relationship/MightHave.pm # once (113µs+0s) by Class::DBI::_require_class at line 4 of Class/DBI/Relationship/HasA.pm # once (113µs+0s) by Net::HTTP::Methods::zlib_ok at line 6 of IO/Compress/RawDeflate.pm # once (113µs+0s) by base::import at line 8 of IO.pm # once (112µs+0s) by Net::HTTP::Methods::zlib_ok at line 4 of IO/Uncompress/Adapter/Inflate.pm # once (112µs+0s) by base::import at line 13 of Class/DBI.pm # once (111µs+0s) by base::import at line 5 of K2/DB2.pm # once (111µs+0s) by Net::HTTP::Methods::zlib_ok at line 17 of Compress/Zlib.pm # once (111µs+0s) by Net::HTTP::Methods::zlib_ok at line 12 of Compress/Raw/Zlib.pm # once (110µs+0s) by Net::HTTP::Methods::zlib_ok at line 5 of IO/Uncompress/Base.pm # once (109µs+0s) by Net::HTTP::Methods::zlib_ok at line 7 of IO/Compress/Base.pm # once (108µs+0s) by Net::HTTP::Methods::zlib_ok at line 9 of IO/Uncompress/Gunzip.pm
{
33632145µs shift;
337
33832140µs my $catmask ;
33932162µs my $fatal = 0 ;
34032133µs my $no_fatal = 0 ;
341
34232205µs my $mask = ${^WARNING_BITS} ;
343
34432386µs if (vec($mask, $Offsets{'all'}, 1)) {
34532223µs $mask |= $Bits{'all'} ;
34632199µs $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
347 }
348
34932236µs push @_, 'all' unless @_;
350
35132340µs foreach my $word ( @_ ) {
35232560µs if ($word eq 'FATAL') {
353 $fatal = 1;
354 $no_fatal = 0;
355 }
356 elsif ($word eq 'NONFATAL') {
357 $fatal = 0;
358 $no_fatal = 1;
359 }
360 elsif ($catmask = $Bits{$word}) {
36132144µs $mask |= $catmask ;
36232137µs $mask |= $DeadBits{$word} if $fatal ;
36332234µs $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
364 }
365 else
366 { Croaker("Unknown warnings category '$word'")}
367 }
368
36932994µs ${^WARNING_BITS} = $mask ;
370}
371
372sub unimport
373
# spent 291µs within warnings::unimport which was called 3 times, avg 97µs/call: # once (101µs+0s) by Net::HTTP::Methods::zlib_ok at line 341 of File/GlobMapper.pm # once (98µs+0s) by Net::HTTP::Methods::zlib_ok at line 84 of IO/Uncompress/Base.pm # once (92µs+0s) by DBI::_load_class at line 7 of DBIx/ContextualFetch.pm
{
374313µs shift;
375
376313µs my $catmask ;
377333µs my $mask = ${^WARNING_BITS} ;
378
379334µs if (vec($mask, $Offsets{'all'}, 1)) {
380322µs $mask |= $Bits{'all'} ;
381318µs $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
382 }
383
384316µs push @_, 'all' unless @_;
385
386333µs foreach my $word ( @_ ) {
387355µs if ($word eq 'FATAL') {
388 next;
389 }
390 elsif ($catmask = $Bits{$word}) {
391 $mask &= ~($catmask | $DeadBits{$word} | $All);
392 }
393 else
394 { Croaker("Unknown warnings category '$word'")}
395 }
396
397385µs ${^WARNING_BITS} = $mask ;
398}
399
400216µsmy %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
401
402sub __chk
403{
404 my $category ;
405 my $offset ;
406 my $isobj = 0 ;
407
408 if (@_) {
409 # check the category supplied.
410 $category = shift ;
411 if (my $type = ref $category) {
412 Croaker("not an object")
413 if exists $builtin_type{$type};
414 $category = $type;
415 $isobj = 1 ;
416 }
417 $offset = $Offsets{$category};
418 Croaker("Unknown warnings category '$category'")
419 unless defined $offset;
420 }
421 else {
422 $category = (caller(1))[0] ;
423 $offset = $Offsets{$category};
424 Croaker("package '$category' not registered for warnings")
425 unless defined $offset ;
426 }
427
428 my $this_pkg = (caller(1))[0] ;
429 my $i = 2 ;
430 my $pkg ;
431
432 if ($isobj) {
433 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
434 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
435 }
436 $i -= 2 ;
437 }
438 else {
439 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
440 last if $pkg ne $this_pkg ;
441 }
442 $i = 2
443 if !$pkg || $pkg eq $this_pkg ;
444 }
445
446 my $callers_bitmask = (caller($i))[9] ;
447 return ($callers_bitmask, $offset, $i) ;
448}
449
450sub enabled
451{
452 Croaker("Usage: warnings::enabled([category])")
453 unless @_ == 1 || @_ == 0 ;
454
455 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
456
457 return 0 unless defined $callers_bitmask ;
458 return vec($callers_bitmask, $offset, 1) ||
459 vec($callers_bitmask, $Offsets{'all'}, 1) ;
460}
461
462
463sub warn
464{
465 Croaker("Usage: warnings::warn([category,] 'message')")
466 unless @_ == 2 || @_ == 1 ;
467
468 my $message = pop ;
469 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
470 Carp::croak($message)
471 if vec($callers_bitmask, $offset+1, 1) ||
472 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
473 Carp::carp($message) ;
474}
475
476sub warnif
477{
478 Croaker("Usage: warnings::warnif([category,] 'message')")
479 unless @_ == 2 || @_ == 1 ;
480
481 my $message = pop ;
482 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
483
484 return
485 unless defined $callers_bitmask &&
486 (vec($callers_bitmask, $offset, 1) ||
487 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
488
489 Carp::croak($message)
490 if vec($callers_bitmask, $offset+1, 1) ||
491 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
492
493 Carp::carp($message) ;
494}
495
496168µs1;
497# ex: set ro:
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.