This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ExtUtils::MakeMaker 5.94_02 -> 5.95_01
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
0ca4541c
NIS
3
4$VERSION = '1.00';
b75c8c73 5
73f0cc2d
GS
6BEGIN {
7 push @INC, './lib';
8}
599cee73
PM
9use strict ;
10
11sub DEFAULT_ON () { 1 }
12sub DEFAULT_OFF () { 2 }
13
14my $tree = {
d3a7d8c7
GS
15
16'all' => {
e476b1b5 17 'io' => { 'pipe' => DEFAULT_OFF,
599cee73
PM
18 'unopened' => DEFAULT_OFF,
19 'closed' => DEFAULT_OFF,
20 'newline' => DEFAULT_OFF,
21 'exec' => DEFAULT_OFF,
99ef548b 22 'layer' => DEFAULT_OFF,
599cee73 23 },
e476b1b5 24 'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73 25 'semicolon' => DEFAULT_OFF,
e476b1b5 26 'precedence' => DEFAULT_OFF,
4673fc70 27 'bareword' => DEFAULT_OFF,
599cee73 28 'reserved' => DEFAULT_OFF,
627300f0 29 'digit' => DEFAULT_OFF,
599cee73 30 'parenthesis' => DEFAULT_OFF,
599cee73 31 'printf' => DEFAULT_OFF,
e476b1b5
GS
32 'prototype' => DEFAULT_OFF,
33 'qw' => DEFAULT_OFF,
599cee73 34 },
e476b1b5 35 'severe' => { 'inplace' => DEFAULT_ON,
0453d815
PM
36 'internal' => DEFAULT_ON,
37 'debugging' => DEFAULT_ON,
e476b1b5 38 'malloc' => DEFAULT_ON,
0453d815 39 },
12bcd1a6 40 'deprecated' => DEFAULT_OFF,
e476b1b5
GS
41 'void' => DEFAULT_OFF,
42 'recursion' => DEFAULT_OFF,
43 'redefine' => DEFAULT_OFF,
44 'numeric' => DEFAULT_OFF,
45 'uninitialized' => DEFAULT_OFF,
46 'once' => DEFAULT_OFF,
47 'misc' => DEFAULT_OFF,
48 'regexp' => DEFAULT_OFF,
49 'glob' => DEFAULT_OFF,
50 'y2k' => DEFAULT_OFF,
e476b1b5
GS
51 'untie' => DEFAULT_OFF,
52 'substr' => DEFAULT_OFF,
53 'taint' => DEFAULT_OFF,
54 'signal' => DEFAULT_OFF,
55 'closure' => DEFAULT_OFF,
56 'overflow' => DEFAULT_OFF,
57 'portable' => DEFAULT_OFF,
58 'utf8' => DEFAULT_OFF,
59 'exiting' => DEFAULT_OFF,
60 'pack' => DEFAULT_OFF,
61 'unpack' => DEFAULT_OFF,
0453d815 62 #'default' => DEFAULT_ON,
d3a7d8c7
GS
63 }
64} ;
599cee73
PM
65
66
67###########################################################################
68sub tab {
69 my($l, $t) = @_;
70 $t .= "\t" x ($l - (length($t) + 1) / 8);
71 $t;
72}
73
74###########################################################################
75
76my %list ;
77my %Value ;
d3a7d8c7 78my $index ;
599cee73
PM
79
80sub walk
81{
82 my $tre = shift ;
83 my @list = () ;
84 my ($k, $v) ;
85
95dfd3ab
GS
86 foreach $k (sort keys %$tre) {
87 $v = $tre->{$k};
599cee73
PM
88 die "duplicate key $k\n" if defined $list{$k} ;
89 $Value{$index} = uc $k ;
90 push @{ $list{$k} }, $index ++ ;
91 if (ref $v)
92 { push (@{ $list{$k} }, walk ($v)) }
93 push @list, @{ $list{$k} } ;
94 }
95
96 return @list ;
599cee73
PM
97}
98
99###########################################################################
100
101sub mkRange
102{
103 my @a = @_ ;
104 my @out = @a ;
105 my $i ;
106
107
108 for ($i = 1 ; $i < @a; ++ $i) {
0ca4541c 109 $out[$i] = ".."
599cee73
PM
110 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
111 }
112
113 my $out = join(",",@out);
114
115 $out =~ s/,(\.\.,)+/../g ;
116 return $out;
117}
118
119###########################################################################
e476b1b5
GS
120sub printTree
121{
122 my $tre = shift ;
123 my $prefix = shift ;
124 my $indent = shift ;
125 my ($k, $v) ;
126
127 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
128
129 $prefix .= " " x $indent ;
130 foreach $k (sort keys %$tre) {
131 $v = $tre->{$k};
132 print $prefix . "|\n" ;
133 print $prefix . "+- $k" ;
134 if (ref $v)
0ca4541c 135 {
e476b1b5 136 print " " . "-" x ($max - length $k ) . "+\n" ;
0ca4541c 137 printTree ($v, $prefix . "|" , $max + $indent - 1)
e476b1b5
GS
138 }
139 else
140 { print "\n" }
141 }
142
143}
144
145###########################################################################
599cee73 146
317ea90d 147sub mkHexOct
599cee73 148{
317ea90d 149 my ($f, $max, @a) = @_ ;
599cee73
PM
150 my $mask = "\x00" x $max ;
151 my $string = "" ;
152
153 foreach (@a) {
154 vec($mask, $_, 1) = 1 ;
155 }
156
599cee73 157 foreach (unpack("C*", $mask)) {
317ea90d
MS
158 if ($f eq 'x') {
159 $string .= '\x' . sprintf("%2.2x", $_)
160 }
161 else {
162 $string .= '\\' . sprintf("%o", $_)
163 }
599cee73
PM
164 }
165 return $string ;
166}
167
317ea90d
MS
168sub mkHex
169{
170 my($max, @a) = @_;
171 return mkHexOct("x", $max, @a);
172}
173
174sub mkOct
175{
176 my($max, @a) = @_;
177 return mkHexOct("o", $max, @a);
178}
179
599cee73
PM
180###########################################################################
181
e476b1b5
GS
182if (@ARGV && $ARGV[0] eq "tree")
183{
d3a7d8c7 184 #print " all -+\n" ;
e476b1b5
GS
185 printTree($tree, " ", 4) ;
186 exit ;
187}
599cee73 188
918426be
NC
189unlink "warnings.h";
190unlink "lib/warnings.pm";
4438c4b7
JH
191open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
192open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
193
194print WARN <<'EOM' ;
195/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 196 This file is built by warnings.pl
599cee73
PM
197 Any changes made here will be lost!
198*/
199
200
0453d815
PM
201#define Off(x) ((x) / 8)
202#define Bit(x) (1 << ((x) % 8))
599cee73
PM
203#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
204
0453d815 205
599cee73 206#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 207#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
208#define G_WARN_ALL_ON 2 /* -W flag */
209#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 210#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
211#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
212
d3a7d8c7
GS
213#define pWARN_STD Nullsv
214#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
215#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 216
d3a7d8c7
GS
217#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
218 (x) == pWARN_NONE)
599cee73
PM
219EOM
220
d3a7d8c7
GS
221my $offset = 0 ;
222
223$index = $offset ;
224#@{ $list{"all"} } = walk ($tree) ;
225walk ($tree) ;
599cee73 226
12bcd1a6
PM
227die <<EOM if $index > 255 ;
228Too many warnings categories -- max is 255
229 rewrite packWARN* & unpackWARN* macros
230EOM
599cee73
PM
231
232$index *= 2 ;
233my $warn_size = int($index / 8) + ($index % 8 != 0) ;
234
235my $k ;
236foreach $k (sort { $a <=> $b } keys %Value) {
237 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
238}
239print WARN "\n" ;
240
241print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
242#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
243print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
244print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d
MS
245my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
246
247print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73
PM
248
249print WARN <<'EOM';
250
d5a71f30
GS
251#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
252#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
253#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
254#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
255#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
256
d5a71f30
GS
257#define ckWARN(x) \
258 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
259 (PL_curcop->cop_warnings == pWARN_ALL || \
260 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
261 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
262
263#define ckWARN2(x,y) \
264 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
265 (PL_curcop->cop_warnings == pWARN_ALL || \
266 isWARN_on(PL_curcop->cop_warnings, x) || \
267 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
268 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
269
12bcd1a6
PM
270#define ckWARN3(x,y,z) \
271 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
272 (PL_curcop->cop_warnings == pWARN_ALL || \
273 isWARN_on(PL_curcop->cop_warnings, x) || \
274 isWARN_on(PL_curcop->cop_warnings, y) || \
275 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
276 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
277
278#define ckWARN4(x,y,z,t) \
279 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
280 (PL_curcop->cop_warnings == pWARN_ALL || \
281 isWARN_on(PL_curcop->cop_warnings, x) || \
282 isWARN_on(PL_curcop->cop_warnings, y) || \
283 isWARN_on(PL_curcop->cop_warnings, z) || \
284 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
285 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
286
d5a71f30
GS
287#define ckWARN_d(x) \
288 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
289 (PL_curcop->cop_warnings != pWARN_NONE && \
290 isWARN_on(PL_curcop->cop_warnings, x) ) )
291
292#define ckWARN2_d(x,y) \
293 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
294 (PL_curcop->cop_warnings != pWARN_NONE && \
295 (isWARN_on(PL_curcop->cop_warnings, x) || \
296 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
297
12bcd1a6
PM
298#define ckWARN3_d(x,y,z) \
299 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
300 (PL_curcop->cop_warnings != pWARN_NONE && \
301 (isWARN_on(PL_curcop->cop_warnings, x) || \
302 isWARN_on(PL_curcop->cop_warnings, y) || \
303 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
304
305#define ckWARN4_d(x,y,z,t) \
306 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
307 (PL_curcop->cop_warnings != pWARN_NONE && \
308 (isWARN_on(PL_curcop->cop_warnings, x) || \
309 isWARN_on(PL_curcop->cop_warnings, y) || \
310 isWARN_on(PL_curcop->cop_warnings, z) || \
311 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
312
313#define packWARN(a) (a )
314#define packWARN2(a,b) ((a) | (b)<<8 )
315#define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
316#define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
317
318#define unpackWARN1(x) ((x) & 0xFF)
319#define unpackWARN2(x) (((x) >>8) & 0xFF)
320#define unpackWARN3(x) (((x) >>16) & 0xFF)
321#define unpackWARN4(x) (((x) >>24) & 0xFF)
322
323#define ckDEAD(x) \
324 ( ! specialWARN(PL_curcop->cop_warnings) && \
325 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
326 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
327 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
328 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
329 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
330
4438c4b7 331/* end of file warnings.h */
599cee73
PM
332
333EOM
334
335close WARN ;
336
337while (<DATA>) {
338 last if /^KEYWORDS$/ ;
339 print PM $_ ;
340}
341
d3a7d8c7
GS
342#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
343
344#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
345
346print PM "%Offsets = (\n" ;
347foreach my $k (sort { $a <=> $b } keys %Value) {
348 my $v = lc $Value{$k} ;
349 $k *= 2 ;
350 print PM tab(4, " '$v'"), "=> $k,\n" ;
351}
352
353print PM " );\n\n" ;
354
599cee73
PM
355print PM "%Bits = (\n" ;
356foreach $k (sort keys %list) {
357
358 my $v = $list{$k} ;
359 my @list = sort { $a <=> $b } @$v ;
360
0ca4541c
NIS
361 print PM tab(4, " '$k'"), '=> "',
362 # mkHex($warn_size, @list),
363 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
364 '", # [', mkRange(@list), "]\n" ;
365}
366
367print PM " );\n\n" ;
368
369print PM "%DeadBits = (\n" ;
370foreach $k (sort keys %list) {
371
372 my $v = $list{$k} ;
373 my @list = sort { $a <=> $b } @$v ;
374
0ca4541c
NIS
375 print PM tab(4, " '$k'"), '=> "',
376 # mkHex($warn_size, @list),
377 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
378 '", # [', mkRange(@list), "]\n" ;
379}
380
381print PM " );\n\n" ;
d3a7d8c7
GS
382print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
383print PM '$LAST_BIT = ' . "$index ;\n" ;
384print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
385while (<DATA>) {
386 print PM $_ ;
387}
388
389close PM ;
390
391__END__
392
4438c4b7 393# This file was created by warnings.pl
599cee73
PM
394# Any changes made here will be lost.
395#
396
4438c4b7 397package warnings;
599cee73 398
b75c8c73
MS
399our $VERSION = '1.00';
400
599cee73
PM
401=head1 NAME
402
4438c4b7 403warnings - Perl pragma to control optional warnings
599cee73
PM
404
405=head1 SYNOPSIS
406
4438c4b7
JH
407 use warnings;
408 no warnings;
599cee73 409
4438c4b7
JH
410 use warnings "all";
411 no warnings "all";
599cee73 412
d3a7d8c7
GS
413 use warnings::register;
414 if (warnings::enabled()) {
415 warnings::warn("some warning");
416 }
417
418 if (warnings::enabled("void")) {
e476b1b5
GS
419 warnings::warn("void", "some warning");
420 }
421
7e6d00f8
PM
422 if (warnings::enabled($object)) {
423 warnings::warn($object, "some warning");
424 }
425
721f911b
PM
426 warnings::warnif("some warning");
427 warnings::warnif("void", "some warning");
428 warnings::warnif($object, "some warning");
7e6d00f8 429
599cee73
PM
430=head1 DESCRIPTION
431
0453d815
PM
432If no import list is supplied, all possible warnings are either enabled
433or disabled.
599cee73 434
0ca4541c 435A number of functions are provided to assist module authors.
e476b1b5
GS
436
437=over 4
438
d3a7d8c7
GS
439=item use warnings::register
440
7e6d00f8
PM
441Creates a new warnings category with the same name as the package where
442the call to the pragma is used.
443
444=item warnings::enabled()
445
446Use the warnings category with the same name as the current package.
447
448Return TRUE if that warnings category is enabled in the calling module.
449Otherwise returns FALSE.
450
451=item warnings::enabled($category)
452
453Return TRUE if the warnings category, C<$category>, is enabled in the
454calling module.
455Otherwise returns FALSE.
456
457=item warnings::enabled($object)
458
459Use the name of the class for the object reference, C<$object>, as the
460warnings category.
461
462Return TRUE if that warnings category is enabled in the first scope
463where the object is used.
464Otherwise returns FALSE.
465
466=item warnings::warn($message)
467
468Print C<$message> to STDERR.
469
470Use the warnings category with the same name as the current package.
471
472If that warnings category has been set to "FATAL" in the calling module
473then die. Otherwise return.
474
475=item warnings::warn($category, $message)
476
477Print C<$message> to STDERR.
478
479If the warnings category, C<$category>, has been set to "FATAL" in the
480calling module then die. Otherwise return.
d3a7d8c7 481
7e6d00f8 482=item warnings::warn($object, $message)
e476b1b5 483
7e6d00f8 484Print C<$message> to STDERR.
e476b1b5 485
7e6d00f8
PM
486Use the name of the class for the object reference, C<$object>, as the
487warnings category.
e476b1b5 488
7e6d00f8
PM
489If that warnings category has been set to "FATAL" in the scope where C<$object>
490is first used then die. Otherwise return.
599cee73 491
e476b1b5 492
7e6d00f8
PM
493=item warnings::warnif($message)
494
495Equivalent to:
496
497 if (warnings::enabled())
498 { warnings::warn($message) }
499
500=item warnings::warnif($category, $message)
501
502Equivalent to:
503
504 if (warnings::enabled($category))
505 { warnings::warn($category, $message) }
506
507=item warnings::warnif($object, $message)
508
509Equivalent to:
510
511 if (warnings::enabled($object))
512 { warnings::warn($object, $message) }
d3a7d8c7 513
e476b1b5
GS
514=back
515
749f83fa 516See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
517
518=cut
519
520use Carp ;
521
522KEYWORDS
523
d3a7d8c7
GS
524$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
525
c3186b65
PM
526sub Croaker
527{
528 delete $Carp::CarpInternal{'warnings'};
529 croak @_ ;
530}
531
599cee73
PM
532sub bits {
533 my $mask ;
534 my $catmask ;
535 my $fatal = 0 ;
536 foreach my $word (@_) {
327afb7f
GS
537 if ($word eq 'FATAL') {
538 $fatal = 1;
539 }
d3a7d8c7
GS
540 elsif ($catmask = $Bits{$word}) {
541 $mask |= $catmask ;
542 $mask |= $DeadBits{$word} if $fatal ;
599cee73 543 }
d3a7d8c7 544 else
c3186b65 545 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
546 }
547
548 return $mask ;
549}
550
551sub import {
552 shift;
f1f33818
PM
553 my $mask = ${^WARNING_BITS} ;
554 if (vec($mask, $Offsets{'all'}, 1)) {
555 $mask |= $Bits{'all'} ;
556 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
557 }
558 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
559}
560
561sub unimport {
562 shift;
d3a7d8c7
GS
563 my $mask = ${^WARNING_BITS} ;
564 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 565 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
566 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
567 }
08540116 568 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
569}
570
7e6d00f8 571sub __chk
599cee73 572{
d3a7d8c7
GS
573 my $category ;
574 my $offset ;
7e6d00f8 575 my $isobj = 0 ;
d3a7d8c7
GS
576
577 if (@_) {
578 # check the category supplied.
579 $category = shift ;
7e6d00f8 580 if (ref $category) {
c3186b65 581 Croaker ("not an object")
3d1a39c8 582 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
583 $category = $1 ;
584 $isobj = 1 ;
585 }
d3a7d8c7 586 $offset = $Offsets{$category};
c3186b65 587 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
588 unless defined $offset;
589 }
590 else {
0ca4541c 591 $category = (caller(1))[0] ;
d3a7d8c7 592 $offset = $Offsets{$category};
c3186b65 593 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
594 unless defined $offset ;
595 }
596
0ca4541c 597 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
598 my $i = 2 ;
599 my $pkg ;
600
601 if ($isobj) {
602 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
603 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
604 }
605 $i -= 2 ;
606 }
607 else {
608 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
609 last if $pkg ne $this_pkg ;
610 }
0ca4541c 611 $i = 2
7e6d00f8
PM
612 if !$pkg || $pkg eq $this_pkg ;
613 }
614
0ca4541c 615 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
616 return ($callers_bitmask, $offset, $i) ;
617}
618
619sub enabled
620{
c3186b65 621 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
622 unless @_ == 1 || @_ == 0 ;
623
624 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
625
626 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
627 return vec($callers_bitmask, $offset, 1) ||
628 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
629}
630
d3a7d8c7 631
e476b1b5
GS
632sub warn
633{
c3186b65 634 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 635 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 636
7e6d00f8
PM
637 my $message = pop ;
638 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 639 croak($message)
d3a7d8c7
GS
640 if vec($callers_bitmask, $offset+1, 1) ||
641 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
642 carp($message) ;
643}
644
7e6d00f8
PM
645sub warnif
646{
c3186b65 647 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
648 unless @_ == 2 || @_ == 1 ;
649
650 my $message = pop ;
651 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 652
0ca4541c 653 return
7e6d00f8
PM
654 unless defined $callers_bitmask &&
655 (vec($callers_bitmask, $offset, 1) ||
656 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
657
0ca4541c 658 croak($message)
7e6d00f8
PM
659 if vec($callers_bitmask, $offset+1, 1) ||
660 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
661
662 carp($message) ;
663}
599cee73 6641;