home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / Lint.pm < prev    next >
Text File  |  2003-11-07  |  10KB  |  392 lines

  1. package B::Lint;
  2.  
  3. our $VERSION = '1.02';
  4.  
  5. =head1 NAME
  6.  
  7. B::Lint - Perl lint
  8.  
  9. =head1 SYNOPSIS
  10.  
  11. perl -MO=Lint[,OPTIONS] foo.pl
  12.  
  13. =head1 DESCRIPTION
  14.  
  15. The B::Lint module is equivalent to an extended version of the B<-w>
  16. option of B<perl>. It is named after the program B<lint> which carries
  17. out a similar process for C programs.
  18.  
  19. =head1 OPTIONS AND LINT CHECKS
  20.  
  21. Option words are separated by commas (not whitespace) and follow the
  22. usual conventions of compiler backend options. Following any options
  23. (indicated by a leading B<->) come lint check arguments. Each such
  24. argument (apart from the special B<all> and B<none> options) is a
  25. word representing one possible lint check (turning on that check) or
  26. is B<no-foo> (turning off that check). Before processing the check
  27. arguments, a standard list of checks is turned on. Later options
  28. override earlier ones. Available options are:
  29.  
  30. =over 8
  31.  
  32. =item B<context>
  33.  
  34. Produces a warning whenever an array is used in an implicit scalar
  35. context. For example, both of the lines
  36.  
  37.     $foo = length(@bar);
  38.     $foo = @bar;
  39. will elicit a warning. Using an explicit B<scalar()> silences the
  40. warning. For example,
  41.  
  42.     $foo = scalar(@bar);
  43.  
  44. =item B<implicit-read> and B<implicit-write>
  45.  
  46. These options produce a warning whenever an operation implicitly
  47. reads or (respectively) writes to one of Perl's special variables.
  48. For example, B<implicit-read> will warn about these:
  49.  
  50.     /foo/;
  51.  
  52. and B<implicit-write> will warn about these:
  53.  
  54.     s/foo/bar/;
  55.  
  56. Both B<implicit-read> and B<implicit-write> warn about this:
  57.  
  58.     for (@a) { ... }
  59.  
  60. =item B<bare-subs>
  61.  
  62. This option warns whenever a bareword is implicitly quoted, but is also
  63. the name of a subroutine in the current package. Typical mistakes that it will
  64. trap are:
  65.  
  66.     use constant foo => 'bar';
  67.     @a = ( foo => 1 );
  68.     $b{foo} = 2;
  69.  
  70. Neither of these will do what a naive user would expect.
  71.  
  72. =item B<dollar-underscore>
  73.  
  74. This option warns whenever $_ is used either explicitly anywhere or
  75. as the implicit argument of a B<print> statement.
  76.  
  77. =item B<private-names>
  78.  
  79. This option warns on each use of any variable, subroutine or
  80. method name that lives in a non-current package but begins with
  81. an underscore ("_"). Warnings aren't issued for the special case
  82. of the single character name "_" by itself (e.g. $_ and @_).
  83.  
  84. =item B<undefined-subs>
  85.  
  86. This option warns whenever an undefined subroutine is invoked.
  87. This option will only catch explicitly invoked subroutines such
  88. as C<foo()> and not indirect invocations such as C<&$subref()>
  89. or C<$obj-E<gt>meth()>. Note that some programs or modules delay
  90. definition of subs until runtime by means of the AUTOLOAD
  91. mechanism.
  92.  
  93. =item B<regexp-variables>
  94.  
  95. This option warns whenever one of the regexp variables $', $& or
  96. $' is used. Any occurrence of any of these variables in your
  97. program can slow your whole program down. See L<perlre> for
  98. details.
  99.  
  100. =item B<all>
  101.  
  102. Turn all warnings on.
  103.  
  104. =item B<none>
  105.  
  106. Turn all warnings off.
  107.  
  108. =back
  109.  
  110. =head1 NON LINT-CHECK OPTIONS
  111.  
  112. =over 8
  113.  
  114. =item B<-u Package>
  115.  
  116. Normally, Lint only checks the main code of the program together
  117. with all subs defined in package main. The B<-u> option lets you
  118. include other package names whose subs are then checked by Lint.
  119.  
  120. =back
  121.  
  122. =head1 BUGS
  123.  
  124. This is only a very preliminary version.
  125.  
  126. This module doesn't work correctly on thread-enabled perls.
  127.  
  128. =head1 AUTHOR
  129.  
  130. Malcolm Beattie, mbeattie@sable.ox.ac.uk.
  131.  
  132. =cut
  133.  
  134. use strict;
  135. use B qw(walkoptree_slow main_root walksymtable svref_2object parents
  136.          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
  137.         );
  138.  
  139. my $file = "unknown";        # shadows current filename
  140. my $line = 0;            # shadows current line number
  141. my $curstash = "main";        # shadows current stash
  142.  
  143. # Lint checks
  144. my %check;
  145. my %implies_ok_context;
  146. BEGIN {
  147.     map($implies_ok_context{$_}++,
  148.     qw(scalar av2arylen aelem aslice helem hslice
  149.        keys values hslice defined undef delete));
  150. }
  151.  
  152. # Lint checks turned on by default
  153. my @default_checks = qw(context);
  154.  
  155. my %valid_check;
  156. # All valid checks
  157. BEGIN {
  158.     map($valid_check{$_}++,
  159.     qw(context implicit_read implicit_write dollar_underscore
  160.        private_names bare_subs undefined_subs regexp_variables));
  161. }
  162.  
  163. # Debugging options
  164. my ($debug_op);
  165.  
  166. my %done_cv;        # used to mark which subs have already been linted
  167. my @extra_packages;    # Lint checks mainline code and all subs which are
  168.             # in main:: or in one of these packages.
  169.  
  170. sub warning {
  171.     my $format = (@_ < 2) ? "%s" : shift;
  172.     warn sprintf("$format at %s line %d\n", @_, $file, $line);
  173. }
  174.  
  175. # This gimme can't cope with context that's only determined
  176. # at runtime via dowantarray().
  177. sub gimme {
  178.     my $op = shift;
  179.     my $flags = $op->flags;
  180.     if ($flags & OPf_WANT) {
  181.     return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
  182.     }
  183.     return undef;
  184. }
  185.  
  186. sub B::OP::lint {}
  187.  
  188. sub B::COP::lint {
  189.     my $op = shift;
  190.     if ($op->name eq "nextstate") {
  191.     $file = $op->file;
  192.     $line = $op->line;
  193.     $curstash = $op->stash->NAME;
  194.     }
  195. }
  196.  
  197. sub B::UNOP::lint {
  198.     my $op = shift;
  199.     my $opname = $op->name;
  200.     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
  201.     my $parent = parents->[0];
  202.     my $pname = $parent->name;
  203.     return if gimme($op) || $implies_ok_context{$pname};
  204.     # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
  205.     # null out the parent so we have to check for a parent of pp_null and
  206.     # a grandparent of pp_enteriter or pp_delete
  207.     if ($pname eq "null") {
  208.         my $gpname = parents->[1]->name;
  209.         return if $gpname eq "enteriter" || $gpname eq "delete";
  210.     }
  211.     warning("Implicit scalar context for %s in %s",
  212.         $opname eq "rv2av" ? "array" : "hash", $parent->desc);
  213.     }
  214.     if ($check{private_names} && $opname eq "method") {
  215.     my $methop = $op->first;
  216.     if ($methop->name eq "const") {
  217.         my $method = $methop->sv->PV;
  218.         if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
  219.         warning("Illegal reference to private method name $method");
  220.         }
  221.     }
  222.     }
  223. }
  224.  
  225. sub B::PMOP::lint {
  226.     my $op = shift;
  227.     if ($check{implicit_read}) {
  228.     if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
  229.         warning('Implicit match on $_');
  230.     }
  231.     }
  232.     if ($check{implicit_write}) {
  233.     if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
  234.         warning('Implicit substitution on $_');
  235.     }
  236.     }
  237. }
  238.  
  239. sub B::LOOP::lint {
  240.     my $op = shift;
  241.     if ($check{implicit_read} || $check{implicit_write}) {
  242.     if ($op->name eq "enteriter") {
  243.         my $last = $op->last;
  244.         if ($last->name eq "gv" && $last->gv->NAME eq "_") {
  245.         warning('Implicit use of $_ in foreach');
  246.         }
  247.     }
  248.     }
  249. }
  250.  
  251. sub B::SVOP::lint {
  252.     my $op = shift;
  253.     if ( $check{bare_subs} && $op->name eq 'const'
  254.          && $op->private & 64 )        # OPpCONST_BARE = 64 in op.h
  255.     {
  256.     my $sv = $op->sv;
  257.     if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
  258.         warning "Bare sub name '" . $sv->PV . "' interpreted as string";
  259.     }
  260.     }
  261.     if ($check{dollar_underscore} && $op->name eq "gvsv"
  262.     && $op->gv->NAME eq "_")
  263.     {
  264.     warning('Use of $_');
  265.     }
  266.     if ($check{private_names}) {
  267.     my $opname = $op->name;
  268.     if ($opname eq "gv" || $opname eq "gvsv") {
  269.         my $gv = $op->gv;
  270.         if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
  271.         warning('Illegal reference to private name %s', $gv->NAME);
  272.         }
  273.     } elsif ($opname eq "method_named") {
  274.         my $method = $op->gv->PV;
  275.         if ($method =~ /^_./) {
  276.         warning("Illegal reference to private method name $method");
  277.         }
  278.     }
  279.     }
  280.     if ($check{undefined_subs}) {
  281.     if ($op->name eq "gv"
  282.         && $op->next->name eq "entersub")
  283.     {
  284.         my $gv = $op->gv;
  285.         my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
  286.         no strict 'refs';
  287.         if (!defined(&$subname)) {
  288.         $subname =~ s/^main:://;
  289.         warning('Undefined subroutine %s called', $subname);
  290.         }
  291.     }
  292.     }
  293.     if ($check{regexp_variables} && $op->name eq "gvsv") {
  294.     my $name = $op->gv->NAME;
  295.     if ($name =~ /^[&'`]$/) {
  296.         warning('Use of regexp variable $%s', $name);
  297.     }
  298.     }
  299. }
  300.  
  301. sub B::GV::lintcv {
  302.     my $gv = shift;
  303.     my $cv = $gv->CV;
  304.     #warn sprintf("lintcv: %s::%s (done=%d)\n",
  305.     #         $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
  306.     return if !$$cv || $done_cv{$$cv}++;
  307.     my $root = $cv->ROOT;
  308.     #warn "    root = $root (0x$$root)\n";#debug
  309.     walkoptree_slow($root, "lint") if $$root;
  310. }
  311.  
  312. sub do_lint {
  313.     my %search_pack;
  314.     walkoptree_slow(main_root, "lint") if ${main_root()};
  315.     
  316.     # Now do subs in main
  317.     no strict qw(vars refs);
  318.     local(*glob);
  319.     for my $sym (keys %main::) {
  320.     next if $sym =~ /::$/;
  321.     *glob = $main::{$sym};
  322.         svref_2object(\*glob)->EGV->lintcv;
  323.     }
  324.  
  325.     # Now do subs in non-main packages given by -u options
  326.     map { $search_pack{$_} = 1 } @extra_packages;
  327.     walksymtable(\%{"main::"}, "lintcv", sub {
  328.     my $package = shift;
  329.     $package =~ s/::$//;
  330.     #warn "Considering $package\n";#debug
  331.     return exists $search_pack{$package};
  332.     });
  333. }
  334.  
  335. sub compile {
  336.     my @options = @_;
  337.     my ($option, $opt, $arg);
  338.     # Turn on default lint checks
  339.     for $opt (@default_checks) {
  340.     $check{$opt} = 1;
  341.     }
  342.   OPTION:
  343.     while ($option = shift @options) {
  344.     if ($option =~ /^-(.)(.*)/) {
  345.         $opt = $1;
  346.         $arg = $2;
  347.     } else {
  348.         unshift @options, $option;
  349.         last OPTION;
  350.     }
  351.     if ($opt eq "-" && $arg eq "-") {
  352.         shift @options;
  353.         last OPTION;
  354.     } elsif ($opt eq "D") {
  355.             $arg ||= shift @options;
  356.         foreach $arg (split(//, $arg)) {
  357.         if ($arg eq "o") {
  358.             B->debug(1);
  359.         } elsif ($arg eq "O") {
  360.             $debug_op = 1;
  361.         }
  362.         }
  363.     } elsif ($opt eq "u") {
  364.         $arg ||= shift @options;
  365.         push(@extra_packages, $arg);
  366.     }
  367.     }
  368.     foreach $opt (@default_checks, @options) {
  369.     $opt =~ tr/-/_/;
  370.     if ($opt eq "all") {
  371.         %check = %valid_check;
  372.     }
  373.     elsif ($opt eq "none") {
  374.         %check = ();
  375.     }
  376.     else {
  377.         if ($opt =~ s/^no_//) {
  378.         $check{$opt} = 0;
  379.         }
  380.         else {
  381.         $check{$opt} = 1;
  382.         }
  383.         warn "No such check: $opt\n" unless defined $valid_check{$opt};
  384.     }
  385.     }
  386.     # Remaining arguments are things to check
  387.     
  388.     return \&do_lint;
  389. }
  390.  
  391. 1;
  392.