← Index
NYTProf Performance Profile   « line view »
For Makefile.PL
  Run on Sun Mar 1 16:04:44 2015
Reported on Sun Mar 1 16:09:01 2015

FilenameC:/tmp64ng/perl/lib/warnings.pm
StatementsExecuted 776 statements in 0s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110s0swarnings::::CORE:matchwarnings::CORE:match (opcode)
1110s0swarnings::::CORE:regcompwarnings::CORE:regcomp (opcode)
0000s0swarnings::::Croakerwarnings::Croaker
0000s0swarnings::::__chkwarnings::__chk
2110s0swarnings::::_bitswarnings::_bits
0000s0swarnings::::_error_locwarnings::_error_loc
10210s0swarnings::::_mkMaskwarnings::_mkMask
0000s0swarnings::::bitswarnings::bits
0000s0swarnings::::enabledwarnings::enabled
0000s0swarnings::::fatal_enabledwarnings::fatal_enabled
3333310s0swarnings::::importwarnings::import
6220s0swarnings::::register_categorieswarnings::register_categories
1818130s0swarnings::::unimportwarnings::unimport
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 is built by regen/warnings.pl.
4# Any changes made here will be lost!
5
6package warnings;
7
810sour $VERSION = '1.23';
9
10# Verify that we're called correctly so that warnings will work.
11# see also strict.pm.
1210s20sunless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
# spent 0s making 1 call to warnings::CORE:match # spent 0s making 1 call to warnings::CORE:regcomp
13 my (undef, $f, $l) = caller;
14 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
15}
16
17=head1 NAME
18
19warnings - Perl pragma to control optional warnings
20
21=head1 SYNOPSIS
22
23 use warnings;
24 no warnings;
25
26 use warnings "all";
27 no warnings "all";
28
29 use warnings::register;
30 if (warnings::enabled()) {
31 warnings::warn("some warning");
32 }
33
34 if (warnings::enabled("void")) {
35 warnings::warn("void", "some warning");
36 }
37
38 if (warnings::enabled($object)) {
39 warnings::warn($object, "some warning");
40 }
41
42 warnings::warnif("some warning");
43 warnings::warnif("void", "some warning");
44 warnings::warnif($object, "some warning");
45
46=head1 DESCRIPTION
47
48The C<warnings> pragma gives control over which warnings are enabled in
49which parts of a Perl program. It's a more flexible alternative for
50both the command line flag B<-w> and the equivalent Perl variable,
51C<$^W>.
52
53This pragma works just like the C<strict> pragma.
54This means that the scope of the warning pragma is limited to the
55enclosing block. It also means that the pragma setting will not
56leak across files (via C<use>, C<require> or C<do>). This allows
57authors to independently define the degree of warning checks that will
58be applied to their module.
59
60By default, optional warnings are disabled, so any legacy code that
61doesn't attempt to control the warnings will work unchanged.
62
63All warnings are enabled in a block by either of these:
64
65 use warnings;
66 use warnings 'all';
67
68Similarly all warnings are disabled in a block by either of these:
69
70 no warnings;
71 no warnings 'all';
72
73For example, consider the code below:
74
75 use warnings;
76 my @a;
77 {
78 no warnings;
79 my $b = @a[0];
80 }
81 my $c = @a[0];
82
83The code in the enclosing block has warnings enabled, but the inner
84block has them disabled. In this case that means the assignment to the
85scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
86warning, but the assignment to the scalar C<$b> will not.
87
88=head2 Default Warnings and Optional Warnings
89
90Before the introduction of lexical warnings, Perl had two classes of
91warnings: mandatory and optional.
92
93As its name suggests, if your code tripped a mandatory warning, you
94would get a warning whether you wanted it or not.
95For example, the code below would always produce an C<"isn't numeric">
96warning about the "2:".
97
98 my $a = "2:" + 3;
99
100With the introduction of lexical warnings, mandatory warnings now become
101I<default> warnings. The difference is that although the previously
102mandatory warnings are still enabled by default, they can then be
103subsequently enabled or disabled with the lexical warning pragma. For
104example, in the code below, an C<"isn't numeric"> warning will only
105be reported for the C<$a> variable.
106
107 my $a = "2:" + 3;
108 no warnings;
109 my $b = "2:" + 3;
110
111Note that neither the B<-w> flag or the C<$^W> can be used to
112disable/enable default warnings. They are still mandatory in this case.
113
114=head2 What's wrong with B<-w> and C<$^W>
115
116Although very useful, the big problem with using B<-w> on the command
117line to enable warnings is that it is all or nothing. Take the typical
118scenario when you are writing a Perl program. Parts of the code you
119will write yourself, but it's very likely that you will make use of
120pre-written Perl modules. If you use the B<-w> flag in this case, you
121end up enabling warnings in pieces of code that you haven't written.
122
123Similarly, using C<$^W> to either disable or enable blocks of code is
124fundamentally flawed. For a start, say you want to disable warnings in
125a block of code. You might expect this to be enough to do the trick:
126
127 {
128 local ($^W) = 0;
129 my $a =+ 2;
130 my $b; chop $b;
131 }
132
133When this code is run with the B<-w> flag, a warning will be produced
134for the C<$a> line: C<"Reversed += operator">.
135
136The problem is that Perl has both compile-time and run-time warnings. To
137disable compile-time warnings you need to rewrite the code like this:
138
139 {
140 BEGIN { $^W = 0 }
141 my $a =+ 2;
142 my $b; chop $b;
143 }
144
145The other big problem with C<$^W> is the way you can inadvertently
146change the warning setting in unexpected places in your code. For example,
147when the code below is run (without the B<-w> flag), the second call
148to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
149the first will not.
150
151 sub doit
152 {
153 my $b; chop $b;
154 }
155
156 doit();
157
158 {
159 local ($^W) = 1;
160 doit()
161 }
162
163This is a side-effect of C<$^W> being dynamically scoped.
164
165Lexical warnings get around these limitations by allowing finer control
166over where warnings can or can't be tripped.
167
168=head2 Controlling Warnings from the Command Line
169
170There are three Command Line flags that can be used to control when
171warnings are (or aren't) produced:
172
173=over 5
174
175=item B<-w>
176X<-w>
177
178This is the existing flag. If the lexical warnings pragma is B<not>
179used in any of you code, or any of the modules that you use, this flag
180will enable warnings everywhere. See L<Backward Compatibility> for
181details of how this flag interacts with lexical warnings.
182
183=item B<-W>
184X<-W>
185
186If the B<-W> flag is used on the command line, it will enable all warnings
187throughout the program regardless of whether warnings were disabled
188locally using C<no warnings> or C<$^W =0>.
189This includes all files that get
190included via C<use>, C<require> or C<do>.
191Think of it as the Perl equivalent of the "lint" command.
192
193=item B<-X>
194X<-X>
195
196Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
197
198=back
199
200=head2 Backward Compatibility
201
202If you are used to working with a version of Perl prior to the
203introduction of lexically scoped warnings, or have code that uses both
204lexical warnings and C<$^W>, this section will describe how they interact.
205
206How Lexical Warnings interact with B<-w>/C<$^W>:
207
208=over 5
209
210=item 1.
211
212If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
213control warnings is used and neither C<$^W> nor the C<warnings> pragma
214are used, then default warnings will be enabled and optional warnings
215disabled.
216This means that legacy code that doesn't attempt to control the warnings
217will work unchanged.
218
219=item 2.
220
221The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
222means that any legacy code that currently relies on manipulating C<$^W>
223to control warning behavior will still work as is.
224
225=item 3.
226
227Apart from now being a boolean, the C<$^W> variable operates in exactly
228the same horrible uncontrolled global way, except that it cannot
229disable/enable default warnings.
230
231=item 4.
232
233If a piece of code is under the control of the C<warnings> pragma,
234both the C<$^W> variable and the B<-w> flag will be ignored for the
235scope of the lexical warning.
236
237=item 5.
238
239The only way to override a lexical warnings setting is with the B<-W>
240or B<-X> command line flags.
241
242=back
243
244The combined effect of 3 & 4 is that it will allow code which uses
245the C<warnings> pragma to control the warning behavior of $^W-type
246code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
247
248=head2 Category Hierarchy
249X<warning, categories>
250
251A hierarchy of "categories" have been defined to allow groups of warnings
252to be enabled/disabled in isolation.
253
254The current hierarchy is:
255
256 all -+
257 |
258 +- closure
259 |
260 +- deprecated
261 |
262 +- exiting
263 |
264 +- experimental --+
265 | |
266 | +- experimental::autoderef
267 | |
268 | +- experimental::lexical_subs
269 | |
270 | +- experimental::lexical_topic
271 | |
272 | +- experimental::postderef
273 | |
274 | +- experimental::regex_sets
275 | |
276 | +- experimental::signatures
277 | |
278 | +- experimental::smartmatch
279 |
280 +- glob
281 |
282 +- imprecision
283 |
284 +- io ------------+
285 | |
286 | +- closed
287 | |
288 | +- exec
289 | |
290 | +- layer
291 | |
292 | +- newline
293 | |
294 | +- pipe
295 | |
296 | +- syscalls
297 | |
298 | +- unopened
299 |
300 +- misc
301 |
302 +- numeric
303 |
304 +- once
305 |
306 +- overflow
307 |
308 +- pack
309 |
310 +- portable
311 |
312 +- recursion
313 |
314 +- redefine
315 |
316 +- regexp
317 |
318 +- severe --------+
319 | |
320 | +- debugging
321 | |
322 | +- inplace
323 | |
324 | +- internal
325 | |
326 | +- malloc
327 |
328 +- signal
329 |
330 +- substr
331 |
332 +- syntax --------+
333 | |
334 | +- ambiguous
335 | |
336 | +- bareword
337 | |
338 | +- digit
339 | |
340 | +- illegalproto
341 | |
342 | +- parenthesis
343 | |
344 | +- precedence
345 | |
346 | +- printf
347 | |
348 | +- prototype
349 | |
350 | +- qw
351 | |
352 | +- reserved
353 | |
354 | +- semicolon
355 |
356 +- taint
357 |
358 +- threads
359 |
360 +- uninitialized
361 |
362 +- unpack
363 |
364 +- untie
365 |
366 +- utf8 ----------+
367 | |
368 | +- non_unicode
369 | |
370 | +- nonchar
371 | |
372 | +- surrogate
373 |
374 +- void
375
376Just like the "strict" pragma any of these categories can be combined
377
378 use warnings qw(void redefine);
379 no warnings qw(io syntax untie);
380
381Also like the "strict" pragma, if there is more than one instance of the
382C<warnings> pragma in a given scope the cumulative effect is additive.
383
384 use warnings qw(void); # only "void" warnings enabled
385 ...
386 use warnings qw(io); # only "void" & "io" warnings enabled
387 ...
388 no warnings qw(void); # only "io" warnings enabled
389
390To determine which category a specific warning has been assigned to see
391L<perldiag>.
392
393Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
394sub-category of the "syntax" category. It is now a top-level category
395in its own right.
396
397=head2 Fatal Warnings
398X<warning, fatal>
399
400The presence of the word "FATAL" in the category list will escalate any
401warnings detected from the categories specified in the lexical scope
402into fatal errors. In the code below, the use of C<time>, C<length>
403and C<join> can all produce a C<"Useless use of xxx in void context">
404warning.
405
406 use warnings;
407
408 time;
409
410 {
411 use warnings FATAL => qw(void);
412 length "abc";
413 }
414
415 join "", 1,2,3;
416
417 print "done\n";
418
419When run it produces this output
420
421 Useless use of time in void context at fatal line 3.
422 Useless use of length in void context at fatal line 7.
423
424The scope where C<length> is used has escalated the C<void> warnings
425category into a fatal error, so the program terminates immediately when it
426encounters the warning.
427
428To explicitly turn off a "FATAL" warning you just disable the warning
429it is associated with. So, for example, to disable the "void" warning
430in the example above, either of these will do the trick:
431
432 no warnings qw(void);
433 no warnings FATAL => qw(void);
434
435If you want to downgrade a warning that has been escalated into a fatal
436error back to a normal warning, you can use the "NONFATAL" keyword. For
437example, the code below will promote all warnings into fatal errors,
438except for those in the "syntax" category.
439
440 use warnings FATAL => 'all', NONFATAL => 'syntax';
441
442As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
443use:
444
445 use v5.20; # Perl 5.20 or greater is required for the following
446 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
447
448If you want your program to be compatible with versions of Perl before
4495.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
450previous versions of Perl, the behavior of the statements
451C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
452C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
453they included the C<< => 'all' >> portion. As of 5.20, they do.)
454
455B<NOTE:> Users of FATAL warnings, especially
456those using C<< FATAL => 'all' >>
457should be fully aware that they are risking future portability of their
458programs by doing so. Perl makes absolutely no commitments to not
459introduce new warnings, or warnings categories in the future, and indeed
460we explicitly reserve the right to do so. Code that may not warn now may
461warn in a future release of Perl if the Perl5 development team deems it
462in the best interests of the community to do so. Should code using FATAL
463warnings break due to the introduction of a new warning we will NOT
464consider it an incompatible change. Users of FATAL warnings should take
465special caution during upgrades to check to see if their code triggers
466any new warnings and should pay particular attention to the fine print of
467the documentation of the features they use to ensure they do not exploit
468features that are documented as risky, deprecated, or unspecified, or where
469the documentation says "so don't do that", or anything with the same sense
470and spirit. Use of such features in combination with FATAL warnings is
471ENTIRELY AT THE USER'S RISK.
472
473=head2 Reporting Warnings from a Module
474X<warning, reporting> X<warning, registering>
475
476The C<warnings> pragma provides a number of functions that are useful for
477module authors. These are used when you want to report a module-specific
478warning to a calling module has enabled warnings via the C<warnings>
479pragma.
480
481Consider the module C<MyMod::Abc> below.
482
483 package MyMod::Abc;
484
485 use warnings::register;
486
487 sub open {
488 my $path = shift;
489 if ($path !~ m#^/#) {
490 warnings::warn("changing relative path to /var/abc")
491 if warnings::enabled();
492 $path = "/var/abc/$path";
493 }
494 }
495
496 1;
497
498The call to C<warnings::register> will create a new warnings category
499called "MyMod::Abc", i.e. the new category name matches the current
500package name. The C<open> function in the module will display a warning
501message if it gets given a relative path as a parameter. This warnings
502will only be displayed if the code that uses C<MyMod::Abc> has actually
503enabled them with the C<warnings> pragma like below.
504
505 use MyMod::Abc;
506 use warnings 'MyMod::Abc';
507 ...
508 abc::open("../fred.txt");
509
510It is also possible to test whether the pre-defined warnings categories are
511set in the calling module with the C<warnings::enabled> function. Consider
512this snippet of code:
513
514 package MyMod::Abc;
515
516 sub open {
517 warnings::warnif("deprecated",
518 "open is deprecated, use new instead");
519 new(@_);
520 }
521
522 sub new
523 ...
524 1;
525
526The function C<open> has been deprecated, so code has been included to
527display a warning message whenever the calling module has (at least) the
528"deprecated" warnings category enabled. Something like this, say.
529
530 use warnings 'deprecated';
531 use MyMod::Abc;
532 ...
533 MyMod::Abc::open($filename);
534
535Either the C<warnings::warn> or C<warnings::warnif> function should be
536used to actually display the warnings message. This is because they can
537make use of the feature that allows warnings to be escalated into fatal
538errors. So in this case
539
540 use MyMod::Abc;
541 use warnings FATAL => 'MyMod::Abc';
542 ...
543 MyMod::Abc::open('../fred.txt');
544
545the C<warnings::warnif> function will detect this and die after
546displaying the warning message.
547
548The three warnings functions, C<warnings::warn>, C<warnings::warnif>
549and C<warnings::enabled> can optionally take an object reference in place
550of a category name. In this case the functions will use the class name
551of the object as the warnings category.
552
553Consider this example:
554
555 package Original;
556
557 no warnings;
558 use warnings::register;
559
560 sub new
561 {
562 my $class = shift;
563 bless [], $class;
564 }
565
566 sub check
567 {
568 my $self = shift;
569 my $value = shift;
570
571 if ($value % 2 && warnings::enabled($self))
572 { warnings::warn($self, "Odd numbers are unsafe") }
573 }
574
575 sub doit
576 {
577 my $self = shift;
578 my $value = shift;
579 $self->check($value);
580 # ...
581 }
582
583 1;
584
585 package Derived;
586
587 use warnings::register;
588 use Original;
589 our @ISA = qw( Original );
590 sub new
591 {
592 my $class = shift;
593 bless [], $class;
594 }
595
596
597 1;
598
599The code below makes use of both modules, but it only enables warnings from
600C<Derived>.
601
602 use Original;
603 use Derived;
604 use warnings 'Derived';
605 my $a = Original->new();
606 $a->doit(1);
607 my $b = Derived->new();
608 $a->doit(1);
609
610When this code is run only the C<Derived> object, C<$b>, will generate
611a warning.
612
613 Odd numbers are unsafe at main.pl line 7
614
615Notice also that the warning is reported at the line where the object is first
616used.
617
618When registering new categories of warning, you can supply more names to
619warnings::register like this:
620
621 package MyModule;
622 use warnings::register qw(format precision);
623
624 ...
625
626 warnings::warnif('MyModule::format', '...');
627
628=head1 FUNCTIONS
629
630=over 4
631
632=item use warnings::register
633
634Creates a new warnings category with the same name as the package where
635the call to the pragma is used.
636
637=item warnings::enabled()
638
639Use the warnings category with the same name as the current package.
640
641Return TRUE if that warnings category is enabled in the calling module.
642Otherwise returns FALSE.
643
644=item warnings::enabled($category)
645
646Return TRUE if the warnings category, C<$category>, is enabled in the
647calling module.
648Otherwise returns FALSE.
649
650=item warnings::enabled($object)
651
652Use the name of the class for the object reference, C<$object>, as the
653warnings category.
654
655Return TRUE if that warnings category is enabled in the first scope
656where the object is used.
657Otherwise returns FALSE.
658
659=item warnings::fatal_enabled()
660
661Return TRUE if the warnings category with the same name as the current
662package has been set to FATAL in the calling module.
663Otherwise returns FALSE.
664
665=item warnings::fatal_enabled($category)
666
667Return TRUE if the warnings category C<$category> has been set to FATAL in
668the calling module.
669Otherwise returns FALSE.
670
671=item warnings::fatal_enabled($object)
672
673Use the name of the class for the object reference, C<$object>, as the
674warnings category.
675
676Return TRUE if that warnings category has been set to FATAL in the first
677scope where the object is used.
678Otherwise returns FALSE.
679
680=item warnings::warn($message)
681
682Print C<$message> to STDERR.
683
684Use the warnings category with the same name as the current package.
685
686If that warnings category has been set to "FATAL" in the calling module
687then die. Otherwise return.
688
689=item warnings::warn($category, $message)
690
691Print C<$message> to STDERR.
692
693If the warnings category, C<$category>, has been set to "FATAL" in the
694calling module then die. Otherwise return.
695
696=item warnings::warn($object, $message)
697
698Print C<$message> to STDERR.
699
700Use the name of the class for the object reference, C<$object>, as the
701warnings category.
702
703If that warnings category has been set to "FATAL" in the scope where C<$object>
704is first used then die. Otherwise return.
705
706
707=item warnings::warnif($message)
708
709Equivalent to:
710
711 if (warnings::enabled())
712 { warnings::warn($message) }
713
714=item warnings::warnif($category, $message)
715
716Equivalent to:
717
718 if (warnings::enabled($category))
719 { warnings::warn($category, $message) }
720
721=item warnings::warnif($object, $message)
722
723Equivalent to:
724
725 if (warnings::enabled($object))
726 { warnings::warn($object, $message) }
727
728=item warnings::register_categories(@names)
729
730This registers warning categories for the given names and is primarily for
731use by the warnings::register pragma.
732
733=back
734
735See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
736
737=cut
738
73910sour %Offsets = (
740
741 # Warnings Categories added in Perl 5.008
742
743 'all' => 0,
744 'closure' => 2,
745 'deprecated' => 4,
746 'exiting' => 6,
747 'glob' => 8,
748 'io' => 10,
749 'closed' => 12,
750 'exec' => 14,
751 'layer' => 16,
752 'newline' => 18,
753 'pipe' => 20,
754 'unopened' => 22,
755 'misc' => 24,
756 'numeric' => 26,
757 'once' => 28,
758 'overflow' => 30,
759 'pack' => 32,
760 'portable' => 34,
761 'recursion' => 36,
762 'redefine' => 38,
763 'regexp' => 40,
764 'severe' => 42,
765 'debugging' => 44,
766 'inplace' => 46,
767 'internal' => 48,
768 'malloc' => 50,
769 'signal' => 52,
770 'substr' => 54,
771 'syntax' => 56,
772 'ambiguous' => 58,
773 'bareword' => 60,
774 'digit' => 62,
775 'parenthesis' => 64,
776 'precedence' => 66,
777 'printf' => 68,
778 'prototype' => 70,
779 'qw' => 72,
780 'reserved' => 74,
781 'semicolon' => 76,
782 'taint' => 78,
783 'threads' => 80,
784 'uninitialized' => 82,
785 'unpack' => 84,
786 'untie' => 86,
787 'utf8' => 88,
788 'void' => 90,
789
790 # Warnings Categories added in Perl 5.011
791
792 'imprecision' => 92,
793 'illegalproto' => 94,
794
795 # Warnings Categories added in Perl 5.013
796
797 'non_unicode' => 96,
798 'nonchar' => 98,
799 'surrogate' => 100,
800
801 # Warnings Categories added in Perl 5.017
802
803 'experimental' => 102,
804 'experimental::lexical_subs'=> 104,
805 'experimental::lexical_topic'=> 106,
806 'experimental::regex_sets'=> 108,
807 'experimental::smartmatch'=> 110,
808
809 # Warnings Categories added in Perl 5.019
810
811 'experimental::autoderef'=> 112,
812 'experimental::postderef'=> 114,
813 'experimental::signatures'=> 116,
814 'syscalls' => 118,
815 );
816
81710sour %Bits = (
818 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..59]
819 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [29]
820 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [30]
821 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
822 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
823 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
824 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
825 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [31]
826 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
827 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
828 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15", # [51..58]
829 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [56]
830 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [52]
831 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [53]
832 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [57]
833 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [54]
834 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [58]
835 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [55]
836 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
837 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [47]
838 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [46]
839 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
840 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
841 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [5..11,59]
842 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
843 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
844 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
845 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
846 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [48]
847 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [49]
848 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
849 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
850 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
851 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
852 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [32]
853 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
854 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
855 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [33]
856 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [34]
857 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [35]
858 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [36]
859 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
860 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
861 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
862 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [37]
863 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [38]
864 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
865 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
866 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
867 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [50]
868 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00", # [28..38,47]
869 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [59]
870 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [39]
871 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [40]
872 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [41]
873 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
874 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [42]
875 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [43]
876 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00", # [44,48..50]
877 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [45]
878 );
879
88010sour %DeadBits = (
881 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..59]
882 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [29]
883 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [30]
884 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
885 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
886 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
887 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
888 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [31]
889 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
890 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
891 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a", # [51..58]
892 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [56]
893 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [52]
894 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [53]
895 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [57]
896 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [54]
897 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [58]
898 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [55]
899 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
900 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [47]
901 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [46]
902 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
903 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
904 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [5..11,59]
905 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
906 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
907 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
908 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
909 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [48]
910 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [49]
911 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
912 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
913 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
914 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
915 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [32]
916 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
917 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
918 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [33]
919 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [34]
920 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [35]
921 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [36]
922 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
923 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
924 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
925 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [37]
926 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [38]
927 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
928 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
929 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
930 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [50]
931 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00", # [28..38,47]
932 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [59]
933 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [39]
934 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [40]
935 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [41]
936 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
937 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [42]
938 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [43]
939 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00", # [44,48..50]
940 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [45]
941 );
942
94310s$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
94410s$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15", # [2,56,52,53,57,54,58,55,4,22,23,25]
945$LAST_BIT = 120 ;
94610s$BYTES = 15 ;
947
94820s$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
949
950sub Croaker
951{
952 require Carp; # this initializes %CarpInternal
953 local $Carp::CarpInternal{'warnings'};
954 delete $Carp::CarpInternal{'warnings'};
955 Carp::croak(@_);
956}
957
958
# spent 0s within warnings::_bits which was called 2 times, avg 0s/call: # 2 times (0s+0s) by warnings::import at line 1007, avg 0s/call
sub _bits {
95920s my $mask = shift ;
96020s my $catmask ;
96120s my $fatal = 0 ;
96220s my $no_fatal = 0 ;
963
96420s foreach my $word ( @_ ) {
96540s if ($word eq 'FATAL') {
96620s $fatal = 1;
96720s $no_fatal = 0;
968 }
969 elsif ($word eq 'NONFATAL') {
970 $fatal = 0;
971 $no_fatal = 1;
972 }
973 elsif ($catmask = $Bits{$word}) {
97420s $mask |= $catmask ;
97520s $mask |= $DeadBits{$word} if $fatal ;
97620s $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
977 }
978 else
979 { Croaker("Unknown warnings category '$word'")}
980 }
981
98220s return $mask ;
983}
984
985sub bits
986{
987 # called from B::Deparse.pm
988 push @_, 'all' unless @_ ;
989 return _bits(undef, @_) ;
990}
991
992sub import
993
# spent 0s within warnings::import which was called 33 times, avg 0s/call: # once (0s+0s) by CPAN::Meta::BEGIN@3 at line 3 of CPAN/Meta/Feature.pm # once (0s+0s) by Win32::API::Struct::BEGIN@10 at line 10 of Win32/API/Struct.pm # once (0s+0s) by Encode::Encoding::BEGIN@5 at line 5 of Encode/Encoding.pm # once (0s+0s) by Config::BEGIN@10 at line 10 of Config.pm # once (0s+0s) by CPAN::Meta::BEGIN@3.6 at line 3 of CPAN/Meta/Converter.pm # once (0s+0s) by CPAN::Meta::Converter::BEGIN@3 at line 3 of CPAN/Meta/Validator.pm # once (0s+0s) by Portable::minicpan::BEGIN@5 at line 5 of Portable/minicpan.pm # once (0s+0s) by overloading::BEGIN@2 at line 2 of overloading.pm # once (0s+0s) by Portable::Config::BEGIN@5 at line 5 of Portable/Config.pm # once (0s+0s) by CPAN::Meta::YAML::BEGIN@201 at line 201 of CPAN/Meta/YAML.pm # once (0s+0s) by Parse::CPAN::Meta::BEGIN@3 at line 3 of CPAN/Meta/YAML.pm # once (0s+0s) by CPAN::Meta::Prereqs::BEGIN@2 at line 2 of CPAN/Meta/Requirements.pm # once (0s+0s) by File::Find::BEGIN@4 at line 4 of File/Find.pm # once (0s+0s) by Portable::CPAN::BEGIN@5 at line 5 of Portable/CPAN.pm # once (0s+0s) by Win32::API::Type::BEGIN@16 at line 16 of Win32/API/Type.pm # once (0s+0s) by Encode::Config::BEGIN@8 at line 8 of Encode/Config.pm # once (0s+0s) by File::Copy::BEGIN@12 at line 12 of File/Copy.pm # once (0s+0s) by File::Basename::BEGIN@52 at line 52 of File/Basename.pm # once (0s+0s) by Portable::LoadYaml::BEGIN@78 at line 78 of Portable/LoadYaml.pm # once (0s+0s) by Portable::LoadYaml::BEGIN@7 at line 7 of Portable/LoadYaml.pm # once (0s+0s) by ExtUtils::Manifest::BEGIN@11 at line 11 of ExtUtils/Manifest.pm # once (0s+0s) by Config::BEGIN@6 at line 6 of Config_heavy.pl # once (0s+0s) by Portable::FileSpec::BEGIN@7 at line 7 of Portable/FileSpec.pm # once (0s+0s) by ExtUtils::Liblist::Kid::BEGIN@13 at line 13 of ExtUtils/Liblist/Kid.pm # once (0s+0s) by Encode::BEGIN@6 at line 6 of Encode.pm # once (0s+0s) by Portable::BEGIN@53 at line 53 of Portable.pm # once (0s+0s) by Encode::Alias::BEGIN@3 at line 3 of Encode/Alias.pm # once (0s+0s) by CPAN::Meta::Feature::BEGIN@3 at line 3 of CPAN/Meta/Prereqs.pm # once (0s+0s) by Portable::HomeDir::BEGIN@7 at line 7 of Portable/HomeDir.pm # once (0s+0s) by ExtUtils::MM_Any::BEGIN@3.3 at line 3 of CPAN/Meta.pm # once (0s+0s) by Encode::Byte::BEGIN@3 at line 3 of Encode/Byte.pm # once (0s+0s) by Carp::BEGIN@5 at line 5 of Carp.pm # once (0s+0s) by Win32::API::BEGIN@18 at line 18 of Win32/API.pm
{
994330s shift;
995
996330s my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
997
998330s if (vec($mask, $Offsets{'all'}, 1)) {
99920s $mask |= $Bits{'all'} ;
100020s $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1001 }
1002
1003 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1004330s push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
1005
1006 # Empty @_ is equivalent to @_ = 'all' ;
1007330s20s ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
# spent 0s making 2 calls to warnings::_bits, avg 0s/call
1008}
1009
1010sub unimport
1011
# spent 0s within warnings::unimport which was called 18 times, avg 0s/call: # once (0s+0s) by CPAN::Meta::Converter::BEGIN@53 at line 53 of CPAN/Meta/Converter.pm # once (0s+0s) by CPAN::Meta::Converter::BEGIN@52 at line 52 of CPAN/Meta/Converter.pm # once (0s+0s) by Encode::Alias::BEGIN@4 at line 4 of Encode/Alias.pm # once (0s+0s) by ExtUtils::MakeMaker::Locale::BEGIN@105 at line 105 of ExtUtils/MakeMaker/Locale.pm # once (0s+0s) by Portable::Config::BEGIN@64 at line 63 of Portable/Config.pm # once (0s+0s) by Portable::Config::BEGIN@78 at line 78 of Portable/Config.pm # once (0s+0s) by Carp::BEGIN@568 at line 568 of Carp.pm # once (0s+0s) by Carp::BEGIN@6 at line 24 of Carp.pm # once (0s+0s) by Win32::API::BEGIN@26 at line 26 of Win32/API.pm # once (0s+0s) by Win32::API::BEGIN@537 at line 537 of Win32/API.pm # once (0s+0s) by DirHandle::BEGIN@50 at line 50 of DirHandle.pm # once (0s+0s) by File::Copy::BEGIN@12.1 at line 12 of File/Copy.pm # once (0s+0s) by Exporter::Heavy::BEGIN@202 at line 202 of Exporter/Heavy.pm # once (0s+0s) by Text::ParseWords::BEGIN@133 at line 133 of Text/ParseWords.pm # once (0s+0s) by Text::ParseWords::BEGIN@62 at line 62 of Text/ParseWords.pm # once (0s+0s) by Win32::API::Struct::BEGIN@313 at line 313 of Win32/API/Struct.pm # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@873 at line 873 of ExtUtils/MakeMaker.pm # once (0s+0s) by Encode::BEGIN@266 at line 266 of Encode.pm
{
1012180s shift;
1013
1014180s my $catmask ;
1015180s my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1016
1017180s if (vec($mask, $Offsets{'all'}, 1)) {
1018100s $mask |= $Bits{'all'} ;
1019100s $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1020 }
1021
1022 # append 'all' when implied (empty import list or after a lone "FATAL")
1023180s push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
1024
1025180s foreach my $word ( @_ ) {
1026180s if ($word eq 'FATAL') {
1027 next;
1028 }
1029 elsif ($catmask = $Bits{$word}) {
1030 $mask &= ~($catmask | $DeadBits{$word} | $All);
1031 }
1032 else
1033 { Croaker("Unknown warnings category '$word'")}
1034 }
1035
1036180s ${^WARNING_BITS} = $mask ;
1037}
1038
103920smy %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1040
1041sub MESSAGE () { 4 };
1042sub FATAL () { 2 };
1043sub NORMAL () { 1 };
1044
1045sub __chk
1046{
1047 my $category ;
1048 my $offset ;
1049 my $isobj = 0 ;
1050 my $wanted = shift;
1051 my $has_message = $wanted & MESSAGE;
1052
1053 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
1054 my $sub = (caller 1)[3];
1055 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
1056 Croaker("Usage: $sub($syntax)");
1057 }
1058
1059 my $message = pop if $has_message;
1060
1061 if (@_) {
1062 # check the category supplied.
1063 $category = shift ;
1064 if (my $type = ref $category) {
1065 Croaker("not an object")
1066 if exists $builtin_type{$type};
1067 $category = $type;
1068 $isobj = 1 ;
1069 }
1070 $offset = $Offsets{$category};
1071 Croaker("Unknown warnings category '$category'")
1072 unless defined $offset;
1073 }
1074 else {
1075 $category = (caller(1))[0] ;
1076 $offset = $Offsets{$category};
1077 Croaker("package '$category' not registered for warnings")
1078 unless defined $offset ;
1079 }
1080
1081 my $i;
1082
1083 if ($isobj) {
1084 my $pkg;
1085 $i = 2;
1086 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
1087 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
1088 }
1089 $i -= 2 ;
1090 }
1091 else {
1092 $i = _error_loc(); # see where Carp will allocate the error
1093 }
1094
1095 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
1096 # explicitly returns undef.
1097 my(@callers_bitmask) = (caller($i))[9] ;
1098 my $callers_bitmask =
1099 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
1100
1101 my @results;
1102 foreach my $type (FATAL, NORMAL) {
1103 next unless $wanted & $type;
1104
1105 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
1106 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
1107 }
1108
1109 # &enabled and &fatal_enabled
1110 return $results[0] unless $has_message;
1111
1112 # &warnif, and the category is neither enabled as warning nor as fatal
1113 return if $wanted == (NORMAL | FATAL | MESSAGE)
1114 && !($results[0] || $results[1]);
1115
1116 require Carp;
1117 Carp::croak($message) if $results[0];
1118 # will always get here for &warn. will only get here for &warnif if the
1119 # category is enabled
1120 Carp::carp($message);
1121}
1122
1123sub _mkMask
1124
# spent 0s within warnings::_mkMask which was called 10 times, avg 0s/call: # 5 times (0s+0s) by warnings::register_categories at line 1138, avg 0s/call # 5 times (0s+0s) by warnings::register_categories at line 1144, avg 0s/call
{
1125100s my ($bit) = @_;
1126100s my $mask = "";
1127
1128100s vec($mask, $bit, 1) = 1;
1129100s return $mask;
1130}
1131
1132sub register_categories
1133
# spent 0s within warnings::register_categories which was called 6 times, avg 0s/call: # 5 times (0s+0s) by warnings::register::import at line 42 of warnings/register.pm, avg 0s/call # once (0s+0s) by ExtUtils::MakeMaker::version::BEGIN@2 at line 7 of version.pm
{
113460s my @names = @_;
1135
113660s for my $name (@names) {
113760s if (! defined $Bits{$name}) {
113850s50s $Bits{$name} = _mkMask($LAST_BIT);
# spent 0s making 5 calls to warnings::_mkMask, avg 0s/call
113950s vec($Bits{'all'}, $LAST_BIT, 1) = 1;
114050s $Offsets{$name} = $LAST_BIT ++;
114150s foreach my $k (keys %Bits) {
11423150s vec($Bits{$k}, $LAST_BIT, 1) = 0;
1143 }
114450s50s $DeadBits{$name} = _mkMask($LAST_BIT);
# spent 0s making 5 calls to warnings::_mkMask, avg 0s/call
114550s vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
1146 }
1147 }
1148}
1149
1150sub _error_loc {
1151 require Carp;
1152 goto &Carp::short_error_loc; # don't introduce another stack frame
1153}
1154
1155sub enabled
1156{
1157 return __chk(NORMAL, @_);
1158}
1159
1160sub fatal_enabled
1161{
1162 return __chk(FATAL, @_);
1163}
1164
1165sub warn
1166{
1167 return __chk(FATAL | MESSAGE, @_);
1168}
1169
1170sub warnif
1171{
1172 return __chk(NORMAL | FATAL | MESSAGE, @_);
1173}
1174
1175# These are not part of any public interface, so we can delete them to save
1176# space.
117710sdelete @warnings::{qw(NORMAL FATAL MESSAGE)};
1178
117910s1;
1180
1181# ex: set ro:
 
# spent 0s within warnings::CORE:match which was called: # once (0s+0s) by Config::BEGIN@10 at line 12
sub warnings::CORE:match; # opcode
# spent 0s within warnings::CORE:regcomp which was called: # once (0s+0s) by Config::BEGIN@10 at line 12
sub warnings::CORE:regcomp; # opcode
Report produced by the NYTProf 5.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.