lib/warnings.pm

   1 # -*- buffer-read-only: t -*-
   2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   3 # This file was created by warnings.pl
   4 # Any changes made here will be lost.
   5 #
   6
   7 package warnings;
   8
   9 our $VERSION = '1.05';
  10
  11 =head1 NAME
  12
  13 warnings - Perl pragma to control optional warnings
  14
  15 =head1 SYNOPSIS
  16
  17     use warnings;
  18     no warnings;
  19
  20     use warnings "all";
  21     no warnings "all";
  22
  23     use warnings::register;
  24     if (warnings::enabled()) {
  25         warnings::warn("some warning");
  26     }
  27
  28     if (warnings::enabled("void")) {
  29         warnings::warn("void", "some warning");
  30     }
  31
  32     if (warnings::enabled($object)) {
  33         warnings::warn($object, "some warning");
  34     }
  35
  36     warnings::warnif("some warning");
  37     warnings::warnif("void", "some warning");
  38     warnings::warnif($object, "some warning");
  39
  40 =head1 DESCRIPTION
  41
  42 The C<warnings> pragma is a replacement for the command line flag C<-w>,
  43 but the pragma is limited to the enclosing block, while the flag is global.
  44 See L<perllexwarn> for more information.
  45
  46 If no import list is supplied, all possible warnings are either enabled
  47 or disabled.
  48
  49 A number of functions are provided to assist module authors.
  50
  51 =over 4
  52
  53 =item use warnings::register
  54
  55 Creates a new warnings category with the same name as the package where
  56 the call to the pragma is used.
  57
  58 =item warnings::enabled()
  59
  60 Use the warnings category with the same name as the current package.
  61
  62 Return TRUE if that warnings category is enabled in the calling module.
  63 Otherwise returns FALSE.
  64
  65 =item warnings::enabled($category)
  66
  67 Return TRUE if the warnings category, C<$category>, is enabled in the
  68 calling module.
  69 Otherwise returns FALSE.
  70
  71 =item warnings::enabled($object)
  72
  73 Use the name of the class for the object reference, C<$object>, as the
  74 warnings category.
  75
  76 Return TRUE if that warnings category is enabled in the first scope
  77 where the object is used.
  78 Otherwise returns FALSE.
  79
  80 =item warnings::warn($message)
  81
  82 Print C<$message> to STDERR.
  83
  84 Use the warnings category with the same name as the current package.
  85
  86 If that warnings category has been set to "FATAL" in the calling module
  87 then die. Otherwise return.
  88
  89 =item warnings::warn($category, $message)
  90
  91 Print C<$message> to STDERR.
  92
  93 If the warnings category, C<$category>, has been set to "FATAL" in the
  94 calling module then die. Otherwise return.
  95
  96 =item warnings::warn($object, $message)
  97
  98 Print C<$message> to STDERR.
  99
 100 Use the name of the class for the object reference, C<$object>, as the
 101 warnings category.
 102
 103 If that warnings category has been set to "FATAL" in the scope where C<$object>
 104 is first used then die. Otherwise return.
 105
 106
 107 =item warnings::warnif($message)
 108
 109 Equivalent to:
 110
 111     if (warnings::enabled())
 112       { warnings::warn($message) }
 113
 114 =item warnings::warnif($category, $message)
 115
 116 Equivalent to:
 117
 118     if (warnings::enabled($category))
 119       { warnings::warn($category, $message) }
 120
 121 =item warnings::warnif($object, $message)
 122
 123 Equivalent to:
 124
 125     if (warnings::enabled($object))
 126       { warnings::warn($object, $message) }
 127
 128 =back
 129
 130 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 131
 132 =cut
 133
 134 use Carp ();
 135
 136 our %Offsets = (
 137
 138     # Warnings Categories added in Perl 5.008
 139
 140     'all'               => 0,
 141     'closure'           => 2,
 142     'deprecated'        => 4,
 143     'exiting'           => 6,
 144     'glob'              => 8,
 145     'io'                => 10,
 146     'closed'            => 12,
 147     'exec'              => 14,
 148     'layer'             => 16,
 149     'newline'           => 18,
 150     'pipe'              => 20,
 151     'unopened'          => 22,
 152     'misc'              => 24,
 153     'numeric'           => 26,
 154     'once'              => 28,
 155     'overflow'          => 30,
 156     'pack'              => 32,
 157     'portable'          => 34,
 158     'recursion'         => 36,
 159     'redefine'          => 38,
 160     'regexp'            => 40,
 161     'severe'            => 42,
 162     'debugging'         => 44,
 163     'inplace'           => 46,
 164     'internal'          => 48,
 165     'malloc'            => 50,
 166     'signal'            => 52,
 167     'substr'            => 54,
 168     'syntax'            => 56,
 169     'ambiguous'         => 58,
 170     'bareword'          => 60,
 171     'digit'             => 62,
 172     'parenthesis'       => 64,
 173     'precedence'        => 66,
 174     'printf'            => 68,
 175     'prototype'         => 70,
 176     'qw'                => 72,
 177     'reserved'          => 74,
 178     'semicolon'         => 76,
 179     'taint'             => 78,
 180     'threads'           => 80,
 181     'uninitialized'     => 82,
 182     'unpack'            => 84,
 183     'untie'             => 86,
 184     'utf8'              => 88,
 185     'void'              => 90,
 186     'y2k'               => 92,
 187   );
 188
 189 our %Bits = (
 190     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
 191     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 192     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 193     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 194     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 195     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 196     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 197     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 198     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 199     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 200     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 201     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 202     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 203     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 204     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 205     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 206     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 207     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 208     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 209     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 210     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 211     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 212     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 213     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 214     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 215     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 216     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 217     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 218     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 219     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 220     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 221     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 222     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 223     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 224     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 225     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 226     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 227     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 228     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 229     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 230     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 231     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 232     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 233     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 234     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 235     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 236     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 237   );
 238
 239 our %DeadBits = (
 240     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
 241     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 242     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 243     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 244     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 245     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 246     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 247     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 248     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 249     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 250     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 251     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 252     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 253     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 254     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 255     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 256     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 257     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 258     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 259     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 260     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 261     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 262     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 263     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 264     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 265     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 266     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 267     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 268     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 269     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 270     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 271     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 272     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 273     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 274     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 275     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 276     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 277     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
 278     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 279     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 280     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 281     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 282     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 283     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 284     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 285     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 286     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 287   );
 288
 289 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 290 $LAST_BIT = 94 ;
 291 $BYTES    = 12 ;
 292
 293 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 294
 295 sub Croaker
 296 {
 297     local $Carp::CarpInternal{'warnings'};
 298     delete $Carp::CarpInternal{'warnings'};
 299     Carp::croak(@_);
 300 }
 301
 302 sub bits
 303 {
 304     # called from B::Deparse.pm
 305
 306     push @_, 'all' unless @_;
 307
 308     my $mask;
 309     my $catmask ;
 310     my $fatal = 0 ;
 311     my $no_fatal = 0 ;
 312
 313     foreach my $word ( @_ ) {
 314         if ($word eq 'FATAL') {
 315             $fatal = 1;
 316             $no_fatal = 0;
 317         }
 318         elsif ($word eq 'NONFATAL') {
 319             $fatal = 0;
 320             $no_fatal = 1;
 321         }
 322         elsif ($catmask = $Bits{$word}) {
 323             $mask |= $catmask ;
 324             $mask |= $DeadBits{$word} if $fatal ;
 325             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 326         }
 327         else
 328           { Croaker("Unknown warnings category '$word'")}
 329     }
 330
 331     return $mask ;
 332 }
 333
 334 sub import
 335 {
 336     shift;
 337
 338     my $catmask ;
 339     my $fatal = 0 ;
 340     my $no_fatal = 0 ;
 341
 342     my $mask = ${^WARNING_BITS} ;
 343
 344     if (vec($mask, $Offsets{'all'}, 1)) {
 345         $mask |= $Bits{'all'} ;
 346         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 347     }
 348
 349     push @_, 'all' unless @_;
 350
 351     foreach my $word ( @_ ) {
 352         if ($word eq 'FATAL') {
 353             $fatal = 1;
 354             $no_fatal = 0;
 355         }
 356         elsif ($word eq 'NONFATAL') {
 357             $fatal = 0;
 358             $no_fatal = 1;
 359         }
 360         elsif ($catmask = $Bits{$word}) {
 361             $mask |= $catmask ;
 362             $mask |= $DeadBits{$word} if $fatal ;
 363             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 364         }
 365         else
 366           { Croaker("Unknown warnings category '$word'")}
 367     }
 368
 369     ${^WARNING_BITS} = $mask ;
 370 }
 371
 372 sub unimport
 373 {
 374     shift;
 375
 376     my $catmask ;
 377     my $mask = ${^WARNING_BITS} ;
 378
 379     if (vec($mask, $Offsets{'all'}, 1)) {
 380         $mask |= $Bits{'all'} ;
 381         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 382     }
 383
 384     push @_, 'all' unless @_;
 385
 386     foreach my $word ( @_ ) {
 387         if ($word eq 'FATAL') {
 388             next;
 389         }
 390         elsif ($catmask = $Bits{$word}) {
 391             $mask &= ~($catmask | $DeadBits{$word} | $All);
 392         }
 393         else
 394           { Croaker("Unknown warnings category '$word'")}
 395     }
 396
 397     ${^WARNING_BITS} = $mask ;
 398 }
 399
 400 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 401
 402 sub __chk
 403 {
 404     my $category ;
 405     my $offset ;
 406     my $isobj = 0 ;
 407
 408     if (@_) {
 409         # check the category supplied.
 410         $category = shift ;
 411         if (my $type = ref $category) {
 412             Croaker("not an object")
 413                 if exists $builtin_type{$type};
 414             $category = $type;
 415             $isobj = 1 ;
 416         }
 417         $offset = $Offsets{$category};
 418         Croaker("Unknown warnings category '$category'")
 419             unless defined $offset;
 420     }
 421     else {
 422         $category = (caller(1))[0] ;
 423         $offset = $Offsets{$category};
 424         Croaker("package '$category' not registered for warnings")
 425             unless defined $offset ;
 426     }
 427
 428     my $this_pkg = (caller(1))[0] ;
 429     my $i = 2 ;
 430     my $pkg ;
 431
 432     if ($isobj) {
 433         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 434             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 435         }
 436         $i -= 2 ;
 437     }
 438     else {
 439         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 440             last if $pkg ne $this_pkg ;
 441         }
 442         $i = 2
 443             if !$pkg || $pkg eq $this_pkg ;
 444     }
 445
 446     my $callers_bitmask = (caller($i))[9] ;
 447     return ($callers_bitmask, $offset, $i) ;
 448 }
 449
 450 sub enabled
 451 {
 452     Croaker("Usage: warnings::enabled([category])")
 453         unless @_ == 1 || @_ == 0 ;
 454
 455     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 456
 457     return 0 unless defined $callers_bitmask ;
 458     return vec($callers_bitmask, $offset, 1) ||
 459            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 460 }
 461
 462
 463 sub warn
 464 {
 465     Croaker("Usage: warnings::warn([category,] 'message')")
 466         unless @_ == 2 || @_ == 1 ;
 467
 468     my $message = pop ;
 469     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 470     Carp::croak($message)
 471         if vec($callers_bitmask, $offset+1, 1) ||
 472            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 473     Carp::carp($message) ;
 474 }
 475
 476 sub warnif
 477 {
 478     Croaker("Usage: warnings::warnif([category,] 'message')")
 479         unless @_ == 2 || @_ == 1 ;
 480
 481     my $message = pop ;
 482     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 483
 484     return
 485         unless defined $callers_bitmask &&
 486                 (vec($callers_bitmask, $offset, 1) ||
 487                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 488
 489     Carp::croak($message)
 490         if vec($callers_bitmask, $offset+1, 1) ||
 491            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 492
 493     Carp::carp($message) ;
 494 }
 495
 496 1;
 497 # ex: set ro: