X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=835fd7c5e4edd46505ee71597d88bc78f9c3a1e4;hb=0100440d3c83cbbd0295cecf65f71318c7bebf25;hp=f2380d9dbba2307c8db861cf4d96996150e2530e;hpb=06dcd5bfe49c573553f3a05b5b5fdf417bf526a2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/warnings.pl b/warnings.pl index f2380d9..835fd7c 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,9 +1,23 @@ #!/usr/bin/perl +# +# Regenerate (overwriting only if changed): +# +# lib/warnings.pm +# warnings.h +# +# from information hardcoded into this script (the $tree hash), plus the +# template for warnings.pm in the DATA section. +# +# With an argument of 'tree', just dump the contents of $tree and exits. +# Also accepts the standard regen_lib -q and -v args. +# +# This script is normally invoked from regen.pl. -$VERSION = '1.02_02'; +$VERSION = '1.02_03'; BEGIN { - push @INC, './lib'; + require 'regen_lib.pl'; + push @INC, './lib'; } use strict ; @@ -61,7 +75,7 @@ my $tree = { 'pack' => [ 5.008, DEFAULT_OFF], 'unpack' => [ 5.008, DEFAULT_OFF], 'threads' => [ 5.008, DEFAULT_OFF], - 'assertions' => [ 5.009, DEFAULT_OFF], + 'imprecision' => [ 5.011, DEFAULT_OFF], #'default' => [ 5.008, DEFAULT_ON ], }], @@ -249,14 +263,10 @@ if (@ARGV && $ARGV[0] eq "tree") exit ; } -unlink "warnings.h"; -unlink "lib/warnings.pm"; -open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; -binmode WARN; -open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; -binmode PM; +my $warn = safer_open("warnings.h-new"); +my $pm = safer_open("lib/warnings.pm-new"); -print WARN <<'EOM' ; +print $warn <<'EOM' ; /* -*- buffer-read-only: t -*- !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by warnings.pl @@ -308,19 +318,19 @@ my $k ; my $last_ver = 0; foreach $k (sort { $a <=> $b } keys %ValueToName) { my ($name, $version) = @{ $ValueToName{$k} }; - print WARN "\n/* Warnings Categories added in Perl $version */\n\n" + print $warn "\n/* Warnings Categories added in Perl $version */\n\n" if $last_ver != $version ; - print WARN tab(5, "#define WARN_$name"), "$k\n" ; + print $warn tab(5, "#define WARN_$name"), "$k\n" ; $last_ver = $version ; } -print WARN "\n" ; +print $warn "\n" ; -print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; +print $warn tab(5, '#define WARNsize'), "$warn_size\n" ; #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; -print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; -print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; +print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; +print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; -print WARN <<'EOM'; +print $warn <<'EOM'; #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) @@ -329,8 +339,9 @@ print WARN <<'EOM'; #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1)) #define DUP_WARNINGS(p) \ - (STRLEN*)(specialWARN(p) ? (p) \ - : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)) + (specialWARN(p) ? (STRLEN*)(p) \ + : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \ + char)) #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w)) #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2)) @@ -342,6 +353,8 @@ print WARN <<'EOM'; #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3)) #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4)) +#define WARNshift 8 + #define packWARN(a) (a ) #define packWARN2(a,b) ((a) | ((b)<<8) ) #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) ) @@ -364,68 +377,70 @@ print WARN <<'EOM'; /* ex: set ro: */ EOM -close WARN ; +safer_close $warn; +rename_if_different("warnings.h-new", "warnings.h"); while () { last if /^KEYWORDS$/ ; - print PM $_ ; + print $pm $_ ; } #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; $last_ver = 0; -print PM "our %Offsets = (\n" ; +print $pm "our %Offsets = (\n" ; foreach my $k (sort { $a <=> $b } keys %ValueToName) { my ($name, $version) = @{ $ValueToName{$k} }; $name = lc $name; $k *= 2 ; if ( $last_ver != $version ) { - print PM "\n"; - print PM tab(4, " # Warnings Categories added in Perl $version"); - print PM "\n\n"; + print $pm "\n"; + print $pm tab(4, " # Warnings Categories added in Perl $version"); + print $pm "\n\n"; } - print PM tab(4, " '$name'"), "=> $k,\n" ; + print $pm tab(4, " '$name'"), "=> $k,\n" ; $last_ver = $version; } -print PM " );\n\n" ; +print $pm " );\n\n" ; -print PM "our %Bits = (\n" ; +print $pm "our %Bits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; my @list = sort { $a <=> $b } @$v ; - print PM tab(4, " '$k'"), '=> "', + print $pm tab(4, " '$k'"), '=> "', # mkHex($warn_size, @list), mkHex($warn_size, map $_ * 2 , @list), '", # [', mkRange(@list), "]\n" ; } -print PM " );\n\n" ; +print $pm " );\n\n" ; -print PM "our %DeadBits = (\n" ; +print $pm "our %DeadBits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; my @list = sort { $a <=> $b } @$v ; - print PM tab(4, " '$k'"), '=> "', + print $pm tab(4, " '$k'"), '=> "', # mkHex($warn_size, @list), mkHex($warn_size, map $_ * 2 + 1 , @list), '", # [', mkRange(@list), "]\n" ; } -print PM " );\n\n" ; -print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ; -print PM '$LAST_BIT = ' . "$index ;\n" ; -print PM '$BYTES = ' . "$warn_size ;\n" ; +print $pm " );\n\n" ; +print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ; +print $pm '$LAST_BIT = ' . "$index ;\n" ; +print $pm '$BYTES = ' . "$warn_size ;\n" ; while () { - print PM $_ ; + print $pm $_ ; } -print PM "# ex: set ro:\n"; -close PM ; +print $pm "# ex: set ro:\n"; +safer_close $pm; +rename_if_different("lib/warnings.pm-new", "lib/warnings.pm"); __END__ # -*- buffer-read-only: t -*- @@ -436,7 +451,14 @@ __END__ package warnings; -our $VERSION = '1.05'; +our $VERSION = '1.08'; + +# Verify that we're called correctly so that warnings will work. +# see also strict.pm. +unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { + my (undef, $f, $l) = caller; + die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); +} =head1 NAME @@ -507,6 +529,27 @@ Return TRUE if that warnings category is enabled in the first scope where the object is used. Otherwise returns FALSE. +=item warnings::fatal_enabled() + +Return TRUE if the warnings category with the same name as the current +package has been set to FATAL in the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($category) + +Return TRUE if the warnings category C<$category> has been set to FATAL in +the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category has been set to FATAL in the first +scope where the object is used. +Otherwise returns FALSE. + =item warnings::warn($message) Print C<$message> to STDERR. @@ -567,7 +610,7 @@ $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; sub Croaker { - require Carp::Heavy; # this initializes %CarpInternal + require Carp; # this initializes %CarpInternal local $Carp::CarpInternal{'warnings'}; delete $Carp::CarpInternal{'warnings'}; Carp::croak(@_); @@ -718,7 +761,7 @@ sub __chk } sub _error_loc { - require Carp::Heavy; + require Carp; goto &Carp::short_error_loc; # don't introduce another stack frame } @@ -734,6 +777,17 @@ sub enabled vec($callers_bitmask, $Offsets{'all'}, 1) ; } +sub fatal_enabled +{ + Croaker("Usage: warnings::fatal_enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask; + return vec($callers_bitmask, $offset + 1, 1) || + vec($callers_bitmask, $Offsets{'all'} + 1, 1) ; +} sub warn {