This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Create new warnings category experimental::regex_sets
[perl5.git] / regen / warnings.pl
1 #!/usr/bin/perl
2
3 # Regenerate (overwriting only if changed):
4 #
5 #    lib/warnings.pm
6 #    warnings.h
7 #
8 # from information hardcoded into this script (the $tree hash), plus the
9 # template for warnings.pm in the DATA section.
10 #
11 # When changing the number of warnings, t/op/caller.t should change to
12 # correspond with the value of $BYTES in lib/warnings.pm
13 #
14 # With an argument of 'tree', just dump the contents of $tree and exits.
15 # Also accepts the standard regen_lib -q and -v args.
16 #
17 # This script is normally invoked from regen.pl.
18
19 $VERSION = '1.02_03';
20
21 BEGIN {
22     require 'regen/regen_lib.pl';
23     push @INC, './lib';
24 }
25 use strict ;
26
27 sub DEFAULT_ON  () { 1 }
28 sub DEFAULT_OFF () { 2 }
29
30 my $tree = {
31
32 'all' => [ 5.008, {
33         'io'            => [ 5.008, {   
34                                 'pipe'          => [ 5.008, DEFAULT_OFF],
35                                 'unopened'      => [ 5.008, DEFAULT_OFF],
36                                 'closed'        => [ 5.008, DEFAULT_OFF],
37                                 'newline'       => [ 5.008, DEFAULT_OFF],
38                                 'exec'          => [ 5.008, DEFAULT_OFF],
39                                 'layer'         => [ 5.008, DEFAULT_OFF],
40                            }],
41         'syntax'        => [ 5.008, {   
42                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
43                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
44                                 'precedence'    => [ 5.008, DEFAULT_OFF],
45                                 'bareword'      => [ 5.008, DEFAULT_OFF],
46                                 'reserved'      => [ 5.008, DEFAULT_OFF],
47                                 'digit'         => [ 5.008, DEFAULT_OFF],
48                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
49                                 'printf'        => [ 5.008, DEFAULT_OFF],
50                                 'prototype'     => [ 5.008, DEFAULT_OFF],
51                                 'qw'            => [ 5.008, DEFAULT_OFF],
52                                 'illegalproto'  => [ 5.011, DEFAULT_OFF],
53                            }],
54         'severe'        => [ 5.008, {   
55                                 'inplace'       => [ 5.008, DEFAULT_ON],
56                                 'internal'      => [ 5.008, DEFAULT_OFF],
57                                 'debugging'     => [ 5.008, DEFAULT_ON],
58                                 'malloc'        => [ 5.008, DEFAULT_ON],
59                            }],
60         'deprecated'    => [ 5.008, DEFAULT_ON],
61         'void'          => [ 5.008, DEFAULT_OFF],
62         'recursion'     => [ 5.008, DEFAULT_OFF],
63         'redefine'      => [ 5.008, DEFAULT_OFF],
64         'numeric'       => [ 5.008, DEFAULT_OFF],
65         'uninitialized' => [ 5.008, DEFAULT_OFF],
66         'once'          => [ 5.008, DEFAULT_OFF],
67         'misc'          => [ 5.008, DEFAULT_OFF],
68         'regexp'        => [ 5.008, DEFAULT_OFF],
69         'glob'          => [ 5.008, DEFAULT_ON],
70         'untie'         => [ 5.008, DEFAULT_OFF],
71         'substr'        => [ 5.008, DEFAULT_OFF],
72         'taint'         => [ 5.008, DEFAULT_OFF],
73         'signal'        => [ 5.008, DEFAULT_OFF],
74         'closure'       => [ 5.008, DEFAULT_OFF],
75         'overflow'      => [ 5.008, DEFAULT_OFF],
76         'portable'      => [ 5.008, DEFAULT_OFF],
77         'utf8'          => [ 5.008, {
78                                 'surrogate' => [ 5.013, DEFAULT_OFF],
79                                 'nonchar' => [ 5.013, DEFAULT_OFF],
80                                 'non_unicode' => [ 5.013, DEFAULT_OFF],
81                         }],
82         'exiting'       => [ 5.008, DEFAULT_OFF],
83         'pack'          => [ 5.008, DEFAULT_OFF],
84         'unpack'        => [ 5.008, DEFAULT_OFF],
85         'threads'       => [ 5.008, DEFAULT_OFF],
86         'imprecision'   => [ 5.011, DEFAULT_OFF],
87         'experimental'  => [ 5.017, {
88                                 'experimental::lexical_subs' =>
89                                     [ 5.017, DEFAULT_ON ],
90                                 'experimental::regex_sets' =>
91                                     [ 5.017, DEFAULT_ON ],
92                         }],
93
94          #'default'     => [ 5.008, DEFAULT_ON ],
95         }],
96 } ;
97
98 my @def ;
99 my %list ;
100 my %Value ;
101 my %ValueToName ;
102 my %NameToValue ;
103
104 my %v_list = () ;
105
106 sub valueWalk
107 {
108     my $tre = shift ;
109     my @list = () ;
110     my ($k, $v) ;
111
112     foreach $k (sort keys %$tre) {
113         $v = $tre->{$k};
114         die "duplicate key $k\n" if defined $list{$k} ;
115         die "Value associated with key '$k' is not an ARRAY reference"
116             if !ref $v || ref $v ne 'ARRAY' ;
117
118         my ($ver, $rest) = @{ $v } ;
119         push @{ $v_list{$ver} }, $k;
120         
121         if (ref $rest)
122           { valueWalk ($rest) }
123
124     }
125
126 }
127
128 sub orderValues
129 {
130     my $index = 0;
131     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
132         foreach my $name (@{ $v_list{$ver} } ) {
133             $ValueToName{ $index } = [ uc $name, $ver ] ;
134             $NameToValue{ uc $name } = $index ++ ;
135         }
136     }
137
138     return $index ;
139 }
140
141 ###########################################################################
142
143 sub walk
144 {
145     my $tre = shift ;
146     my @list = () ;
147     my ($k, $v) ;
148
149     foreach $k (sort keys %$tre) {
150         $v = $tre->{$k};
151         die "duplicate key $k\n" if defined $list{$k} ;
152         die "Can't find key '$k'"
153             if ! defined $NameToValue{uc $k} ;
154         push @{ $list{$k} }, $NameToValue{uc $k} ;
155         die "Value associated with key '$k' is not an ARRAY reference"
156             if !ref $v || ref $v ne 'ARRAY' ;
157         
158         my ($ver, $rest) = @{ $v } ;
159         if (ref $rest)
160           { push (@{ $list{$k} }, walk ($rest)) }
161         elsif ($rest == DEFAULT_ON)
162           { push @def, $NameToValue{uc $k} }
163
164         push @list, @{ $list{$k} } ;
165     }
166
167    return @list ;
168 }
169
170 ###########################################################################
171
172 sub mkRange
173 {
174     my @a = @_ ;
175     my @out = @a ;
176
177     for my $i (1 .. @a - 1) {
178         $out[$i] = ".."
179           if $a[$i] == $a[$i - 1] + 1
180              && ($i >= @a  - 1 || $a[$i] + 1 == $a[$i + 1] );
181     }
182     $out[-1] = $a[-1] if $out[-1] eq "..";
183
184     my $out = join(",",@out);
185
186     $out =~ s/,(\.\.,)+/../g ;
187     return $out;
188 }
189
190 ###########################################################################
191 sub printTree
192 {
193     my $tre = shift ;
194     my $prefix = shift ;
195     my ($k, $v) ;
196
197     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
198     my @keys = sort keys %$tre ;
199
200     while ($k = shift @keys) {
201         $v = $tre->{$k};
202         die "Value associated with key '$k' is not an ARRAY reference"
203             if !ref $v || ref $v ne 'ARRAY' ;
204         
205         my $offset ;
206         if ($tre ne $tree) {
207             print $prefix . "|\n" ;
208             print $prefix . "+- $k" ;
209             $offset = ' ' x ($max + 4) ;
210         }
211         else {
212             print $prefix . "$k" ;
213             $offset = ' ' x ($max + 1) ;
214         }
215
216         my ($ver, $rest) = @{ $v } ;
217         if (ref $rest)
218         {
219             my $bar = @keys ? "|" : " ";
220             print " -" . "-" x ($max - length $k ) . "+\n" ;
221             printTree ($rest, $prefix . $bar . $offset )
222         }
223         else
224           { print "\n" }
225     }
226
227 }
228
229 ###########################################################################
230
231 sub mkHexOct
232 {
233     my ($f, $max, @a) = @_ ;
234     my $mask = "\x00" x $max ;
235     my $string = "" ;
236
237     foreach (@a) {
238         vec($mask, $_, 1) = 1 ;
239     }
240
241     foreach (unpack("C*", $mask)) {
242         if ($f eq 'x') {
243             $string .= '\x' . sprintf("%2.2x", $_)
244         }
245         else {
246             $string .= '\\' . sprintf("%o", $_)
247         }
248     }
249     return $string ;
250 }
251
252 sub mkHex
253 {
254     my($max, @a) = @_;
255     return mkHexOct("x", $max, @a);
256 }
257
258 sub mkOct
259 {
260     my($max, @a) = @_;
261     return mkHexOct("o", $max, @a);
262 }
263
264 ###########################################################################
265
266 if (@ARGV && $ARGV[0] eq "tree")
267 {
268     printTree($tree, "    ") ;
269     exit ;
270 }
271
272 my ($warn, $pm) = map {
273     open_new($_, '>', { by => 'regen/warnings.pl' });
274 } 'warnings.h', 'lib/warnings.pm';
275
276 print $warn <<'EOM';
277
278 #define Off(x)                  ((x) / 8)
279 #define Bit(x)                  (1 << ((x) % 8))
280 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
281
282
283 #define G_WARN_OFF              0       /* $^W == 0 */
284 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
285 #define G_WARN_ALL_ON           2       /* -W flag */
286 #define G_WARN_ALL_OFF          4       /* -X flag */
287 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
288 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
289
290 #define pWARN_STD               NULL
291 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
292 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
293
294 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
295                                  (x) == pWARN_NONE)
296
297 /* if PL_warnhook is set to this value, then warnings die */
298 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
299 EOM
300
301 my $offset = 0 ;
302
303 valueWalk ($tree) ;
304 my $index = orderValues();
305
306 die <<EOM if $index > 255 ;
307 Too many warnings categories -- max is 255
308     rewrite packWARN* & unpackWARN* macros 
309 EOM
310
311 walk ($tree) ;
312
313 $index *= 2 ;
314 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
315
316 my $k ;
317 my $last_ver = 0;
318 foreach $k (sort { $a <=> $b } keys %ValueToName) {
319     my ($name, $version) = @{ $ValueToName{$k} };
320     print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
321         if $last_ver != $version ;
322     $name =~ y/:/_/;
323     print $warn tab(5, "#define WARN_$name"), " $k\n" ;
324     $last_ver = $version ;
325 }
326 print $warn "\n" ;
327
328 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
329 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
330 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
331 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
332
333 print $warn <<'EOM';
334
335 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
336 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
337 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
338 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
339 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
340
341 #define DUP_WARNINGS(p)         \
342     (specialWARN(p) ? (STRLEN*)(p)      \
343     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
344                                              char))
345
346 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
347 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
348 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
349 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
350
351 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
352 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
353 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
354 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
355
356 #define WARNshift               8
357
358 #define packWARN(a)             (a                                      )
359 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
360 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
361 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
362
363 #define unpackWARN1(x)          ((x)        & 0xFF)
364 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
365 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
366 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
367
368 #define ckDEAD(x)                                                       \
369            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
370             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
371               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
372               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
373               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
374               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
375
376 /* end of file warnings.h */
377 EOM
378
379 read_only_bottom_close_and_rename($warn);
380
381 while (<DATA>) {
382     last if /^KEYWORDS$/ ;
383     print $pm $_ ;
384 }
385
386 $last_ver = 0;
387 print $pm "our %Offsets = (\n" ;
388 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
389     my ($name, $version) = @{ $ValueToName{$k} };
390     $name = lc $name;
391     $k *= 2 ;
392     if ( $last_ver != $version ) {
393         print $pm "\n";
394         print $pm tab(4, "    # Warnings Categories added in Perl $version");
395         print $pm "\n\n";
396     }
397     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
398     $last_ver = $version;
399 }
400
401 print $pm "  );\n\n" ;
402
403 print $pm "our %Bits = (\n" ;
404 foreach $k (sort keys  %list) {
405
406     my $v = $list{$k} ;
407     my @list = sort { $a <=> $b } @$v ;
408
409     print $pm tab(4, "    '$k'"), '=> "',
410                 mkHex($warn_size, map $_ * 2 , @list),
411                 '", # [', mkRange(@list), "]\n" ;
412 }
413
414 print $pm "  );\n\n" ;
415
416 print $pm "our %DeadBits = (\n" ;
417 foreach $k (sort keys  %list) {
418
419     my $v = $list{$k} ;
420     my @list = sort { $a <=> $b } @$v ;
421
422     print $pm tab(4, "    '$k'"), '=> "',
423                 mkHex($warn_size, map $_ * 2 + 1 , @list),
424                 '", # [', mkRange(@list), "]\n" ;
425 }
426
427 print $pm "  );\n\n" ;
428 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
429 print $pm '$DEFAULT  = "', mkHex($warn_size, map $_ * 2, @def),
430                            '", # [', mkRange(@def), "]\n" ;
431 print $pm '$LAST_BIT = ' . "$index ;\n" ;
432 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
433 while (<DATA>) {
434     print $pm $_ ;
435 }
436
437 read_only_bottom_close_and_rename($pm);
438
439 __END__
440 package warnings;
441
442 our $VERSION = '1.16';
443
444 # Verify that we're called correctly so that warnings will work.
445 # see also strict.pm.
446 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
447     my (undef, $f, $l) = caller;
448     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
449 }
450
451 =head1 NAME
452
453 warnings - Perl pragma to control optional warnings
454
455 =head1 SYNOPSIS
456
457     use warnings;
458     no warnings;
459
460     use warnings "all";
461     no warnings "all";
462
463     use warnings::register;
464     if (warnings::enabled()) {
465         warnings::warn("some warning");
466     }
467
468     if (warnings::enabled("void")) {
469         warnings::warn("void", "some warning");
470     }
471
472     if (warnings::enabled($object)) {
473         warnings::warn($object, "some warning");
474     }
475
476     warnings::warnif("some warning");
477     warnings::warnif("void", "some warning");
478     warnings::warnif($object, "some warning");
479
480 =head1 DESCRIPTION
481
482 The C<warnings> pragma is a replacement for the command line flag C<-w>,
483 but the pragma is limited to the enclosing block, while the flag is global.
484 See L<perllexwarn> for more information and the list of built-in warning
485 categories.
486
487 If no import list is supplied, all possible warnings are either enabled
488 or disabled.
489
490 A number of functions are provided to assist module authors.
491
492 =over 4
493
494 =item use warnings::register
495
496 Creates a new warnings category with the same name as the package where
497 the call to the pragma is used.
498
499 =item warnings::enabled()
500
501 Use the warnings category with the same name as the current package.
502
503 Return TRUE if that warnings category is enabled in the calling module.
504 Otherwise returns FALSE.
505
506 =item warnings::enabled($category)
507
508 Return TRUE if the warnings category, C<$category>, is enabled in the
509 calling module.
510 Otherwise returns FALSE.
511
512 =item warnings::enabled($object)
513
514 Use the name of the class for the object reference, C<$object>, as the
515 warnings category.
516
517 Return TRUE if that warnings category is enabled in the first scope
518 where the object is used.
519 Otherwise returns FALSE.
520
521 =item warnings::fatal_enabled()
522
523 Return TRUE if the warnings category with the same name as the current
524 package has been set to FATAL in the calling module.
525 Otherwise returns FALSE.
526
527 =item warnings::fatal_enabled($category)
528
529 Return TRUE if the warnings category C<$category> has been set to FATAL in
530 the calling module.
531 Otherwise returns FALSE.
532
533 =item warnings::fatal_enabled($object)
534
535 Use the name of the class for the object reference, C<$object>, as the
536 warnings category.
537
538 Return TRUE if that warnings category has been set to FATAL in the first
539 scope where the object is used.
540 Otherwise returns FALSE.
541
542 =item warnings::warn($message)
543
544 Print C<$message> to STDERR.
545
546 Use the warnings category with the same name as the current package.
547
548 If that warnings category has been set to "FATAL" in the calling module
549 then die. Otherwise return.
550
551 =item warnings::warn($category, $message)
552
553 Print C<$message> to STDERR.
554
555 If the warnings category, C<$category>, has been set to "FATAL" in the
556 calling module then die. Otherwise return.
557
558 =item warnings::warn($object, $message)
559
560 Print C<$message> to STDERR.
561
562 Use the name of the class for the object reference, C<$object>, as the
563 warnings category.
564
565 If that warnings category has been set to "FATAL" in the scope where C<$object>
566 is first used then die. Otherwise return.
567
568
569 =item warnings::warnif($message)
570
571 Equivalent to:
572
573     if (warnings::enabled())
574       { warnings::warn($message) }
575
576 =item warnings::warnif($category, $message)
577
578 Equivalent to:
579
580     if (warnings::enabled($category))
581       { warnings::warn($category, $message) }
582
583 =item warnings::warnif($object, $message)
584
585 Equivalent to:
586
587     if (warnings::enabled($object))
588       { warnings::warn($object, $message) }
589
590 =item warnings::register_categories(@names)
591
592 This registers warning categories for the given names and is primarily for
593 use by the warnings::register pragma, for which see L<perllexwarn>.
594
595 =back
596
597 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
598
599 =cut
600
601 KEYWORDS
602
603 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
604
605 sub Croaker
606 {
607     require Carp; # this initializes %CarpInternal
608     local $Carp::CarpInternal{'warnings'};
609     delete $Carp::CarpInternal{'warnings'};
610     Carp::croak(@_);
611 }
612
613 sub _bits {
614     my $mask = shift ;
615     my $catmask ;
616     my $fatal = 0 ;
617     my $no_fatal = 0 ;
618
619     foreach my $word ( @_ ) {
620         if ($word eq 'FATAL') {
621             $fatal = 1;
622             $no_fatal = 0;
623         }
624         elsif ($word eq 'NONFATAL') {
625             $fatal = 0;
626             $no_fatal = 1;
627         }
628         elsif ($catmask = $Bits{$word}) {
629             $mask |= $catmask ;
630             $mask |= $DeadBits{$word} if $fatal ;
631             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
632         }
633         else
634           { Croaker("Unknown warnings category '$word'")}
635     }
636
637     return $mask ;
638 }
639
640 sub bits
641 {
642     # called from B::Deparse.pm
643     push @_, 'all' unless @_ ;
644     return _bits(undef, @_) ;
645 }
646
647 sub import 
648 {
649     shift;
650
651     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
652
653     if (vec($mask, $Offsets{'all'}, 1)) {
654         $mask |= $Bits{'all'} ;
655         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
656     }
657     
658     # Empty @_ is equivalent to @_ = 'all' ;
659     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
660 }
661
662 sub unimport 
663 {
664     shift;
665
666     my $catmask ;
667     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
668
669     if (vec($mask, $Offsets{'all'}, 1)) {
670         $mask |= $Bits{'all'} ;
671         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
672     }
673
674     push @_, 'all' unless @_;
675
676     foreach my $word ( @_ ) {
677         if ($word eq 'FATAL') {
678             next; 
679         }
680         elsif ($catmask = $Bits{$word}) {
681             $mask &= ~($catmask | $DeadBits{$word} | $All);
682         }
683         else
684           { Croaker("Unknown warnings category '$word'")}
685     }
686
687     ${^WARNING_BITS} = $mask ;
688 }
689
690 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
691
692 sub MESSAGE () { 4 };
693 sub FATAL () { 2 };
694 sub NORMAL () { 1 };
695
696 sub __chk
697 {
698     my $category ;
699     my $offset ;
700     my $isobj = 0 ;
701     my $wanted = shift;
702     my $has_message = $wanted & MESSAGE;
703
704     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
705         my $sub = (caller 1)[3];
706         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
707         Croaker("Usage: $sub($syntax)");
708     }
709
710     my $message = pop if $has_message;
711
712     if (@_) {
713         # check the category supplied.
714         $category = shift ;
715         if (my $type = ref $category) {
716             Croaker("not an object")
717                 if exists $builtin_type{$type};
718             $category = $type;
719             $isobj = 1 ;
720         }
721         $offset = $Offsets{$category};
722         Croaker("Unknown warnings category '$category'")
723             unless defined $offset;
724     }
725     else {
726         $category = (caller(1))[0] ;
727         $offset = $Offsets{$category};
728         Croaker("package '$category' not registered for warnings")
729             unless defined $offset ;
730     }
731
732     my $i;
733
734     if ($isobj) {
735         my $pkg;
736         $i = 2;
737         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
738             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
739         }
740         $i -= 2 ;
741     }
742     else {
743         $i = _error_loc(); # see where Carp will allocate the error
744     }
745
746     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
747     # explicitly returns undef.
748     my(@callers_bitmask) = (caller($i))[9] ;
749     my $callers_bitmask =
750          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
751
752     my @results;
753     foreach my $type (FATAL, NORMAL) {
754         next unless $wanted & $type;
755
756         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
757                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
758     }
759
760     # &enabled and &fatal_enabled
761     return $results[0] unless $has_message;
762
763     # &warnif, and the category is neither enabled as warning nor as fatal
764     return if $wanted == (NORMAL | FATAL | MESSAGE)
765         && !($results[0] || $results[1]);
766
767     require Carp;
768     Carp::croak($message) if $results[0];
769     # will always get here for &warn. will only get here for &warnif if the
770     # category is enabled
771     Carp::carp($message);
772 }
773
774 sub _mkMask
775 {
776     my ($bit) = @_;
777     my $mask = "";
778
779     vec($mask, $bit, 1) = 1;
780     return $mask;
781 }
782
783 sub register_categories
784 {
785     my @names = @_;
786
787     for my $name (@names) {
788         if (! defined $Bits{$name}) {
789             $Bits{$name}     = _mkMask($LAST_BIT);
790             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
791             $Offsets{$name}  = $LAST_BIT ++;
792             foreach my $k (keys %Bits) {
793                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
794             }
795             $DeadBits{$name} = _mkMask($LAST_BIT);
796             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
797         }
798     }
799 }
800
801 sub _error_loc {
802     require Carp;
803     goto &Carp::short_error_loc; # don't introduce another stack frame
804 }
805
806 sub enabled
807 {
808     return __chk(NORMAL, @_);
809 }
810
811 sub fatal_enabled
812 {
813     return __chk(FATAL, @_);
814 }
815
816 sub warn
817 {
818     return __chk(FATAL | MESSAGE, @_);
819 }
820
821 sub warnif
822 {
823     return __chk(NORMAL | FATAL | MESSAGE, @_);
824 }
825
826 # These are not part of any public interface, so we can delete them to save
827 # space.
828 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
829
830 1;