home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _f3fcd3c2f9a1289af96fc2f7d7819ba5 < prev    next >
Text File  |  2004-06-01  |  16KB  |  494 lines
  1.  
  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.03';
  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.     delete $Carp::CarpInternal{'warnings'};
  298.     Carp::croak(@_);
  299. }
  300.  
  301. sub bits
  302. {
  303.     # called from B::Deparse.pm
  304.  
  305.     push @_, 'all' unless @_;
  306.  
  307.     my $mask;
  308.     my $catmask ;
  309.     my $fatal = 0 ;
  310.     my $no_fatal = 0 ;
  311.  
  312.     foreach my $word ( @_ ) {
  313.     if ($word eq 'FATAL') {
  314.         $fatal = 1;
  315.         $no_fatal = 0;
  316.     }
  317.     elsif ($word eq 'NONFATAL') {
  318.         $fatal = 0;
  319.         $no_fatal = 1;
  320.     }
  321.     elsif ($catmask = $Bits{$word}) {
  322.         $mask |= $catmask ;
  323.         $mask |= $DeadBits{$word} if $fatal ;
  324.         $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
  325.     }
  326.     else
  327.           { Croaker("Unknown warnings category '$word'")}
  328.     }
  329.  
  330.     return $mask ;
  331. }
  332.  
  333. sub import 
  334. {
  335.     shift;
  336.  
  337.     my $catmask ;
  338.     my $fatal = 0 ;
  339.     my $no_fatal = 0 ;
  340.  
  341.     my $mask = ${^WARNING_BITS} ;
  342.  
  343.     if (vec($mask, $Offsets{'all'}, 1)) {
  344.         $mask |= $Bits{'all'} ;
  345.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  346.     }
  347.     
  348.     push @_, 'all' unless @_;
  349.  
  350.     foreach my $word ( @_ ) {
  351.     if ($word eq 'FATAL') {
  352.         $fatal = 1;
  353.         $no_fatal = 0;
  354.     }
  355.     elsif ($word eq 'NONFATAL') {
  356.         $fatal = 0;
  357.         $no_fatal = 1;
  358.     }
  359.     elsif ($catmask = $Bits{$word}) {
  360.         $mask |= $catmask ;
  361.         $mask |= $DeadBits{$word} if $fatal ;
  362.         $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
  363.     }
  364.     else
  365.           { Croaker("Unknown warnings category '$word'")}
  366.     }
  367.  
  368.     ${^WARNING_BITS} = $mask ;
  369. }
  370.  
  371. sub unimport 
  372. {
  373.     shift;
  374.  
  375.     my $catmask ;
  376.     my $mask = ${^WARNING_BITS} ;
  377.  
  378.     if (vec($mask, $Offsets{'all'}, 1)) {
  379.         $mask |= $Bits{'all'} ;
  380.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  381.     }
  382.  
  383.     push @_, 'all' unless @_;
  384.  
  385.     foreach my $word ( @_ ) {
  386.     if ($word eq 'FATAL') {
  387.         next; 
  388.     }
  389.     elsif ($catmask = $Bits{$word}) {
  390.         $mask &= ~($catmask | $DeadBits{$word} | $All);
  391.     }
  392.     else
  393.           { Croaker("Unknown warnings category '$word'")}
  394.     }
  395.  
  396.     ${^WARNING_BITS} = $mask ;
  397. }
  398.  
  399. sub __chk
  400. {
  401.     my $category ;
  402.     my $offset ;
  403.     my $isobj = 0 ;
  404.  
  405.     if (@_) {
  406.         # check the category supplied.
  407.         $category = shift ;
  408.         if (ref $category) {
  409.             Croaker ("not an object")
  410.                 if $category !~ /^([^=]+)=/ ;
  411.         $category = $1 ;
  412.             $isobj = 1 ;
  413.         }
  414.         $offset = $Offsets{$category};
  415.         Croaker("Unknown warnings category '$category'")
  416.         unless defined $offset;
  417.     }
  418.     else {
  419.         $category = (caller(1))[0] ;
  420.         $offset = $Offsets{$category};
  421.         Croaker("package '$category' not registered for warnings")
  422.         unless defined $offset ;
  423.     }
  424.  
  425.     my $this_pkg = (caller(1))[0] ;
  426.     my $i = 2 ;
  427.     my $pkg ;
  428.  
  429.     if ($isobj) {
  430.         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
  431.             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
  432.         }
  433.     $i -= 2 ;
  434.     }
  435.     else {
  436.         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
  437.             last if $pkg ne $this_pkg ;
  438.         }
  439.         $i = 2
  440.             if !$pkg || $pkg eq $this_pkg ;
  441.     }
  442.  
  443.     my $callers_bitmask = (caller($i))[9] ;
  444.     return ($callers_bitmask, $offset, $i) ;
  445. }
  446.  
  447. sub enabled
  448. {
  449.     Croaker("Usage: warnings::enabled([category])")
  450.     unless @_ == 1 || @_ == 0 ;
  451.  
  452.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  453.  
  454.     return 0 unless defined $callers_bitmask ;
  455.     return vec($callers_bitmask, $offset, 1) ||
  456.            vec($callers_bitmask, $Offsets{'all'}, 1) ;
  457. }
  458.  
  459.  
  460. sub warn
  461. {
  462.     Croaker("Usage: warnings::warn([category,] 'message')")
  463.     unless @_ == 2 || @_ == 1 ;
  464.  
  465.     my $message = pop ;
  466.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  467.     Carp::croak($message)
  468.     if vec($callers_bitmask, $offset+1, 1) ||
  469.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  470.     Carp::carp($message) ;
  471. }
  472.  
  473. sub warnif
  474. {
  475.     Croaker("Usage: warnings::warnif([category,] 'message')")
  476.     unless @_ == 2 || @_ == 1 ;
  477.  
  478.     my $message = pop ;
  479.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  480.  
  481.     return
  482.         unless defined $callers_bitmask &&
  483.                 (vec($callers_bitmask, $offset, 1) ||
  484.                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
  485.  
  486.     Carp::croak($message)
  487.     if vec($callers_bitmask, $offset+1, 1) ||
  488.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  489.  
  490.     Carp::carp($message) ;
  491. }
  492.  
  493. 1;
  494.