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 ###########################################################################
107 foreach $k (sort keys %$tre) {
109 die "duplicate key $k\n" if defined $list{$k} ;
110 die "Value associated with key '$k' is not an ARRAY reference"
111 if !ref $v || ref $v ne 'ARRAY' ;
113 my ($ver, $rest) = @{ $v } ;
114 push @{ $v_list{$ver} }, $k;
117 { valueWalk ($rest) }
126 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
127 foreach my $name (@{ $v_list{$ver} } ) {
128 $ValueToName{ $index } = [ uc $name, $ver ] ;
129 $NameToValue{ uc $name } = $index ++ ;
136 ###########################################################################
144 foreach $k (sort keys %$tre) {
146 die "duplicate key $k\n" if defined $list{$k} ;
147 die "Can't find key '$k'"
148 if ! defined $NameToValue{uc $k} ;
149 push @{ $list{$k} }, $NameToValue{uc $k} ;
150 die "Value associated with key '$k' is not an ARRAY reference"
151 if !ref $v || ref $v ne 'ARRAY' ;
153 my ($ver, $rest) = @{ $v } ;
155 { push (@{ $list{$k} }, walk ($rest)) }
157 push @list, @{ $list{$k} } ;
163 ###########################################################################
170 for my $i (1 .. @a - 1) {
172 if $a[$i] == $a[$i - 1] + 1
173 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
175 $out[-1] = $a[-1] if $out[-1] eq "..";
177 my $out = join(",",@out);
179 $out =~ s/,(\.\.,)+/../g ;
183 ###########################################################################
190 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
191 my @keys = sort keys %$tre ;
193 while ($k = shift @keys) {
195 die "Value associated with key '$k' is not an ARRAY reference"
196 if !ref $v || ref $v ne 'ARRAY' ;
200 print $prefix . "|\n" ;
201 print $prefix . "+- $k" ;
202 $offset = ' ' x ($max + 4) ;
205 print $prefix . "$k" ;
206 $offset = ' ' x ($max + 1) ;
209 my ($ver, $rest) = @{ $v } ;
212 my $bar = @keys ? "|" : " ";
213 print " -" . "-" x ($max - length $k ) . "+\n" ;
214 printTree ($rest, $prefix . $bar . $offset )
222 ###########################################################################
226 my ($f, $max, @a) = @_ ;
227 my $mask = "\x00" x $max ;
231 vec($mask, $_, 1) = 1 ;
234 foreach (unpack("C*", $mask)) {
236 $string .= '\x' . sprintf("%2.2x", $_)
239 $string .= '\\' . sprintf("%o", $_)
248 return mkHexOct("x", $max, @a);
254 return mkHexOct("o", $max, @a);
257 ###########################################################################
259 if (@ARGV && $ARGV[0] eq "tree")
261 printTree($tree, " ") ;
265 my $warn = safer_open("warnings.h-new");
266 my $pm = safer_open("lib/warnings.pm-new");
268 print $warn <<'EOM' ;
269 /* -*- buffer-read-only: t -*-
270 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
271 This file is built by warnings.pl
272 Any changes made here will be lost!
276 #define Off(x) ((x) / 8)
277 #define Bit(x) (1 << ((x) % 8))
278 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
281 #define G_WARN_OFF 0 /* $^W == 0 */
282 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
283 #define G_WARN_ALL_ON 2 /* -W flag */
284 #define G_WARN_ALL_OFF 4 /* -X flag */
285 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
286 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
288 #define pWARN_STD NULL
289 #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
290 #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
292 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
295 /* if PL_warnhook is set to this value, then warnings die */
296 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
302 my $index = orderValues();
304 die <<EOM if $index > 255 ;
305 Too many warnings categories -- max is 255
306 rewrite packWARN* & unpackWARN* macros
312 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
316 foreach $k (sort { $a <=> $b } keys %ValueToName) {
317 my ($name, $version) = @{ $ValueToName{$k} };
318 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
319 if $last_ver != $version ;
320 print $warn tab(5, "#define WARN_$name"), "$k\n" ;
321 $last_ver = $version ;
325 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
326 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
327 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
328 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
332 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
333 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
334 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
335 #define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
336 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
338 #define DUP_WARNINGS(p) \
339 (specialWARN(p) ? (STRLEN*)(p) \
340 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
343 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
344 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
345 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
346 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
348 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
349 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
350 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
351 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
355 #define packWARN(a) (a )
356 #define packWARN2(a,b) ((a) | ((b)<<8) )
357 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
358 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
360 #define unpackWARN1(x) ((x) & 0xFF)
361 #define unpackWARN2(x) (((x) >>8) & 0xFF)
362 #define unpackWARN3(x) (((x) >>16) & 0xFF)
363 #define unpackWARN4(x) (((x) >>24) & 0xFF)
366 ( ! specialWARN(PL_curcop->cop_warnings) && \
367 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
368 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
369 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
370 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
371 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
373 /* end of file warnings.h */
378 rename_if_different("warnings.h-new", "warnings.h");
381 last if /^KEYWORDS$/ ;
386 print $pm "our %Offsets = (\n" ;
387 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
388 my ($name, $version) = @{ $ValueToName{$k} };
391 if ( $last_ver != $version ) {
393 print $pm tab(4, " # Warnings Categories added in Perl $version");
396 print $pm tab(4, " '$name'"), "=> $k,\n" ;
397 $last_ver = $version;
400 print $pm " );\n\n" ;
402 print $pm "our %Bits = (\n" ;
403 foreach $k (sort keys %list) {
406 my @list = sort { $a <=> $b } @$v ;
408 print $pm tab(4, " '$k'"), '=> "',
409 mkHex($warn_size, map $_ * 2 , @list),
410 '", # [', mkRange(@list), "]\n" ;
413 print $pm " );\n\n" ;
415 print $pm "our %DeadBits = (\n" ;
416 foreach $k (sort keys %list) {
419 my @list = sort { $a <=> $b } @$v ;
421 print $pm tab(4, " '$k'"), '=> "',
422 mkHex($warn_size, map $_ * 2 + 1 , @list),
423 '", # [', mkRange(@list), "]\n" ;
426 print $pm " );\n\n" ;
427 print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
428 print $pm '$LAST_BIT = ' . "$index ;\n" ;
429 print $pm '$BYTES = ' . "$warn_size ;\n" ;
434 print $pm "# ex: set ro:\n";
436 rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
439 # -*- buffer-read-only: t -*-
440 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
441 # This file was created by warnings.pl
442 # Any changes made here will be lost.
447 our $VERSION = '1.11';
449 # Verify that we're called correctly so that warnings will work.
450 # see also strict.pm.
451 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
452 my (undef, $f, $l) = caller;
453 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
458 warnings - Perl pragma to control optional warnings
468 use warnings::register;
469 if (warnings::enabled()) {
470 warnings::warn("some warning");
473 if (warnings::enabled("void")) {
474 warnings::warn("void", "some warning");
477 if (warnings::enabled($object)) {
478 warnings::warn($object, "some warning");
481 warnings::warnif("some warning");
482 warnings::warnif("void", "some warning");
483 warnings::warnif($object, "some warning");
487 The C<warnings> pragma is a replacement for the command line flag C<-w>,
488 but the pragma is limited to the enclosing block, while the flag is global.
489 See L<perllexwarn> for more information.
491 If no import list is supplied, all possible warnings are either enabled
494 A number of functions are provided to assist module authors.
498 =item use warnings::register
500 Creates a new warnings category with the same name as the package where
501 the call to the pragma is used.
503 =item warnings::enabled()
505 Use the warnings category with the same name as the current package.
507 Return TRUE if that warnings category is enabled in the calling module.
508 Otherwise returns FALSE.
510 =item warnings::enabled($category)
512 Return TRUE if the warnings category, C<$category>, is enabled in the
514 Otherwise returns FALSE.
516 =item warnings::enabled($object)
518 Use the name of the class for the object reference, C<$object>, as the
521 Return TRUE if that warnings category is enabled in the first scope
522 where the object is used.
523 Otherwise returns FALSE.
525 =item warnings::fatal_enabled()
527 Return TRUE if the warnings category with the same name as the current
528 package has been set to FATAL in the calling module.
529 Otherwise returns FALSE.
531 =item warnings::fatal_enabled($category)
533 Return TRUE if the warnings category C<$category> has been set to FATAL in
535 Otherwise returns FALSE.
537 =item warnings::fatal_enabled($object)
539 Use the name of the class for the object reference, C<$object>, as the
542 Return TRUE if that warnings category has been set to FATAL in the first
543 scope where the object is used.
544 Otherwise returns FALSE.
546 =item warnings::warn($message)
548 Print C<$message> to STDERR.
550 Use the warnings category with the same name as the current package.
552 If that warnings category has been set to "FATAL" in the calling module
553 then die. Otherwise return.
555 =item warnings::warn($category, $message)
557 Print C<$message> to STDERR.
559 If the warnings category, C<$category>, has been set to "FATAL" in the
560 calling module then die. Otherwise return.
562 =item warnings::warn($object, $message)
564 Print C<$message> to STDERR.
566 Use the name of the class for the object reference, C<$object>, as the
569 If that warnings category has been set to "FATAL" in the scope where C<$object>
570 is first used then die. Otherwise return.
573 =item warnings::warnif($message)
577 if (warnings::enabled())
578 { warnings::warn($message) }
580 =item warnings::warnif($category, $message)
584 if (warnings::enabled($category))
585 { warnings::warn($category, $message) }
587 =item warnings::warnif($object, $message)
591 if (warnings::enabled($object))
592 { warnings::warn($object, $message) }
594 =item warnings::register_categories(@names)
596 This registers warning categories for the given names and is primarily for
597 use by the warnings::register pragma, for which see L<perllexwarn>.
601 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
607 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
611 require Carp; # this initializes %CarpInternal
612 local $Carp::CarpInternal{'warnings'};
613 delete $Carp::CarpInternal{'warnings'};
623 foreach my $word ( @_ ) {
624 if ($word eq 'FATAL') {
628 elsif ($word eq 'NONFATAL') {
632 elsif ($catmask = $Bits{$word}) {
634 $mask |= $DeadBits{$word} if $fatal ;
635 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
638 { Croaker("Unknown warnings category '$word'")}
646 # called from B::Deparse.pm
647 push @_, 'all' unless @_ ;
648 return _bits(undef, @_) ;
655 my $mask = ${^WARNING_BITS} ;
657 if (vec($mask, $Offsets{'all'}, 1)) {
658 $mask |= $Bits{'all'} ;
659 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
662 # Empty @_ is equivalent to @_ = 'all' ;
663 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
671 my $mask = ${^WARNING_BITS} ;
673 if (vec($mask, $Offsets{'all'}, 1)) {
674 $mask |= $Bits{'all'} ;
675 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
678 push @_, 'all' unless @_;
680 foreach my $word ( @_ ) {
681 if ($word eq 'FATAL') {
684 elsif ($catmask = $Bits{$word}) {
685 $mask &= ~($catmask | $DeadBits{$word} | $All);
688 { Croaker("Unknown warnings category '$word'")}
691 ${^WARNING_BITS} = $mask ;
694 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
696 sub MESSAGE () { 4 };
706 my $has_message = $wanted & MESSAGE;
708 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
709 my $sub = (caller 1)[3];
710 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
711 Croaker("Usage: $sub($syntax)");
714 my $message = pop if $has_message;
717 # check the category supplied.
719 if (my $type = ref $category) {
720 Croaker("not an object")
721 if exists $builtin_type{$type};
725 $offset = $Offsets{$category};
726 Croaker("Unknown warnings category '$category'")
727 unless defined $offset;
730 $category = (caller(1))[0] ;
731 $offset = $Offsets{$category};
732 Croaker("package '$category' not registered for warnings")
733 unless defined $offset ;
741 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
742 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
747 $i = _error_loc(); # see where Carp will allocate the error
750 # Defaulting this to 0 reduces complexity in code paths below.
751 my $callers_bitmask = (caller($i))[9] || 0 ;
754 foreach my $type (FATAL, NORMAL) {
755 next unless $wanted & $type;
757 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
758 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
761 # &enabled and &fatal_enabled
762 return $results[0] unless $has_message;
764 # &warnif, and the category is neither enabled as warning nor as fatal
765 return if $wanted == (NORMAL | FATAL | MESSAGE)
766 && !($results[0] || $results[1]);
769 Carp::croak($message) if $results[0];
770 # will always get here for &warn. will only get here for &warnif if the
771 # category is enabled
772 Carp::carp($message);
780 vec($mask, $bit, 1) = 1;
784 sub register_categories
788 for my $name (@names) {
789 if (! defined $Bits{$name}) {
790 $Bits{$name} = _mkMask($LAST_BIT);
791 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
792 $Offsets{$name} = $LAST_BIT ++;
793 foreach my $k (keys %Bits) {
794 vec($Bits{$k}, $LAST_BIT, 1) = 0;
796 $DeadBits{$name} = _mkMask($LAST_BIT);
797 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
804 goto &Carp::short_error_loc; # don't introduce another stack frame
809 return __chk(NORMAL, @_);
814 return __chk(FATAL, @_);
819 return __chk(FATAL | MESSAGE, @_);
824 return __chk(NORMAL | FATAL | MESSAGE, @_);
827 # These are not part of any public interface, so we can delete them to save
829 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);