home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / warnings.pm < prev   
Text File  |  2000-03-18  |  12KB  |  319 lines
  1.  
  2. # This file was created by warnings.pl
  3. # Any changes made here will be lost.
  4. #
  5.  
  6. package warnings;
  7.  
  8. =head1 NAME
  9.  
  10. warnings - Perl pragma to control optional warnings
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.     use warnings;
  15.     no warnings;
  16.  
  17.     use warnings "all";
  18.     no warnings "all";
  19.  
  20.     use warnings::register;
  21.     if (warnings::enabled()) {
  22.         warnings::warn("some warning");
  23.     }
  24.  
  25.     if (warnings::enabled("void")) {
  26.         warnings::warn("void", "some warning");
  27.     }
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. If no import list is supplied, all possible warnings are either enabled
  32. or disabled.
  33.  
  34. A number of functions are provided to assist module authors. 
  35.  
  36. =over 4
  37.  
  38. =item use warnings::register
  39.  
  40. Creates a new warnings category which has the same name as the module
  41. where the call to the pragma is used.
  42.  
  43. =item warnings::enabled([$category])
  44.  
  45. Returns TRUE if the warnings category C<$category> is enabled in the
  46. calling module.  Otherwise returns FALSE.
  47.  
  48. If the parameter, C<$category>, isn't supplied, the current package name
  49. will be used.
  50.  
  51. =item warnings::warn([$category,] $message)
  52.  
  53. If the calling module has I<not> set C<$category> to "FATAL", print
  54. C<$message> to STDERR.
  55. If the calling module has set C<$category> to "FATAL", print C<$message>
  56. STDERR then die.
  57.  
  58. If the parameter, C<$category>, isn't supplied, the current package name
  59. will be used.
  60.  
  61. =back
  62.  
  63. See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
  64.  
  65. =cut
  66.  
  67. use Carp ;
  68.  
  69. %Offsets = (
  70.     'all'        => 0,
  71.     'chmod'        => 2,
  72.     'closure'        => 4,
  73.     'exiting'        => 6,
  74.     'glob'        => 8,
  75.     'io'        => 10,
  76.     'closed'        => 12,
  77.     'exec'        => 14,
  78.     'newline'        => 16,
  79.     'pipe'        => 18,
  80.     'unopened'        => 20,
  81.     'misc'        => 22,
  82.     'numeric'        => 24,
  83.     'once'        => 26,
  84.     'overflow'        => 28,
  85.     'pack'        => 30,
  86.     'portable'        => 32,
  87.     'recursion'        => 34,
  88.     'redefine'        => 36,
  89.     'regexp'        => 38,
  90.     'severe'        => 40,
  91.     'debugging'        => 42,
  92.     'inplace'        => 44,
  93.     'internal'        => 46,
  94.     'malloc'        => 48,
  95.     'signal'        => 50,
  96.     'substr'        => 52,
  97.     'syntax'        => 54,
  98.     'ambiguous'        => 56,
  99.     'bareword'        => 58,
  100.     'deprecated'    => 60,
  101.     'digit'        => 62,
  102.     'parenthesis'    => 64,
  103.     'precedence'    => 66,
  104.     'printf'        => 68,
  105.     'prototype'        => 70,
  106.     'qw'        => 72,
  107.     'reserved'        => 74,
  108.     'semicolon'        => 76,
  109.     'taint'        => 78,
  110.     'umask'        => 80,
  111.     'uninitialized'    => 82,
  112.     'unpack'        => 84,
  113.     'untie'        => 86,
  114.     'utf8'        => 88,
  115.     'void'        => 90,
  116.     'y2k'        => 92,
  117.   );
  118.  
  119. %Bits = (
  120.     'all'        => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
  121.     'ambiguous'        => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
  122.     'bareword'        => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
  123.     'chmod'        => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
  124.     'closed'        => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
  125.     'closure'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
  126.     'debugging'        => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
  127.     'deprecated'    => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
  128.     'digit'        => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
  129.     'exec'        => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
  130.     'exiting'        => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
  131.     'glob'        => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
  132.     'inplace'        => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
  133.     'internal'        => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
  134.     'io'        => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
  135.     'malloc'        => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
  136.     'misc'        => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
  137.     'newline'        => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
  138.     'numeric'        => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
  139.     'once'        => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
  140.     'overflow'        => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
  141.     'pack'        => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
  142.     'parenthesis'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
  143.     'pipe'        => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
  144.     'portable'        => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
  145.     'precedence'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
  146.     'printf'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
  147.     'prototype'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
  148.     'qw'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
  149.     'recursion'        => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
  150.     'redefine'        => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
  151.     'regexp'        => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
  152.     'reserved'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
  153.     'semicolon'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
  154.     'severe'        => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
  155.     'signal'        => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
  156.     'substr'        => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
  157.     'syntax'        => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38]
  158.     'taint'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
  159.     'umask'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
  160.     'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
  161.     'unopened'        => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
  162.     'unpack'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
  163.     'untie'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
  164.     'utf8'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
  165.     'void'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
  166.     'y2k'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
  167.   );
  168.  
  169. %DeadBits = (
  170.     'all'        => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
  171.     'ambiguous'        => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
  172.     'bareword'        => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
  173.     'chmod'        => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
  174.     'closed'        => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
  175.     'closure'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
  176.     'debugging'        => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
  177.     'deprecated'    => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
  178.     'digit'        => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
  179.     'exec'        => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
  180.     'exiting'        => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
  181.     'glob'        => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
  182.     'inplace'        => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
  183.     'internal'        => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
  184.     'io'        => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
  185.     'malloc'        => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
  186.     'misc'        => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
  187.     'newline'        => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
  188.     'numeric'        => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
  189.     'once'        => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
  190.     'overflow'        => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
  191.     'pack'        => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
  192.     'parenthesis'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
  193.     'pipe'        => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
  194.     'portable'        => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
  195.     'precedence'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
  196.     'printf'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
  197.     'prototype'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
  198.     'qw'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
  199.     'recursion'        => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
  200.     'redefine'        => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
  201.     'regexp'        => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
  202.     'reserved'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
  203.     'semicolon'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
  204.     'severe'        => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
  205.     'signal'        => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
  206.     'substr'        => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
  207.     'syntax'        => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38]
  208.     'taint'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
  209.     'umask'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
  210.     'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
  211.     'unopened'        => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
  212.     'unpack'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
  213.     'untie'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
  214.     'utf8'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
  215.     'void'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
  216.     'y2k'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
  217.   );
  218.  
  219. $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
  220. $LAST_BIT = 94 ;
  221. $BYTES    = 12 ;
  222.  
  223. $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
  224.  
  225. sub bits {
  226.     my $mask ;
  227.     my $catmask ;
  228.     my $fatal = 0 ;
  229.     foreach my $word (@_) {
  230.     if  ($word eq 'FATAL') {
  231.         $fatal = 1;
  232.     }
  233.     elsif ($catmask = $Bits{$word}) {
  234.         $mask |= $catmask ;
  235.         $mask |= $DeadBits{$word} if $fatal ;
  236.     }
  237.     else
  238.           { croak("unknown warnings category '$word'")}  
  239.     }
  240.  
  241.     return $mask ;
  242. }
  243.  
  244. sub import {
  245.     shift;
  246.     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
  247. }
  248.  
  249. sub unimport {
  250.     shift;
  251.     my $mask = ${^WARNING_BITS} ;
  252.     if (vec($mask, $Offsets{'all'}, 1)) {
  253.         $mask = $Bits{'all'} ;
  254.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  255.     }
  256.     ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
  257. }
  258.  
  259. sub enabled
  260. {
  261.     croak("Usage: warnings::enabled([category])")
  262.     unless @_ == 1 || @_ == 0 ;
  263.     local $Carp::CarpLevel = 1 ;
  264.     my $category ;
  265.     my $offset ;
  266.     my $callers_bitmask = (caller(1))[9] ; 
  267.     return 0 unless defined $callers_bitmask ;
  268.  
  269.  
  270.     if (@_) {
  271.         # check the category supplied.
  272.         $category = shift ;
  273.         $offset = $Offsets{$category};
  274.         croak("unknown warnings category '$category'")
  275.         unless defined $offset;
  276.     }
  277.     else {
  278.         $category = (caller(0))[0] ; 
  279.         $offset = $Offsets{$category};
  280.         croak("package '$category' not registered for warnings")
  281.         unless defined $offset ;
  282.     }
  283.  
  284.     return vec($callers_bitmask, $offset, 1) ||
  285.            vec($callers_bitmask, $Offsets{'all'}, 1) ;
  286. }
  287.  
  288.  
  289. sub warn
  290. {
  291.     croak("Usage: warnings::warn([category,] 'message')")
  292.     unless @_ == 2 || @_ == 1 ;
  293.     local $Carp::CarpLevel = 1 ;
  294.     my $category ;
  295.     my $offset ;
  296.     my $callers_bitmask = (caller(1))[9] ; 
  297.  
  298.     if (@_ == 2) {
  299.         $category = shift ;
  300.         $offset = $Offsets{$category};
  301.         croak("unknown warnings category '$category'")
  302.         unless defined $offset ;
  303.     }
  304.     else {
  305.         $category = (caller(0))[0] ; 
  306.         $offset = $Offsets{$category};
  307.         croak("package '$category' not registered for warnings")
  308.         unless defined $offset ;
  309.     }
  310.  
  311.     my $message = shift ;
  312.     croak($message) 
  313.     if vec($callers_bitmask, $offset+1, 1) ||
  314.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  315.     carp($message) ;
  316. }
  317.  
  318. 1;
  319.