← Index
NYTProf Performance Profile   « block view • line view • sub view »
For -e
  Run on Sun Aug 5 15:24:32 2012
Reported on Sun Aug 5 15:24:57 2012

Filename/usr/lib/perl5/5.12.4/warnings.pm
StatementsExecuted 270 statements in 2.99ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1717171.72ms1.72mswarnings::::importwarnings::import
444344µs344µswarnings::::unimportwarnings::unimport
11168µs68µswarnings::::CORE:regcompwarnings::CORE:regcomp (opcode)
11126µs26µswarnings::::CORE:matchwarnings::CORE:match (opcode)
0000s0swarnings::::Croakerwarnings::Croaker
0000s0swarnings::::__chkwarnings::__chk
0000s0swarnings::::_error_locwarnings::_error_loc
0000s0swarnings::::bitswarnings::bits
0000s0swarnings::::enabledwarnings::enabled
0000s0swarnings::::fatal_enabledwarnings::fatal_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.09';
10
11# Verify that we're called correctly so that warnings will work.
12# see also strict.pm.
131186µs295µsunless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
# spent 68µs making 1 call to warnings::CORE:regcomp # spent 26µs making 1 call to warnings::CORE:match
14 my (undef, $f, $l) = caller;
15 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
16}
17
18=head1 NAME
19
20warnings - Perl pragma to control optional warnings
21
22=head1 SYNOPSIS
23
24 use warnings;
25 no warnings;
26
27 use warnings "all";
28 no warnings "all";
29
30 use warnings::register;
31 if (warnings::enabled()) {
32 warnings::warn("some warning");
33 }
34
35 if (warnings::enabled("void")) {
36 warnings::warn("void", "some warning");
37 }
38
39 if (warnings::enabled($object)) {
40 warnings::warn($object, "some warning");
41 }
42
43 warnings::warnif("some warning");
44 warnings::warnif("void", "some warning");
45 warnings::warnif($object, "some warning");
46
47=head1 DESCRIPTION
48
49The C<warnings> pragma is a replacement for the command line flag C<-w>,
50but the pragma is limited to the enclosing block, while the flag is global.
51See L<perllexwarn> for more information.
52
53If no import list is supplied, all possible warnings are either enabled
54or disabled.
55
56A number of functions are provided to assist module authors.
57
58=over 4
59
60=item use warnings::register
61
62Creates a new warnings category with the same name as the package where
63the call to the pragma is used.
64
65=item warnings::enabled()
66
67Use the warnings category with the same name as the current package.
68
69Return TRUE if that warnings category is enabled in the calling module.
70Otherwise returns FALSE.
71
72=item warnings::enabled($category)
73
74Return TRUE if the warnings category, C<$category>, is enabled in the
75calling module.
76Otherwise returns FALSE.
77
78=item warnings::enabled($object)
79
80Use the name of the class for the object reference, C<$object>, as the
81warnings category.
82
83Return TRUE if that warnings category is enabled in the first scope
84where the object is used.
85Otherwise returns FALSE.
86
87=item warnings::fatal_enabled()
88
89Return TRUE if the warnings category with the same name as the current
90package has been set to FATAL in the calling module.
91Otherwise returns FALSE.
92
93=item warnings::fatal_enabled($category)
94
95Return TRUE if the warnings category C<$category> has been set to FATAL in
96the calling module.
97Otherwise returns FALSE.
98
99=item warnings::fatal_enabled($object)
100
101Use the name of the class for the object reference, C<$object>, as the
102warnings category.
103
104Return TRUE if that warnings category has been set to FATAL in the first
105scope where the object is used.
106Otherwise returns FALSE.
107
108=item warnings::warn($message)
109
110Print C<$message> to STDERR.
111
112Use the warnings category with the same name as the current package.
113
114If that warnings category has been set to "FATAL" in the calling module
115then die. Otherwise return.
116
117=item warnings::warn($category, $message)
118
119Print C<$message> to STDERR.
120
121If the warnings category, C<$category>, has been set to "FATAL" in the
122calling module then die. Otherwise return.
123
124=item warnings::warn($object, $message)
125
126Print C<$message> to STDERR.
127
128Use the name of the class for the object reference, C<$object>, as the
129warnings category.
130
131If that warnings category has been set to "FATAL" in the scope where C<$object>
132is first used then die. Otherwise return.
133
134
135=item warnings::warnif($message)
136
137Equivalent to:
138
139 if (warnings::enabled())
140 { warnings::warn($message) }
141
142=item warnings::warnif($category, $message)
143
144Equivalent to:
145
146 if (warnings::enabled($category))
147 { warnings::warn($category, $message) }
148
149=item warnings::warnif($object, $message)
150
151Equivalent to:
152
153 if (warnings::enabled($object))
154 { warnings::warn($object, $message) }
155
156=back
157
158See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
159
160=cut
161
162166µsour %Offsets = (
163
164 # Warnings Categories added in Perl 5.008
165
166 'all' => 0,
167 'closure' => 2,
168 'deprecated' => 4,
169 'exiting' => 6,
170 'glob' => 8,
171 'io' => 10,
172 'closed' => 12,
173 'exec' => 14,
174 'layer' => 16,
175 'newline' => 18,
176 'pipe' => 20,
177 'unopened' => 22,
178 'misc' => 24,
179 'numeric' => 26,
180 'once' => 28,
181 'overflow' => 30,
182 'pack' => 32,
183 'portable' => 34,
184 'recursion' => 36,
185 'redefine' => 38,
186 'regexp' => 40,
187 'severe' => 42,
188 'debugging' => 44,
189 'inplace' => 46,
190 'internal' => 48,
191 'malloc' => 50,
192 'signal' => 52,
193 'substr' => 54,
194 'syntax' => 56,
195 'ambiguous' => 58,
196 'bareword' => 60,
197 'digit' => 62,
198 'parenthesis' => 64,
199 'precedence' => 66,
200 'printf' => 68,
201 'prototype' => 70,
202 'qw' => 72,
203 'reserved' => 74,
204 'semicolon' => 76,
205 'taint' => 78,
206 'threads' => 80,
207 'uninitialized' => 82,
208 'unpack' => 84,
209 'untie' => 86,
210 'utf8' => 88,
211 'void' => 90,
212
213 # Warnings Categories added in Perl 5.011
214
215 'imprecision' => 92,
216 'illegalproto' => 94,
217 );
218
219164µsour %Bits = (
220 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
221 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
222 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
223 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
224 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
225 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
226 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
227 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
228 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
229 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
230 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
231 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
232 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
233 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
234 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
235 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
236 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
237 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
238 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
239 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
240 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
241 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
242 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
243 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
244 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
245 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
246 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
247 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
248 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
249 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
250 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
251 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
252 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
253 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
254 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
255 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
256 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
257 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
258 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
259 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
260 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
261 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
262 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
263 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
264 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
265 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
266 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
267 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
268 );
269
270159µsour %DeadBits = (
271 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
272 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
273 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
274 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
275 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
276 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
277 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
278 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
279 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
280 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
281 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
282 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
283 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
284 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
285 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
286 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
287 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
288 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
289 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
290 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
291 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
292 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
293 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
294 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
295 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
296 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
297 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
298 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
299 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
300 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
301 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
302 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
303 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
304 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
305 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
306 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
307 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
308 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
309 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
310 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
311 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
312 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
313 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
314 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
315 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
316 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
317 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
318 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
319 );
320
32115µs$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
32214µs$LAST_BIT = 96 ;
32314µs$BYTES = 12 ;
324
325247µs$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
326
327sub Croaker
328{
329 require Carp; # this initializes %CarpInternal
330 local $Carp::CarpInternal{'warnings'};
331 delete $Carp::CarpInternal{'warnings'};
332 Carp::croak(@_);
333}
334
335sub bits
336{
337 # called from B::Deparse.pm
338
339 push @_, 'all' unless @_;
340
341 my $mask;
342 my $catmask ;
343 my $fatal = 0 ;
344 my $no_fatal = 0 ;
345
346 foreach my $word ( @_ ) {
347 if ($word eq 'FATAL') {
348 $fatal = 1;
349 $no_fatal = 0;
350 }
351 elsif ($word eq 'NONFATAL') {
352 $fatal = 0;
353 $no_fatal = 1;
354 }
355 elsif ($catmask = $Bits{$word}) {
356 $mask |= $catmask ;
357 $mask |= $DeadBits{$word} if $fatal ;
358 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
359 }
360 else
361 { Croaker("Unknown warnings category '$word'")}
362 }
363
364 return $mask ;
365}
366
367sub import
368
# spent 1.72ms within warnings::import which was called 17 times, avg 101µs/call: # once (164µs+0s) by DateTime::TimeZone::BEGIN@6 at line 6 of DateTime/TimeZone.pm # once (116µs+0s) by DateTime::BEGIN@9 at line 9 of DateTime.pm # once (112µs+0s) by DateTime::Locale::Base::BEGIN@4 at line 4 of DateTime/Locale/Base.pm # once (110µs+0s) by DateTime::Locale::en::BEGIN@22 at line 22 of DateTime/Locale/en.pm # once (107µs+0s) by DateTime::Helpers::BEGIN@7 at line 7 of DateTime/Helpers.pm # once (100µs+0s) by DateTime::Infinite::BEGIN@7 at line 7 of DateTime/Infinite.pm # once (96µs+0s) by DateTime::Locale::BEGIN@4 at line 4 of DateTime/Locale.pm # once (95µs+0s) by Params::Validate::XS::BEGIN@4 at line 4 of Params/Validate/XS.pm # once (93µs+0s) by POSIX::BEGIN@3 at line 3 of POSIX.pm # once (93µs+0s) by DateTime::Locale::Catalog::BEGIN@18 at line 18 of DateTime/Locale/Catalog.pm # once (92µs+0s) by DateTime::TimeZone::Local::BEGIN@4 at line 4 of DateTime/TimeZone/Local.pm # once (92µs+0s) by DateTime::Locale::en_US::BEGIN@22 at line 22 of DateTime/Locale/en_US.pm # once (92µs+0s) by Params::Validate::BEGIN@9 at line 9 of Params/Validate.pm # once (91µs+0s) by DateTime::Duration::BEGIN@7 at line 7 of DateTime/Duration.pm # once (90µs+0s) by Params::Validate::Constants::BEGIN@4 at line 4 of Params/Validate/Constants.pm # once (88µs+0s) by DateTime::Locale::root::BEGIN@22 at line 22 of DateTime/Locale/root.pm # once (87µs+0s) by Module::Implementation::BEGIN@7 at line 7 of Module/Implementation.pm
{
3691753µs shift;
370
3711740µs my $catmask ;
3721773µs my $fatal = 0 ;
3731739µs my $no_fatal = 0 ;
374
37517132µs my $mask = ${^WARNING_BITS} ;
376
37717143µs if (vec($mask, $Offsets{'all'}, 1)) {
378 $mask |= $Bits{'all'} ;
379 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
380 }
381
38217135µs push @_, 'all' unless @_;
383
38417162µs foreach my $word ( @_ ) {
38517338µs if ($word eq 'FATAL') {
386 $fatal = 1;
387 $no_fatal = 0;
388 }
389 elsif ($word eq 'NONFATAL') {
390 $fatal = 0;
391 $no_fatal = 1;
392 }
393 elsif ($catmask = $Bits{$word}) {
39417100µs $mask |= $catmask ;
3951738µs $mask |= $DeadBits{$word} if $fatal ;
3961752µs $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
397 }
398 else
399 { Croaker("Unknown warnings category '$word'")}
400 }
401
40217664µs ${^WARNING_BITS} = $mask ;
403}
404
405sub unimport
406
# spent 344µs within warnings::unimport which was called 4 times, avg 86µs/call: # once (97µs+0s) by Module::Implementation::BEGIN@114 at line 114 of Module/Implementation.pm # once (91µs+0s) by POSIX::BEGIN@40 at line 40 of POSIX.pm # once (80µs+0s) by Exporter::Heavy::BEGIN@197 at line 197 of Exporter/Heavy.pm # once (76µs+0s) by Carp::BEGIN@304 at line 304 of Carp.pm
{
407414µs shift;
408
40949µs my $catmask ;
410443µs my $mask = ${^WARNING_BITS} ;
411
412434µs if (vec($mask, $Offsets{'all'}, 1)) {
413212µs $mask |= $Bits{'all'} ;
414213µs $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
415 }
416
417410µs push @_, 'all' unless @_;
418
419435µs foreach my $word ( @_ ) {
420488µs if ($word eq 'FATAL') {
421 next;
422 }
423 elsif ($catmask = $Bits{$word}) {
424 $mask &= ~($catmask | $DeadBits{$word} | $All);
425 }
426 else
427 { Croaker("Unknown warnings category '$word'")}
428 }
429
4304145µs ${^WARNING_BITS} = $mask ;
431}
432
433218µsmy %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
434
435sub __chk
436{
437 my $category ;
438 my $offset ;
439 my $isobj = 0 ;
440
441 if (@_) {
442 # check the category supplied.
443 $category = shift ;
444 if (my $type = ref $category) {
445 Croaker("not an object")
446 if exists $builtin_type{$type};
447 $category = $type;
448 $isobj = 1 ;
449 }
450 $offset = $Offsets{$category};
451 Croaker("Unknown warnings category '$category'")
452 unless defined $offset;
453 }
454 else {
455 $category = (caller(1))[0] ;
456 $offset = $Offsets{$category};
457 Croaker("package '$category' not registered for warnings")
458 unless defined $offset ;
459 }
460
461 my $this_pkg = (caller(1))[0] ;
462 my $i = 2 ;
463 my $pkg ;
464
465 if ($isobj) {
466 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
467 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
468 }
469 $i -= 2 ;
470 }
471 else {
472 $i = _error_loc(); # see where Carp will allocate the error
473 }
474
475 my $callers_bitmask = (caller($i))[9] ;
476 return ($callers_bitmask, $offset, $i) ;
477}
478
479sub _error_loc {
480 require Carp;
481 goto &Carp::short_error_loc; # don't introduce another stack frame
482}
483
484sub enabled
485{
486 Croaker("Usage: warnings::enabled([category])")
487 unless @_ == 1 || @_ == 0 ;
488
489 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
490
491 return 0 unless defined $callers_bitmask ;
492 return vec($callers_bitmask, $offset, 1) ||
493 vec($callers_bitmask, $Offsets{'all'}, 1) ;
494}
495
496sub fatal_enabled
497{
498 Croaker("Usage: warnings::fatal_enabled([category])")
499 unless @_ == 1 || @_ == 0 ;
500
501 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
502
503 return 0 unless defined $callers_bitmask;
504 return vec($callers_bitmask, $offset + 1, 1) ||
505 vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
506}
507
508sub warn
509{
510 Croaker("Usage: warnings::warn([category,] 'message')")
511 unless @_ == 2 || @_ == 1 ;
512
513 my $message = pop ;
514 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
515 require Carp;
516 Carp::croak($message)
517 if vec($callers_bitmask, $offset+1, 1) ||
518 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
519 Carp::carp($message) ;
520}
521
522sub warnif
523{
524 Croaker("Usage: warnings::warnif([category,] 'message')")
525 unless @_ == 2 || @_ == 1 ;
526
527 my $message = pop ;
528 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
529
530 return
531 unless defined $callers_bitmask &&
532 (vec($callers_bitmask, $offset, 1) ||
533 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
534
535 require Carp;
536 Carp::croak($message)
537 if vec($callers_bitmask, $offset+1, 1) ||
538 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
539
540 Carp::carp($message) ;
541}
542
5431164µs1;
544# ex: set ro:
 
# spent 26µs within warnings::CORE:match which was called: # once (26µs+0s) by DateTime::BEGIN@9 at line 13
sub warnings::CORE:match; # opcode
# spent 68µs within warnings::CORE:regcomp which was called: # once (68µs+0s) by DateTime::BEGIN@9 at line 13
sub warnings::CORE:regcomp; # opcode