home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / warnings.pl < prev    next >
Perl Script  |  2000-03-12  |  12KB  |  493 lines
  1. #!/usr/bin/perl
  2.  
  3. BEGIN {
  4.   push @INC, './lib';
  5. }
  6. use strict ;
  7.  
  8. sub DEFAULT_ON  () { 1 }
  9. sub DEFAULT_OFF () { 2 }
  10.  
  11. my $tree = {
  12.  
  13. 'all' => {
  14.            'io'          => {     'pipe'         => DEFAULT_OFF,
  15.                        'unopened'    => DEFAULT_OFF,
  16.                        'closed'    => DEFAULT_OFF,
  17.                        'newline'    => DEFAULT_OFF,
  18.                        'exec'        => DEFAULT_OFF,
  19.                },
  20.            'syntax'    => {     'ambiguous'    => DEFAULT_OFF,
  21.                      'semicolon'    => DEFAULT_OFF,
  22.                      'precedence'    => DEFAULT_OFF,
  23.                      'bareword'    => DEFAULT_OFF,
  24.                      'reserved'    => DEFAULT_OFF,
  25.                 'digit'        => DEFAULT_OFF,
  26.                      'parenthesis'    => DEFAULT_OFF,
  27.                         'deprecated'    => DEFAULT_OFF,
  28.                         'printf'    => DEFAULT_OFF,
  29.                         'prototype'    => DEFAULT_OFF,
  30.                         'qw'        => DEFAULT_OFF,
  31.                },
  32.            'severe'    => {     'inplace'    => DEFAULT_ON,
  33.                  'internal'    => DEFAULT_ON,
  34.                      'debugging'    => DEFAULT_ON,
  35.                      'malloc'    => DEFAULT_ON,
  36.                 },
  37.            'void'        => DEFAULT_OFF,
  38.            'recursion'    => DEFAULT_OFF,
  39.            'redefine'    => DEFAULT_OFF,
  40.            'numeric'    => DEFAULT_OFF,
  41.         'uninitialized'    => DEFAULT_OFF,
  42.            'once'        => DEFAULT_OFF,
  43.            'misc'        => DEFAULT_OFF,
  44.            'regexp'    => DEFAULT_OFF,
  45.            'glob'        => DEFAULT_OFF,
  46.            'y2k'        => DEFAULT_OFF,
  47.            'chmod'        => DEFAULT_OFF,
  48.            'umask'        => DEFAULT_OFF,
  49.            'untie'        => DEFAULT_OFF,
  50.     'substr'    => DEFAULT_OFF,
  51.     'taint'        => DEFAULT_OFF,
  52.     'signal'    => DEFAULT_OFF,
  53.     'closure'    => DEFAULT_OFF,
  54.     'overflow'    => DEFAULT_OFF,
  55.     'portable'    => DEFAULT_OFF,
  56.     'utf8'        => DEFAULT_OFF,
  57.            'exiting'    => DEFAULT_OFF,
  58.            'pack'        => DEFAULT_OFF,
  59.            'unpack'    => DEFAULT_OFF,
  60.             #'default'    => DEFAULT_ON,
  61.       }
  62. } ;
  63.  
  64.  
  65. ###########################################################################
  66. sub tab {
  67.     my($l, $t) = @_;
  68.     $t .= "\t" x ($l - (length($t) + 1) / 8);
  69.     $t;
  70. }
  71.  
  72. ###########################################################################
  73.  
  74. my %list ;
  75. my %Value ;
  76. my $index ;
  77.  
  78. sub walk
  79. {
  80.     my $tre = shift ;
  81.     my @list = () ;
  82.     my ($k, $v) ;
  83.  
  84.     foreach $k (sort keys %$tre) {
  85.     $v = $tre->{$k};
  86.     die "duplicate key $k\n" if defined $list{$k} ;
  87.     $Value{$index} = uc $k ;
  88.         push @{ $list{$k} }, $index ++ ;
  89.     if (ref $v)
  90.       { push (@{ $list{$k} }, walk ($v)) }
  91.     push @list, @{ $list{$k} } ;
  92.     }
  93.  
  94.    return @list ;
  95. }
  96.  
  97. ###########################################################################
  98.  
  99. sub mkRange
  100. {
  101.     my @a = @_ ;
  102.     my @out = @a ;
  103.     my $i ;
  104.  
  105.  
  106.     for ($i = 1 ; $i < @a; ++ $i) {
  107.           $out[$i] = ".." 
  108.           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
  109.     }
  110.  
  111.     my $out = join(",",@out);
  112.  
  113.     $out =~ s/,(\.\.,)+/../g ;
  114.     return $out;
  115. }
  116.  
  117. ###########################################################################
  118. sub printTree
  119. {
  120.     my $tre = shift ;
  121.     my $prefix = shift ;
  122.     my $indent = shift ;
  123.     my ($k, $v) ;
  124.  
  125.     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
  126.  
  127.     $prefix .= " " x $indent ;
  128.     foreach $k (sort keys %$tre) {
  129.     $v = $tre->{$k};
  130.     print $prefix . "|\n" ;
  131.     print $prefix . "+- $k" ;
  132.     if (ref $v)
  133.     { 
  134.         print " " . "-" x ($max - length $k ) . "+\n" ;
  135.         printTree ($v, $prefix . "|" , $max + $indent - 1) 
  136.     }
  137.     else
  138.       { print "\n" }
  139.     }
  140.  
  141. }
  142.  
  143. ###########################################################################
  144.  
  145. sub mkHex
  146. {
  147.     my ($max, @a) = @_ ;
  148.     my $mask = "\x00" x $max ;
  149.     my $string = "" ;
  150.  
  151.     foreach (@a) {
  152.     vec($mask, $_, 1) = 1 ;
  153.     }
  154.  
  155.     #$string = unpack("H$max", $mask) ;
  156.     #$string =~ s/(..)/\x$1/g;
  157.     foreach (unpack("C*", $mask)) {
  158.     $string .= '\x' . sprintf("%2.2x", $_) ;
  159.     }
  160.     return $string ;
  161. }
  162.  
  163. ###########################################################################
  164.  
  165. if (@ARGV && $ARGV[0] eq "tree")
  166. {
  167.     #print "  all -+\n" ;
  168.     printTree($tree, "   ", 4) ;
  169.     exit ;
  170. }
  171.  
  172. #unlink "warnings.h";
  173. #unlink "lib/warnings.pm";
  174. open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
  175. open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
  176.  
  177. print WARN <<'EOM' ;
  178. /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  179.    This file is built by warnings.pl
  180.    Any changes made here will be lost!
  181. */
  182.  
  183.  
  184. #define Off(x)            ((x) / 8)
  185. #define Bit(x)            (1 << ((x) % 8))
  186. #define IsSet(a, x)        ((a)[Off(x)] & Bit(x))
  187.  
  188.  
  189. #define G_WARN_OFF        0     /* $^W == 0 */
  190. #define G_WARN_ON        1    /* -w flag and $^W != 0 */
  191. #define G_WARN_ALL_ON        2    /* -W flag */
  192. #define G_WARN_ALL_OFF        4    /* -X flag */
  193. #define G_WARN_ONCE        8    /* set if 'once' ever enabled */
  194. #define G_WARN_ALL_MASK        (G_WARN_ALL_ON|G_WARN_ALL_OFF)
  195.  
  196. #define pWARN_STD        Nullsv
  197. #define pWARN_ALL        (Nullsv+1)    /* use warnings 'all' */
  198. #define pWARN_NONE        (Nullsv+2)    /* no  warnings 'all' */
  199.  
  200. #define specialWARN(x)        ((x) == pWARN_STD || (x) == pWARN_ALL ||    \
  201.                  (x) == pWARN_NONE)
  202.  
  203. #define ckDEAD(x)                            \
  204.        ( ! specialWARN(PL_curcop->cop_warnings) &&            \
  205.         IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
  206.  
  207. #define ckWARN(x)                            \
  208.     ( (PL_curcop->cop_warnings != pWARN_STD &&            \
  209.        PL_curcop->cop_warnings != pWARN_NONE &&            \
  210.           (PL_curcop->cop_warnings == pWARN_ALL ||            \
  211.            IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )        \
  212.       || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
  213.  
  214. #define ckWARN2(x,y)                            \
  215.       ( (PL_curcop->cop_warnings != pWARN_STD  &&            \
  216.          PL_curcop->cop_warnings != pWARN_NONE &&            \
  217.           (PL_curcop->cop_warnings == pWARN_ALL ||            \
  218.             IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||        \
  219.             IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) )         \
  220.         ||    (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
  221.  
  222. #define ckWARN_d(x)                            \
  223.       (PL_curcop->cop_warnings == pWARN_STD ||            \
  224.        PL_curcop->cop_warnings == pWARN_ALL ||            \
  225.          (PL_curcop->cop_warnings != pWARN_NONE &&            \
  226.           IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
  227.  
  228. #define ckWARN2_d(x,y)                            \
  229.       (PL_curcop->cop_warnings == pWARN_STD ||            \
  230.        PL_curcop->cop_warnings == pWARN_ALL ||            \
  231.          (PL_curcop->cop_warnings != pWARN_NONE &&            \
  232.             (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||        \
  233.              IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
  234.  
  235.  
  236. #define isLEXWARN_on     (PL_curcop->cop_warnings != pWARN_STD)
  237. #define isLEXWARN_off    (PL_curcop->cop_warnings == pWARN_STD)
  238. #define isWARN_ONCE    (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
  239. #define isWARN_on(c,x)    (IsSet(SvPVX(c), 2*(x)))
  240.  
  241. EOM
  242.  
  243. my $offset = 0 ;
  244.  
  245. $index = $offset ;
  246. #@{ $list{"all"} } = walk ($tree) ;
  247. walk ($tree) ;
  248.  
  249.  
  250. $index *= 2 ;
  251. my $warn_size = int($index / 8) + ($index % 8 != 0) ;
  252.  
  253. my $k ;
  254. foreach $k (sort { $a <=> $b } keys %Value) {
  255.     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
  256. }
  257. print WARN "\n" ;
  258.  
  259. print WARN tab(5, '#define WARNsize'),    "$warn_size\n" ;
  260. #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
  261. print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
  262. print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
  263.  
  264. print WARN <<'EOM';
  265.  
  266. /* end of file warnings.h */
  267.  
  268. EOM
  269.  
  270. close WARN ;
  271.  
  272. while (<DATA>) {
  273.     last if /^KEYWORDS$/ ;
  274.     print PM $_ ;
  275. }
  276.  
  277. #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
  278.  
  279. #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
  280.  
  281. print PM "%Offsets = (\n" ;
  282. foreach my $k (sort { $a <=> $b } keys %Value) {
  283.     my $v = lc $Value{$k} ;
  284.     $k *= 2 ;
  285.     print PM tab(4, "    '$v'"), "=> $k,\n" ;
  286. }
  287.  
  288. print PM "  );\n\n" ;
  289.  
  290. print PM "%Bits = (\n" ;
  291. foreach $k (sort keys  %list) {
  292.  
  293.     my $v = $list{$k} ;
  294.     my @list = sort { $a <=> $b } @$v ;
  295.  
  296.     print PM tab(4, "    '$k'"), '=> "', 
  297.         # mkHex($warn_size, @list), 
  298.         mkHex($warn_size, map $_ * 2 , @list), 
  299.         '", # [', mkRange(@list), "]\n" ;
  300. }
  301.  
  302. print PM "  );\n\n" ;
  303.  
  304. print PM "%DeadBits = (\n" ;
  305. foreach $k (sort keys  %list) {
  306.  
  307.     my $v = $list{$k} ;
  308.     my @list = sort { $a <=> $b } @$v ;
  309.  
  310.     print PM tab(4, "    '$k'"), '=> "', 
  311.         # mkHex($warn_size, @list), 
  312.         mkHex($warn_size, map $_ * 2 + 1 , @list), 
  313.         '", # [', mkRange(@list), "]\n" ;
  314. }
  315.  
  316. print PM "  );\n\n" ;
  317. print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
  318. print PM '$LAST_BIT = ' . "$index ;\n" ;
  319. print PM '$BYTES    = ' . "$warn_size ;\n" ;
  320. while (<DATA>) {
  321.     print PM $_ ;
  322. }
  323.  
  324. close PM ;
  325.  
  326. __END__
  327.  
  328. # This file was created by warnings.pl
  329. # Any changes made here will be lost.
  330. #
  331.  
  332. package warnings;
  333.  
  334. =head1 NAME
  335.  
  336. warnings - Perl pragma to control optional warnings
  337.  
  338. =head1 SYNOPSIS
  339.  
  340.     use warnings;
  341.     no warnings;
  342.  
  343.     use warnings "all";
  344.     no warnings "all";
  345.  
  346.     use warnings::register;
  347.     if (warnings::enabled()) {
  348.         warnings::warn("some warning");
  349.     }
  350.  
  351.     if (warnings::enabled("void")) {
  352.         warnings::warn("void", "some warning");
  353.     }
  354.  
  355. =head1 DESCRIPTION
  356.  
  357. If no import list is supplied, all possible warnings are either enabled
  358. or disabled.
  359.  
  360. A number of functions are provided to assist module authors. 
  361.  
  362. =over 4
  363.  
  364. =item use warnings::register
  365.  
  366. Creates a new warnings category which has the same name as the module
  367. where the call to the pragma is used.
  368.  
  369. =item warnings::enabled([$category])
  370.  
  371. Returns TRUE if the warnings category C<$category> is enabled in the
  372. calling module.  Otherwise returns FALSE.
  373.  
  374. If the parameter, C<$category>, isn't supplied, the current package name
  375. will be used.
  376.  
  377. =item warnings::warn([$category,] $message)
  378.  
  379. If the calling module has I<not> set C<$category> to "FATAL", print
  380. C<$message> to STDERR.
  381. If the calling module has set C<$category> to "FATAL", print C<$message>
  382. STDERR then die.
  383.  
  384. If the parameter, C<$category>, isn't supplied, the current package name
  385. will be used.
  386.  
  387. =back
  388.  
  389. See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
  390.  
  391. =cut
  392.  
  393. use Carp ;
  394.  
  395. KEYWORDS
  396.  
  397. $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
  398.  
  399. sub bits {
  400.     my $mask ;
  401.     my $catmask ;
  402.     my $fatal = 0 ;
  403.     foreach my $word (@_) {
  404.     if  ($word eq 'FATAL') {
  405.         $fatal = 1;
  406.     }
  407.     elsif ($catmask = $Bits{$word}) {
  408.         $mask |= $catmask ;
  409.         $mask |= $DeadBits{$word} if $fatal ;
  410.     }
  411.     else
  412.           { croak("unknown warnings category '$word'")}  
  413.     }
  414.  
  415.     return $mask ;
  416. }
  417.  
  418. sub import {
  419.     shift;
  420.     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
  421. }
  422.  
  423. sub unimport {
  424.     shift;
  425.     my $mask = ${^WARNING_BITS} ;
  426.     if (vec($mask, $Offsets{'all'}, 1)) {
  427.         $mask = $Bits{'all'} ;
  428.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  429.     }
  430.     ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
  431. }
  432.  
  433. sub enabled
  434. {
  435.     croak("Usage: warnings::enabled([category])")
  436.     unless @_ == 1 || @_ == 0 ;
  437.     local $Carp::CarpLevel = 1 ;
  438.     my $category ;
  439.     my $offset ;
  440.     my $callers_bitmask = (caller(1))[9] ; 
  441.     return 0 unless defined $callers_bitmask ;
  442.  
  443.  
  444.     if (@_) {
  445.         # check the category supplied.
  446.         $category = shift ;
  447.         $offset = $Offsets{$category};
  448.         croak("unknown warnings category '$category'")
  449.         unless defined $offset;
  450.     }
  451.     else {
  452.         $category = (caller(0))[0] ; 
  453.         $offset = $Offsets{$category};
  454.         croak("package '$category' not registered for warnings")
  455.         unless defined $offset ;
  456.     }
  457.  
  458.     return vec($callers_bitmask, $offset, 1) ||
  459.            vec($callers_bitmask, $Offsets{'all'}, 1) ;
  460. }
  461.  
  462.  
  463. sub warn
  464. {
  465.     croak("Usage: warnings::warn([category,] 'message')")
  466.     unless @_ == 2 || @_ == 1 ;
  467.     local $Carp::CarpLevel = 1 ;
  468.     my $category ;
  469.     my $offset ;
  470.     my $callers_bitmask = (caller(1))[9] ; 
  471.  
  472.     if (@_ == 2) {
  473.         $category = shift ;
  474.         $offset = $Offsets{$category};
  475.         croak("unknown warnings category '$category'")
  476.         unless defined $offset ;
  477.     }
  478.     else {
  479.         $category = (caller(0))[0] ; 
  480.         $offset = $Offsets{$category};
  481.         croak("package '$category' not registered for warnings")
  482.         unless defined $offset ;
  483.     }
  484.  
  485.     my $message = shift ;
  486.     croak($message) 
  487.     if vec($callers_bitmask, $offset+1, 1) ||
  488.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  489.     carp($message) ;
  490. }
  491.  
  492. 1;
  493.