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