This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change PerlIO_(get|set)pos to take SV *
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
b75c8c73
MS
3our $VERSION = '1.00';
4
73f0cc2d
GS
5BEGIN {
6 push @INC, './lib';
7}
599cee73
PM
8use strict ;
9
10sub DEFAULT_ON () { 1 }
11sub DEFAULT_OFF () { 2 }
12
13my $tree = {
d3a7d8c7
GS
14
15'all' => {
e476b1b5 16 'io' => { 'pipe' => DEFAULT_OFF,
599cee73
PM
17 'unopened' => DEFAULT_OFF,
18 'closed' => DEFAULT_OFF,
19 'newline' => DEFAULT_OFF,
20 'exec' => DEFAULT_OFF,
599cee73 21 },
e476b1b5 22 'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73 23 'semicolon' => DEFAULT_OFF,
e476b1b5 24 'precedence' => DEFAULT_OFF,
4673fc70 25 'bareword' => DEFAULT_OFF,
599cee73 26 'reserved' => DEFAULT_OFF,
627300f0 27 'digit' => DEFAULT_OFF,
599cee73
PM
28 'parenthesis' => DEFAULT_OFF,
29 'deprecated' => DEFAULT_OFF,
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 },
e476b1b5
GS
39 'void' => DEFAULT_OFF,
40 'recursion' => DEFAULT_OFF,
41 'redefine' => DEFAULT_OFF,
42 'numeric' => DEFAULT_OFF,
43 'uninitialized' => DEFAULT_OFF,
44 'once' => DEFAULT_OFF,
45 'misc' => DEFAULT_OFF,
46 'regexp' => DEFAULT_OFF,
47 'glob' => DEFAULT_OFF,
48 'y2k' => DEFAULT_OFF,
49 'chmod' => DEFAULT_OFF,
50 'umask' => DEFAULT_OFF,
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) {
109 $out[$i] = ".."
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)
135 {
136 print " " . "-" x ($max - length $k ) . "+\n" ;
137 printTree ($v, $prefix . "|" , $max + $indent - 1)
138 }
139 else
140 { print "\n" }
141 }
142
143}
144
145###########################################################################
599cee73
PM
146
147sub mkHex
148{
149 my ($max, @a) = @_ ;
150 my $mask = "\x00" x $max ;
151 my $string = "" ;
152
153 foreach (@a) {
154 vec($mask, $_, 1) = 1 ;
155 }
156
157 #$string = unpack("H$max", $mask) ;
158 #$string =~ s/(..)/\x$1/g;
159 foreach (unpack("C*", $mask)) {
160 $string .= '\x' . sprintf("%2.2x", $_) ;
161 }
162 return $string ;
163}
164
165###########################################################################
166
e476b1b5
GS
167if (@ARGV && $ARGV[0] eq "tree")
168{
d3a7d8c7 169 #print " all -+\n" ;
e476b1b5
GS
170 printTree($tree, " ", 4) ;
171 exit ;
172}
599cee73 173
4438c4b7
JH
174#unlink "warnings.h";
175#unlink "lib/warnings.pm";
176open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
177open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
178
179print WARN <<'EOM' ;
180/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 181 This file is built by warnings.pl
599cee73
PM
182 Any changes made here will be lost!
183*/
184
185
0453d815
PM
186#define Off(x) ((x) / 8)
187#define Bit(x) (1 << ((x) % 8))
599cee73
PM
188#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
189
0453d815 190
599cee73 191#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 192#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
193#define G_WARN_ALL_ON 2 /* -W flag */
194#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 195#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
196#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
197
d3a7d8c7
GS
198#define pWARN_STD Nullsv
199#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
200#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 201
d3a7d8c7
GS
202#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
203 (x) == pWARN_NONE)
599cee73
PM
204EOM
205
d3a7d8c7
GS
206my $offset = 0 ;
207
208$index = $offset ;
209#@{ $list{"all"} } = walk ($tree) ;
210walk ($tree) ;
599cee73 211
599cee73
PM
212
213$index *= 2 ;
214my $warn_size = int($index / 8) + ($index % 8 != 0) ;
215
216my $k ;
217foreach $k (sort { $a <=> $b } keys %Value) {
218 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
219}
220print WARN "\n" ;
221
222print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
223#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
224print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
225print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
226
227print WARN <<'EOM';
228
d5a71f30
GS
229#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
230#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
231#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
232#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
233#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
234
235#define ckDEAD(x) \
236 ( ! specialWARN(PL_curcop->cop_warnings) && \
237 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
238 isWARNf_on(PL_curcop->cop_warnings, x)))
239
240#define ckWARN(x) \
241 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
242 (PL_curcop->cop_warnings == pWARN_ALL || \
243 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
244 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
245
246#define ckWARN2(x,y) \
247 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
248 (PL_curcop->cop_warnings == pWARN_ALL || \
249 isWARN_on(PL_curcop->cop_warnings, x) || \
250 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
251 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
252
253#define ckWARN_d(x) \
254 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
255 (PL_curcop->cop_warnings != pWARN_NONE && \
256 isWARN_on(PL_curcop->cop_warnings, x) ) )
257
258#define ckWARN2_d(x,y) \
259 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
260 (PL_curcop->cop_warnings != pWARN_NONE && \
261 (isWARN_on(PL_curcop->cop_warnings, x) || \
262 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
263
4438c4b7 264/* end of file warnings.h */
599cee73
PM
265
266EOM
267
268close WARN ;
269
270while (<DATA>) {
271 last if /^KEYWORDS$/ ;
272 print PM $_ ;
273}
274
d3a7d8c7
GS
275#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
276
277#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
278
279print PM "%Offsets = (\n" ;
280foreach my $k (sort { $a <=> $b } keys %Value) {
281 my $v = lc $Value{$k} ;
282 $k *= 2 ;
283 print PM tab(4, " '$v'"), "=> $k,\n" ;
284}
285
286print PM " );\n\n" ;
287
599cee73
PM
288print PM "%Bits = (\n" ;
289foreach $k (sort keys %list) {
290
291 my $v = $list{$k} ;
292 my @list = sort { $a <=> $b } @$v ;
293
294 print PM tab(4, " '$k'"), '=> "',
295 # mkHex($warn_size, @list),
296 mkHex($warn_size, map $_ * 2 , @list),
297 '", # [', mkRange(@list), "]\n" ;
298}
299
300print PM " );\n\n" ;
301
302print PM "%DeadBits = (\n" ;
303foreach $k (sort keys %list) {
304
305 my $v = $list{$k} ;
306 my @list = sort { $a <=> $b } @$v ;
307
308 print PM tab(4, " '$k'"), '=> "',
309 # mkHex($warn_size, @list),
310 mkHex($warn_size, map $_ * 2 + 1 , @list),
311 '", # [', mkRange(@list), "]\n" ;
312}
313
314print PM " );\n\n" ;
d3a7d8c7
GS
315print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
316print PM '$LAST_BIT = ' . "$index ;\n" ;
317print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
318while (<DATA>) {
319 print PM $_ ;
320}
321
322close PM ;
323
324__END__
325
4438c4b7 326# This file was created by warnings.pl
599cee73
PM
327# Any changes made here will be lost.
328#
329
4438c4b7 330package warnings;
599cee73 331
b75c8c73
MS
332our $VERSION = '1.00';
333
599cee73
PM
334=head1 NAME
335
4438c4b7 336warnings - Perl pragma to control optional warnings
599cee73
PM
337
338=head1 SYNOPSIS
339
4438c4b7
JH
340 use warnings;
341 no warnings;
599cee73 342
4438c4b7
JH
343 use warnings "all";
344 no warnings "all";
599cee73 345
d3a7d8c7
GS
346 use warnings::register;
347 if (warnings::enabled()) {
348 warnings::warn("some warning");
349 }
350
351 if (warnings::enabled("void")) {
e476b1b5
GS
352 warnings::warn("void", "some warning");
353 }
354
7e6d00f8
PM
355 if (warnings::enabled($object)) {
356 warnings::warn($object, "some warning");
357 }
358
359 warnif("some warning");
360 warnif("void", "some warning");
361 warnif($object, "some warning");
362
599cee73
PM
363=head1 DESCRIPTION
364
0453d815
PM
365If no import list is supplied, all possible warnings are either enabled
366or disabled.
599cee73 367
d3a7d8c7 368A number of functions are provided to assist module authors.
e476b1b5
GS
369
370=over 4
371
d3a7d8c7
GS
372=item use warnings::register
373
7e6d00f8
PM
374Creates a new warnings category with the same name as the package where
375the call to the pragma is used.
376
377=item warnings::enabled()
378
379Use the warnings category with the same name as the current package.
380
381Return TRUE if that warnings category is enabled in the calling module.
382Otherwise returns FALSE.
383
384=item warnings::enabled($category)
385
386Return TRUE if the warnings category, C<$category>, is enabled in the
387calling module.
388Otherwise returns FALSE.
389
390=item warnings::enabled($object)
391
392Use the name of the class for the object reference, C<$object>, as the
393warnings category.
394
395Return TRUE if that warnings category is enabled in the first scope
396where the object is used.
397Otherwise returns FALSE.
398
399=item warnings::warn($message)
400
401Print C<$message> to STDERR.
402
403Use the warnings category with the same name as the current package.
404
405If that warnings category has been set to "FATAL" in the calling module
406then die. Otherwise return.
407
408=item warnings::warn($category, $message)
409
410Print C<$message> to STDERR.
411
412If the warnings category, C<$category>, has been set to "FATAL" in the
413calling module then die. Otherwise return.
d3a7d8c7 414
7e6d00f8 415=item warnings::warn($object, $message)
e476b1b5 416
7e6d00f8 417Print C<$message> to STDERR.
e476b1b5 418
7e6d00f8
PM
419Use the name of the class for the object reference, C<$object>, as the
420warnings category.
e476b1b5 421
7e6d00f8
PM
422If that warnings category has been set to "FATAL" in the scope where C<$object>
423is first used then die. Otherwise return.
599cee73 424
e476b1b5 425
7e6d00f8
PM
426=item warnings::warnif($message)
427
428Equivalent to:
429
430 if (warnings::enabled())
431 { warnings::warn($message) }
432
433=item warnings::warnif($category, $message)
434
435Equivalent to:
436
437 if (warnings::enabled($category))
438 { warnings::warn($category, $message) }
439
440=item warnings::warnif($object, $message)
441
442Equivalent to:
443
444 if (warnings::enabled($object))
445 { warnings::warn($object, $message) }
d3a7d8c7 446
e476b1b5
GS
447=back
448
749f83fa 449See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
450
451=cut
452
453use Carp ;
454
455KEYWORDS
456
d3a7d8c7
GS
457$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
458
599cee73
PM
459sub bits {
460 my $mask ;
461 my $catmask ;
462 my $fatal = 0 ;
463 foreach my $word (@_) {
327afb7f
GS
464 if ($word eq 'FATAL') {
465 $fatal = 1;
466 }
d3a7d8c7
GS
467 elsif ($catmask = $Bits{$word}) {
468 $mask |= $catmask ;
469 $mask |= $DeadBits{$word} if $fatal ;
599cee73 470 }
d3a7d8c7
GS
471 else
472 { croak("unknown warnings category '$word'")}
599cee73
PM
473 }
474
475 return $mask ;
476}
477
478sub import {
479 shift;
f1f33818
PM
480 my $mask = ${^WARNING_BITS} ;
481 if (vec($mask, $Offsets{'all'}, 1)) {
482 $mask |= $Bits{'all'} ;
483 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
484 }
485 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
486}
487
488sub unimport {
489 shift;
d3a7d8c7
GS
490 my $mask = ${^WARNING_BITS} ;
491 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 492 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
493 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
494 }
495 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
599cee73
PM
496}
497
7e6d00f8 498sub __chk
599cee73 499{
d3a7d8c7
GS
500 my $category ;
501 my $offset ;
7e6d00f8 502 my $isobj = 0 ;
d3a7d8c7
GS
503
504 if (@_) {
505 # check the category supplied.
506 $category = shift ;
7e6d00f8
PM
507 if (ref $category) {
508 croak ("not an object")
509 if $category !~ /^([^=]+)=/ ;+
510 $category = $1 ;
511 $isobj = 1 ;
512 }
d3a7d8c7
GS
513 $offset = $Offsets{$category};
514 croak("unknown warnings category '$category'")
515 unless defined $offset;
516 }
517 else {
7e6d00f8 518 $category = (caller(1))[0] ;
d3a7d8c7
GS
519 $offset = $Offsets{$category};
520 croak("package '$category' not registered for warnings")
521 unless defined $offset ;
522 }
523
7e6d00f8
PM
524 my $this_pkg = (caller(1))[0] ;
525 my $i = 2 ;
526 my $pkg ;
527
528 if ($isobj) {
529 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
530 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
531 }
532 $i -= 2 ;
533 }
534 else {
535 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
536 last if $pkg ne $this_pkg ;
537 }
538 $i = 2
539 if !$pkg || $pkg eq $this_pkg ;
540 }
541
542 my $callers_bitmask = (caller($i))[9] ;
543 return ($callers_bitmask, $offset, $i) ;
544}
545
546sub enabled
547{
548 croak("Usage: warnings::enabled([category])")
549 unless @_ == 1 || @_ == 0 ;
550
551 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
552
553 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
554 return vec($callers_bitmask, $offset, 1) ||
555 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
556}
557
d3a7d8c7 558
e476b1b5
GS
559sub warn
560{
d3a7d8c7
GS
561 croak("Usage: warnings::warn([category,] 'message')")
562 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 563
7e6d00f8
PM
564 my $message = pop ;
565 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
566 local $Carp::CarpLevel = $i ;
e476b1b5 567 croak($message)
d3a7d8c7
GS
568 if vec($callers_bitmask, $offset+1, 1) ||
569 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
570 carp($message) ;
571}
572
7e6d00f8
PM
573sub warnif
574{
575 croak("Usage: warnings::warnif([category,] 'message')")
576 unless @_ == 2 || @_ == 1 ;
577
578 my $message = pop ;
579 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
580 local $Carp::CarpLevel = $i ;
581
582 return
583 unless defined $callers_bitmask &&
584 (vec($callers_bitmask, $offset, 1) ||
585 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
586
587 croak($message)
588 if vec($callers_bitmask, $offset+1, 1) ||
589 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
590
591 carp($message) ;
592}
599cee73 5931;