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