3 # Regenerate (overwriting only if changed):
8 # from information hardcoded into this script (the $tree hash), plus the
9 # template for warnings.pm in the DATA section.
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.
14 # This script is normally invoked from regen.pl.
19 require 'regen_lib.pl';
24 sub DEFAULT_ON () { 1 }
25 sub DEFAULT_OFF () { 2 }
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],
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 'illegalproto' => [ 5.011, DEFAULT_OFF],
51 'severe' => [ 5.008, {
52 'inplace' => [ 5.008, DEFAULT_ON],
53 'internal' => [ 5.008, DEFAULT_ON],
54 'debugging' => [ 5.008, DEFAULT_ON],
55 'malloc' => [ 5.008, DEFAULT_ON],
57 'deprecated' => [ 5.008, DEFAULT_OFF],
58 'void' => [ 5.008, DEFAULT_OFF],
59 'recursion' => [ 5.008, DEFAULT_OFF],
60 'redefine' => [ 5.008, DEFAULT_OFF],
61 'numeric' => [ 5.008, DEFAULT_OFF],
62 'uninitialized' => [ 5.008, DEFAULT_OFF],
63 'once' => [ 5.008, DEFAULT_OFF],
64 'misc' => [ 5.008, DEFAULT_OFF],
65 'regexp' => [ 5.008, DEFAULT_OFF],
66 'glob' => [ 5.008, DEFAULT_OFF],
67 'untie' => [ 5.008, DEFAULT_OFF],
68 'substr' => [ 5.008, DEFAULT_OFF],
69 'taint' => [ 5.008, DEFAULT_OFF],
70 'signal' => [ 5.008, DEFAULT_OFF],
71 'closure' => [ 5.008, DEFAULT_OFF],
72 'overflow' => [ 5.008, DEFAULT_OFF],
73 'portable' => [ 5.008, DEFAULT_OFF],
74 'utf8' => [ 5.008, DEFAULT_OFF],
75 'exiting' => [ 5.008, DEFAULT_OFF],
76 'pack' => [ 5.008, DEFAULT_OFF],
77 'unpack' => [ 5.008, DEFAULT_OFF],
78 'threads' => [ 5.008, DEFAULT_OFF],
79 'imprecision' => [ 5.011, DEFAULT_OFF],
81 #'default' => [ 5.008, DEFAULT_ON ],
85 ###########################################################################
88 $t .= "\t" x ($l - (length($t) + 1) / 8);
92 ###########################################################################
108 foreach $k (sort keys %$tre) {
110 die "duplicate key $k\n" if defined $list{$k} ;
111 die "Value associated with key '$k' is not an ARRAY reference"
112 if !ref $v || ref $v ne 'ARRAY' ;
114 my ($ver, $rest) = @{ $v } ;
115 push @{ $v_list{$ver} }, $k;
118 { valueWalk ($rest) }
127 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
128 foreach my $name (@{ $v_list{$ver} } ) {
129 $ValueToName{ $index } = [ uc $name, $ver ] ;
130 $NameToValue{ uc $name } = $index ++ ;
137 ###########################################################################
145 foreach $k (sort keys %$tre) {
147 die "duplicate key $k\n" if defined $list{$k} ;
148 #$Value{$index} = uc $k ;
149 die "Can't find key '$k'"
150 if ! defined $NameToValue{uc $k} ;
151 push @{ $list{$k} }, $NameToValue{uc $k} ;
152 die "Value associated with key '$k' is not an ARRAY reference"
153 if !ref $v || ref $v ne 'ARRAY' ;
155 my ($ver, $rest) = @{ $v } ;
157 { push (@{ $list{$k} }, walk ($rest)) }
159 push @list, @{ $list{$k} } ;
165 ###########################################################################
174 for ($i = 1 ; $i < @a; ++ $i) {
176 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
179 my $out = join(",",@out);
181 $out =~ s/,(\.\.,)+/../g ;
185 ###########################################################################
192 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
193 my @keys = sort keys %$tre ;
195 while ($k = shift @keys) {
197 die "Value associated with key '$k' is not an ARRAY reference"
198 if !ref $v || ref $v ne 'ARRAY' ;
202 print $prefix . "|\n" ;
203 print $prefix . "+- $k" ;
204 $offset = ' ' x ($max + 4) ;
207 print $prefix . "$k" ;
208 $offset = ' ' x ($max + 1) ;
211 my ($ver, $rest) = @{ $v } ;
214 my $bar = @keys ? "|" : " ";
215 print " -" . "-" x ($max - length $k ) . "+\n" ;
216 printTree ($rest, $prefix . $bar . $offset )
224 ###########################################################################
228 my ($f, $max, @a) = @_ ;
229 my $mask = "\x00" x $max ;
233 vec($mask, $_, 1) = 1 ;
236 foreach (unpack("C*", $mask)) {
238 $string .= '\x' . sprintf("%2.2x", $_)
241 $string .= '\\' . sprintf("%o", $_)
250 return mkHexOct("x", $max, @a);
256 return mkHexOct("o", $max, @a);
259 ###########################################################################
261 if (@ARGV && $ARGV[0] eq "tree")
263 printTree($tree, " ") ;
267 my $warn = safer_open("warnings.h-new");
268 my $pm = safer_open("lib/warnings.pm-new");
270 print $warn <<'EOM' ;
271 /* -*- buffer-read-only: t -*-
272 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
273 This file is built by warnings.pl
274 Any changes made here will be lost!
278 #define Off(x) ((x) / 8)
279 #define Bit(x) (1 << ((x) % 8))
280 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
283 #define G_WARN_OFF 0 /* $^W == 0 */
284 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
285 #define G_WARN_ALL_ON 2 /* -W flag */
286 #define G_WARN_ALL_OFF 4 /* -X flag */
287 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
288 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
290 #define pWARN_STD NULL
291 #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
292 #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
294 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
297 /* if PL_warnhook is set to this value, then warnings die */
298 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
304 #@{ $list{"all"} } = walk ($tree) ;
306 my $index = orderValues();
308 die <<EOM if $index > 255 ;
309 Too many warnings categories -- max is 255
310 rewrite packWARN* & unpackWARN* macros
316 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
320 foreach $k (sort { $a <=> $b } keys %ValueToName) {
321 my ($name, $version) = @{ $ValueToName{$k} };
322 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
323 if $last_ver != $version ;
324 print $warn tab(5, "#define WARN_$name"), "$k\n" ;
325 $last_ver = $version ;
329 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
330 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
331 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
332 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
336 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
337 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
338 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
339 #define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
340 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
342 #define DUP_WARNINGS(p) \
343 (specialWARN(p) ? (STRLEN*)(p) \
344 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
347 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
348 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
349 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
350 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
352 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
353 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
354 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
355 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
359 #define packWARN(a) (a )
360 #define packWARN2(a,b) ((a) | ((b)<<8) )
361 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
362 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
364 #define unpackWARN1(x) ((x) & 0xFF)
365 #define unpackWARN2(x) (((x) >>8) & 0xFF)
366 #define unpackWARN3(x) (((x) >>16) & 0xFF)
367 #define unpackWARN4(x) (((x) >>24) & 0xFF)
370 ( ! specialWARN(PL_curcop->cop_warnings) && \
371 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
372 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
373 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
374 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
375 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
377 /* end of file warnings.h */
382 rename_if_different("warnings.h-new", "warnings.h");
385 last if /^KEYWORDS$/ ;
389 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
392 print $pm "our %Offsets = (\n" ;
393 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
394 my ($name, $version) = @{ $ValueToName{$k} };
397 if ( $last_ver != $version ) {
399 print $pm tab(4, " # Warnings Categories added in Perl $version");
402 print $pm tab(4, " '$name'"), "=> $k,\n" ;
403 $last_ver = $version;
406 print $pm " );\n\n" ;
408 print $pm "our %Bits = (\n" ;
409 foreach $k (sort keys %list) {
412 my @list = sort { $a <=> $b } @$v ;
414 print $pm tab(4, " '$k'"), '=> "',
415 # mkHex($warn_size, @list),
416 mkHex($warn_size, map $_ * 2 , @list),
417 '", # [', mkRange(@list), "]\n" ;
420 print $pm " );\n\n" ;
422 print $pm "our %DeadBits = (\n" ;
423 foreach $k (sort keys %list) {
426 my @list = sort { $a <=> $b } @$v ;
428 print $pm tab(4, " '$k'"), '=> "',
429 # mkHex($warn_size, @list),
430 mkHex($warn_size, map $_ * 2 + 1 , @list),
431 '", # [', mkRange(@list), "]\n" ;
434 print $pm " );\n\n" ;
435 print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
436 print $pm '$LAST_BIT = ' . "$index ;\n" ;
437 print $pm '$BYTES = ' . "$warn_size ;\n" ;
442 print $pm "# ex: set ro:\n";
444 rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
447 # -*- buffer-read-only: t -*-
448 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
449 # This file was created by warnings.pl
450 # Any changes made here will be lost.
455 our $VERSION = '1.10';
457 # Verify that we're called correctly so that warnings will work.
458 # see also strict.pm.
459 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
460 my (undef, $f, $l) = caller;
461 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
466 warnings - Perl pragma to control optional warnings
476 use warnings::register;
477 if (warnings::enabled()) {
478 warnings::warn("some warning");
481 if (warnings::enabled("void")) {
482 warnings::warn("void", "some warning");
485 if (warnings::enabled($object)) {
486 warnings::warn($object, "some warning");
489 warnings::warnif("some warning");
490 warnings::warnif("void", "some warning");
491 warnings::warnif($object, "some warning");
495 The C<warnings> pragma is a replacement for the command line flag C<-w>,
496 but the pragma is limited to the enclosing block, while the flag is global.
497 See L<perllexwarn> for more information.
499 If no import list is supplied, all possible warnings are either enabled
502 A number of functions are provided to assist module authors.
506 =item use warnings::register
508 Creates a new warnings category with the same name as the package where
509 the call to the pragma is used.
511 =item warnings::enabled()
513 Use the warnings category with the same name as the current package.
515 Return TRUE if that warnings category is enabled in the calling module.
516 Otherwise returns FALSE.
518 =item warnings::enabled($category)
520 Return TRUE if the warnings category, C<$category>, is enabled in the
522 Otherwise returns FALSE.
524 =item warnings::enabled($object)
526 Use the name of the class for the object reference, C<$object>, as the
529 Return TRUE if that warnings category is enabled in the first scope
530 where the object is used.
531 Otherwise returns FALSE.
533 =item warnings::fatal_enabled()
535 Return TRUE if the warnings category with the same name as the current
536 package has been set to FATAL in the calling module.
537 Otherwise returns FALSE.
539 =item warnings::fatal_enabled($category)
541 Return TRUE if the warnings category C<$category> has been set to FATAL in
543 Otherwise returns FALSE.
545 =item warnings::fatal_enabled($object)
547 Use the name of the class for the object reference, C<$object>, as the
550 Return TRUE if that warnings category has been set to FATAL in the first
551 scope where the object is used.
552 Otherwise returns FALSE.
554 =item warnings::warn($message)
556 Print C<$message> to STDERR.
558 Use the warnings category with the same name as the current package.
560 If that warnings category has been set to "FATAL" in the calling module
561 then die. Otherwise return.
563 =item warnings::warn($category, $message)
565 Print C<$message> to STDERR.
567 If the warnings category, C<$category>, has been set to "FATAL" in the
568 calling module then die. Otherwise return.
570 =item warnings::warn($object, $message)
572 Print C<$message> to STDERR.
574 Use the name of the class for the object reference, C<$object>, as the
577 If that warnings category has been set to "FATAL" in the scope where C<$object>
578 is first used then die. Otherwise return.
581 =item warnings::warnif($message)
585 if (warnings::enabled())
586 { warnings::warn($message) }
588 =item warnings::warnif($category, $message)
592 if (warnings::enabled($category))
593 { warnings::warn($category, $message) }
595 =item warnings::warnif($object, $message)
599 if (warnings::enabled($object))
600 { warnings::warn($object, $message) }
604 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
610 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
614 require Carp; # this initializes %CarpInternal
615 local $Carp::CarpInternal{'warnings'};
616 delete $Carp::CarpInternal{'warnings'};
626 foreach my $word ( @_ ) {
627 if ($word eq 'FATAL') {
631 elsif ($word eq 'NONFATAL') {
635 elsif ($catmask = $Bits{$word}) {
637 $mask |= $DeadBits{$word} if $fatal ;
638 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
641 { Croaker("Unknown warnings category '$word'")}
649 # called from B::Deparse.pm
650 push @_, 'all' unless @_ ;
651 return _bits(undef, @_) ;
658 my $mask = ${^WARNING_BITS} ;
660 if (vec($mask, $Offsets{'all'}, 1)) {
661 $mask |= $Bits{'all'} ;
662 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
665 # Empty @_ is equivalent to @_ = 'all' ;
666 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
674 my $mask = ${^WARNING_BITS} ;
676 if (vec($mask, $Offsets{'all'}, 1)) {
677 $mask |= $Bits{'all'} ;
678 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
681 push @_, 'all' unless @_;
683 foreach my $word ( @_ ) {
684 if ($word eq 'FATAL') {
687 elsif ($catmask = $Bits{$word}) {
688 $mask &= ~($catmask | $DeadBits{$word} | $All);
691 { Croaker("Unknown warnings category '$word'")}
694 ${^WARNING_BITS} = $mask ;
697 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
699 sub MESSAGE () { 4 };
709 my $has_message = $wanted & MESSAGE;
711 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
712 my $sub = (caller 1)[3];
713 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
714 Croaker("Usage: $sub($syntax)");
717 my $message = pop if $has_message;
720 # check the category supplied.
722 if (my $type = ref $category) {
723 Croaker("not an object")
724 if exists $builtin_type{$type};
728 $offset = $Offsets{$category};
729 Croaker("Unknown warnings category '$category'")
730 unless defined $offset;
733 $category = (caller(1))[0] ;
734 $offset = $Offsets{$category};
735 Croaker("package '$category' not registered for warnings")
736 unless defined $offset ;
744 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
745 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
750 $i = _error_loc(); # see where Carp will allocate the error
753 # Defaulting this to 0 reduces complexity in code paths below.
754 my $callers_bitmask = (caller($i))[9] || 0 ;
757 foreach my $type (FATAL, NORMAL) {
758 next unless $wanted & $type;
760 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
761 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
764 # &enabled and &fatal_enabled
765 return $results[0] unless $has_message;
767 # &warnif, and the category is neither enabled as warning nor as fatal
768 return if $wanted == (NORMAL | FATAL | MESSAGE)
769 && !($results[0] || $results[1]);
772 Carp::croak($message) if $results[0];
773 # will always get here for &warn. will only get here for &warnif if the
774 # category is enabled
775 Carp::carp($message);
780 goto &Carp::short_error_loc; # don't introduce another stack frame
785 return __chk(NORMAL, @_);
790 return __chk(FATAL, @_);
795 return __chk(FATAL | MESSAGE, @_);
800 return __chk(NORMAL | FATAL | MESSAGE, @_);
803 # These are not part of any public interface, so we can delete them to save
805 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);