lib/warnings.pm

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