source: trunk/third/perl/warnings.pl @ 20075

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