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 # When changing the number of warnings, t/op/caller.t should change to
12 # correspond with the value of $BYTES in lib/warnings.pm
14 # With an argument of 'tree', just dump the contents of $tree and exits.
15 # Also accepts the standard regen_lib -q and -v args.
17 # This script is normally invoked from regen.pl.
22 require 'regen/regen_lib.pl';
27 sub DEFAULT_ON () { 1 }
28 sub DEFAULT_OFF () { 2 }
34 'pipe' => [ 5.008, DEFAULT_OFF],
35 'unopened' => [ 5.008, DEFAULT_OFF],
36 'closed' => [ 5.008, DEFAULT_OFF],
37 'newline' => [ 5.008, DEFAULT_OFF],
38 'exec' => [ 5.008, DEFAULT_OFF],
39 'layer' => [ 5.008, DEFAULT_OFF],
41 'syntax' => [ 5.008, {
42 'ambiguous' => [ 5.008, DEFAULT_OFF],
43 'semicolon' => [ 5.008, DEFAULT_OFF],
44 'precedence' => [ 5.008, DEFAULT_OFF],
45 'bareword' => [ 5.008, DEFAULT_OFF],
46 'reserved' => [ 5.008, DEFAULT_OFF],
47 'digit' => [ 5.008, DEFAULT_OFF],
48 'parenthesis' => [ 5.008, DEFAULT_OFF],
49 'printf' => [ 5.008, DEFAULT_OFF],
50 'prototype' => [ 5.008, DEFAULT_OFF],
51 'qw' => [ 5.008, DEFAULT_OFF],
52 'illegalproto' => [ 5.011, DEFAULT_OFF],
54 'severe' => [ 5.008, {
55 'inplace' => [ 5.008, DEFAULT_ON],
56 'internal' => [ 5.008, DEFAULT_ON],
57 'debugging' => [ 5.008, DEFAULT_ON],
58 'malloc' => [ 5.008, DEFAULT_ON],
60 'deprecated' => [ 5.008, DEFAULT_OFF],
61 'void' => [ 5.008, DEFAULT_OFF],
62 'recursion' => [ 5.008, DEFAULT_OFF],
63 'redefine' => [ 5.008, DEFAULT_OFF],
64 'numeric' => [ 5.008, DEFAULT_OFF],
65 'uninitialized' => [ 5.008, DEFAULT_OFF],
66 'once' => [ 5.008, DEFAULT_OFF],
67 'misc' => [ 5.008, DEFAULT_OFF],
68 'regexp' => [ 5.008, DEFAULT_OFF],
69 'glob' => [ 5.008, DEFAULT_OFF],
70 'untie' => [ 5.008, DEFAULT_OFF],
71 'substr' => [ 5.008, DEFAULT_OFF],
72 'taint' => [ 5.008, DEFAULT_OFF],
73 'signal' => [ 5.008, DEFAULT_OFF],
74 'closure' => [ 5.008, DEFAULT_OFF],
75 'overflow' => [ 5.008, DEFAULT_OFF],
76 'portable' => [ 5.008, DEFAULT_OFF],
78 'surrogate' => [ 5.013, DEFAULT_OFF],
79 'nonchar' => [ 5.013, DEFAULT_OFF],
80 'non_unicode' => [ 5.013, DEFAULT_OFF],
82 'exiting' => [ 5.008, DEFAULT_OFF],
83 'pack' => [ 5.008, DEFAULT_OFF],
84 'unpack' => [ 5.008, DEFAULT_OFF],
85 'threads' => [ 5.008, DEFAULT_OFF],
86 'imprecision' => [ 5.011, DEFAULT_OFF],
88 #'default' => [ 5.008, DEFAULT_ON ],
105 foreach $k (sort keys %$tre) {
107 die "duplicate key $k\n" if defined $list{$k} ;
108 die "Value associated with key '$k' is not an ARRAY reference"
109 if !ref $v || ref $v ne 'ARRAY' ;
111 my ($ver, $rest) = @{ $v } ;
112 push @{ $v_list{$ver} }, $k;
115 { valueWalk ($rest) }
124 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
125 foreach my $name (@{ $v_list{$ver} } ) {
126 $ValueToName{ $index } = [ uc $name, $ver ] ;
127 $NameToValue{ uc $name } = $index ++ ;
134 ###########################################################################
142 foreach $k (sort keys %$tre) {
144 die "duplicate key $k\n" if defined $list{$k} ;
145 die "Can't find key '$k'"
146 if ! defined $NameToValue{uc $k} ;
147 push @{ $list{$k} }, $NameToValue{uc $k} ;
148 die "Value associated with key '$k' is not an ARRAY reference"
149 if !ref $v || ref $v ne 'ARRAY' ;
151 my ($ver, $rest) = @{ $v } ;
153 { push (@{ $list{$k} }, walk ($rest)) }
155 push @list, @{ $list{$k} } ;
161 ###########################################################################
168 for my $i (1 .. @a - 1) {
170 if $a[$i] == $a[$i - 1] + 1
171 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
173 $out[-1] = $a[-1] if $out[-1] eq "..";
175 my $out = join(",",@out);
177 $out =~ s/,(\.\.,)+/../g ;
181 ###########################################################################
188 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
189 my @keys = sort keys %$tre ;
191 while ($k = shift @keys) {
193 die "Value associated with key '$k' is not an ARRAY reference"
194 if !ref $v || ref $v ne 'ARRAY' ;
198 print $prefix . "|\n" ;
199 print $prefix . "+- $k" ;
200 $offset = ' ' x ($max + 4) ;
203 print $prefix . "$k" ;
204 $offset = ' ' x ($max + 1) ;
207 my ($ver, $rest) = @{ $v } ;
210 my $bar = @keys ? "|" : " ";
211 print " -" . "-" x ($max - length $k ) . "+\n" ;
212 printTree ($rest, $prefix . $bar . $offset )
220 ###########################################################################
224 my ($f, $max, @a) = @_ ;
225 my $mask = "\x00" x $max ;
229 vec($mask, $_, 1) = 1 ;
232 foreach (unpack("C*", $mask)) {
234 $string .= '\x' . sprintf("%2.2x", $_)
237 $string .= '\\' . sprintf("%o", $_)
246 return mkHexOct("x", $max, @a);
252 return mkHexOct("o", $max, @a);
255 ###########################################################################
257 if (@ARGV && $ARGV[0] eq "tree")
259 printTree($tree, " ") ;
263 my ($warn, $pm) = map {
264 open_new($_, '>', { by => 'regen/warnings.pl' });
265 } 'warnings.h', 'lib/warnings.pm';
269 #define Off(x) ((x) / 8)
270 #define Bit(x) (1 << ((x) % 8))
271 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
274 #define G_WARN_OFF 0 /* $^W == 0 */
275 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
276 #define G_WARN_ALL_ON 2 /* -W flag */
277 #define G_WARN_ALL_OFF 4 /* -X flag */
278 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
279 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
281 #define pWARN_STD NULL
282 #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
283 #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
285 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
288 /* if PL_warnhook is set to this value, then warnings die */
289 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
295 my $index = orderValues();
297 die <<EOM if $index > 255 ;
298 Too many warnings categories -- max is 255
299 rewrite packWARN* & unpackWARN* macros
305 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
309 foreach $k (sort { $a <=> $b } keys %ValueToName) {
310 my ($name, $version) = @{ $ValueToName{$k} };
311 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
312 if $last_ver != $version ;
313 print $warn tab(5, "#define WARN_$name"), "$k\n" ;
314 $last_ver = $version ;
318 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
319 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
320 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
321 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
325 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
326 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
327 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
328 #define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
329 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
331 #define DUP_WARNINGS(p) \
332 (specialWARN(p) ? (STRLEN*)(p) \
333 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
336 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
337 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
338 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
339 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
341 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
342 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
343 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
344 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
348 #define packWARN(a) (a )
349 #define packWARN2(a,b) ((a) | ((b)<<8) )
350 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
351 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
353 #define unpackWARN1(x) ((x) & 0xFF)
354 #define unpackWARN2(x) (((x) >>8) & 0xFF)
355 #define unpackWARN3(x) (((x) >>16) & 0xFF)
356 #define unpackWARN4(x) (((x) >>24) & 0xFF)
359 ( ! specialWARN(PL_curcop->cop_warnings) && \
360 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
361 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
362 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
363 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
364 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
366 /* end of file warnings.h */
369 read_only_bottom_close_and_rename($warn);
372 last if /^KEYWORDS$/ ;
377 print $pm "our %Offsets = (\n" ;
378 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
379 my ($name, $version) = @{ $ValueToName{$k} };
382 if ( $last_ver != $version ) {
384 print $pm tab(4, " # Warnings Categories added in Perl $version");
387 print $pm tab(4, " '$name'"), "=> $k,\n" ;
388 $last_ver = $version;
391 print $pm " );\n\n" ;
393 print $pm "our %Bits = (\n" ;
394 foreach $k (sort keys %list) {
397 my @list = sort { $a <=> $b } @$v ;
399 print $pm tab(4, " '$k'"), '=> "',
400 mkHex($warn_size, map $_ * 2 , @list),
401 '", # [', mkRange(@list), "]\n" ;
404 print $pm " );\n\n" ;
406 print $pm "our %DeadBits = (\n" ;
407 foreach $k (sort keys %list) {
410 my @list = sort { $a <=> $b } @$v ;
412 print $pm tab(4, " '$k'"), '=> "',
413 mkHex($warn_size, map $_ * 2 + 1 , @list),
414 '", # [', mkRange(@list), "]\n" ;
417 print $pm " );\n\n" ;
418 print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
419 print $pm '$LAST_BIT = ' . "$index ;\n" ;
420 print $pm '$BYTES = ' . "$warn_size ;\n" ;
425 read_only_bottom_close_and_rename($pm);
430 our $VERSION = '1.13';
432 # Verify that we're called correctly so that warnings will work.
433 # see also strict.pm.
434 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
435 my (undef, $f, $l) = caller;
436 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
441 warnings - Perl pragma to control optional warnings
451 use warnings::register;
452 if (warnings::enabled()) {
453 warnings::warn("some warning");
456 if (warnings::enabled("void")) {
457 warnings::warn("void", "some warning");
460 if (warnings::enabled($object)) {
461 warnings::warn($object, "some warning");
464 warnings::warnif("some warning");
465 warnings::warnif("void", "some warning");
466 warnings::warnif($object, "some warning");
470 The C<warnings> pragma is a replacement for the command line flag C<-w>,
471 but the pragma is limited to the enclosing block, while the flag is global.
472 See L<perllexwarn> for more information and the list of built-in warning
475 If no import list is supplied, all possible warnings are either enabled
478 A number of functions are provided to assist module authors.
482 =item use warnings::register
484 Creates a new warnings category with the same name as the package where
485 the call to the pragma is used.
487 =item warnings::enabled()
489 Use the warnings category with the same name as the current package.
491 Return TRUE if that warnings category is enabled in the calling module.
492 Otherwise returns FALSE.
494 =item warnings::enabled($category)
496 Return TRUE if the warnings category, C<$category>, is enabled in the
498 Otherwise returns FALSE.
500 =item warnings::enabled($object)
502 Use the name of the class for the object reference, C<$object>, as the
505 Return TRUE if that warnings category is enabled in the first scope
506 where the object is used.
507 Otherwise returns FALSE.
509 =item warnings::fatal_enabled()
511 Return TRUE if the warnings category with the same name as the current
512 package has been set to FATAL in the calling module.
513 Otherwise returns FALSE.
515 =item warnings::fatal_enabled($category)
517 Return TRUE if the warnings category C<$category> has been set to FATAL in
519 Otherwise returns FALSE.
521 =item warnings::fatal_enabled($object)
523 Use the name of the class for the object reference, C<$object>, as the
526 Return TRUE if that warnings category has been set to FATAL in the first
527 scope where the object is used.
528 Otherwise returns FALSE.
530 =item warnings::warn($message)
532 Print C<$message> to STDERR.
534 Use the warnings category with the same name as the current package.
536 If that warnings category has been set to "FATAL" in the calling module
537 then die. Otherwise return.
539 =item warnings::warn($category, $message)
541 Print C<$message> to STDERR.
543 If the warnings category, C<$category>, has been set to "FATAL" in the
544 calling module then die. Otherwise return.
546 =item warnings::warn($object, $message)
548 Print C<$message> to STDERR.
550 Use the name of the class for the object reference, C<$object>, as the
553 If that warnings category has been set to "FATAL" in the scope where C<$object>
554 is first used then die. Otherwise return.
557 =item warnings::warnif($message)
561 if (warnings::enabled())
562 { warnings::warn($message) }
564 =item warnings::warnif($category, $message)
568 if (warnings::enabled($category))
569 { warnings::warn($category, $message) }
571 =item warnings::warnif($object, $message)
575 if (warnings::enabled($object))
576 { warnings::warn($object, $message) }
578 =item warnings::register_categories(@names)
580 This registers warning categories for the given names and is primarily for
581 use by the warnings::register pragma, for which see L<perllexwarn>.
585 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
591 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
595 require Carp; # this initializes %CarpInternal
596 local $Carp::CarpInternal{'warnings'};
597 delete $Carp::CarpInternal{'warnings'};
607 foreach my $word ( @_ ) {
608 if ($word eq 'FATAL') {
612 elsif ($word eq 'NONFATAL') {
616 elsif ($catmask = $Bits{$word}) {
618 $mask |= $DeadBits{$word} if $fatal ;
619 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
622 { Croaker("Unknown warnings category '$word'")}
630 # called from B::Deparse.pm
631 push @_, 'all' unless @_ ;
632 return _bits(undef, @_) ;
639 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
641 if (vec($mask, $Offsets{'all'}, 1)) {
642 $mask |= $Bits{'all'} ;
643 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
646 # Empty @_ is equivalent to @_ = 'all' ;
647 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
655 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
657 if (vec($mask, $Offsets{'all'}, 1)) {
658 $mask |= $Bits{'all'} ;
659 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
662 push @_, 'all' unless @_;
664 foreach my $word ( @_ ) {
665 if ($word eq 'FATAL') {
668 elsif ($catmask = $Bits{$word}) {
669 $mask &= ~($catmask | $DeadBits{$word} | $All);
672 { Croaker("Unknown warnings category '$word'")}
675 ${^WARNING_BITS} = $mask ;
678 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
680 sub MESSAGE () { 4 };
690 my $has_message = $wanted & MESSAGE;
692 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
693 my $sub = (caller 1)[3];
694 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
695 Croaker("Usage: $sub($syntax)");
698 my $message = pop if $has_message;
701 # check the category supplied.
703 if (my $type = ref $category) {
704 Croaker("not an object")
705 if exists $builtin_type{$type};
709 $offset = $Offsets{$category};
710 Croaker("Unknown warnings category '$category'")
711 unless defined $offset;
714 $category = (caller(1))[0] ;
715 $offset = $Offsets{$category};
716 Croaker("package '$category' not registered for warnings")
717 unless defined $offset ;
725 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
726 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
731 $i = _error_loc(); # see where Carp will allocate the error
734 # Defaulting this to 0 reduces complexity in code paths below.
735 my $callers_bitmask = (caller($i))[9] || 0 ;
738 foreach my $type (FATAL, NORMAL) {
739 next unless $wanted & $type;
741 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
742 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
745 # &enabled and &fatal_enabled
746 return $results[0] unless $has_message;
748 # &warnif, and the category is neither enabled as warning nor as fatal
749 return if $wanted == (NORMAL | FATAL | MESSAGE)
750 && !($results[0] || $results[1]);
753 Carp::croak($message) if $results[0];
754 # will always get here for &warn. will only get here for &warnif if the
755 # category is enabled
756 Carp::carp($message);
764 vec($mask, $bit, 1) = 1;
768 sub register_categories
772 for my $name (@names) {
773 if (! defined $Bits{$name}) {
774 $Bits{$name} = _mkMask($LAST_BIT);
775 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
776 $Offsets{$name} = $LAST_BIT ++;
777 foreach my $k (keys %Bits) {
778 vec($Bits{$k}, $LAST_BIT, 1) = 0;
780 $DeadBits{$name} = _mkMask($LAST_BIT);
781 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
788 goto &Carp::short_error_loc; # don't introduce another stack frame
793 return __chk(NORMAL, @_);
798 return __chk(FATAL, @_);
803 return __chk(FATAL | MESSAGE, @_);
808 return __chk(NORMAL | FATAL | MESSAGE, @_);
811 # These are not part of any public interface, so we can delete them to save
813 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);