home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / B / Lint.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-19  |  9.5 KB  |  372 lines
  1. package B::Lint;
  2.  
  3. our $VERSION = '1.01';
  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<dollar-underscore>
  61.  
  62. This option warns whenever $_ is used either explicitly anywhere or
  63. as the implicit argument of a B<print> statement.
  64.  
  65. =item B<private-names>
  66.  
  67. This option warns on each use of any variable, subroutine or
  68. method name that lives in a non-current package but begins with
  69. an underscore ("_"). Warnings aren't issued for the special case
  70. of the single character name "_" by itself (e.g. $_ and @_).
  71.  
  72. =item B<undefined-subs>
  73.  
  74. This option warns whenever an undefined subroutine is invoked.
  75. This option will only catch explicitly invoked subroutines such
  76. as C<foo()> and not indirect invocations such as C<&$subref()>
  77. or C<$obj-E<gt>meth()>. Note that some programs or modules delay
  78. definition of subs until runtime by means of the AUTOLOAD
  79. mechanism.
  80.  
  81. =item B<regexp-variables>
  82.  
  83. This option warns whenever one of the regexp variables $', $& or
  84. $' is used. Any occurrence of any of these variables in your
  85. program can slow your whole program down. See L<perlre> for
  86. details.
  87.  
  88. =item B<all>
  89.  
  90. Turn all warnings on.
  91.  
  92. =item B<none>
  93.  
  94. Turn all warnings off.
  95.  
  96. =back
  97.  
  98. =head1 NON LINT-CHECK OPTIONS
  99.  
  100. =over 8
  101.  
  102. =item B<-u Package>
  103.  
  104. Normally, Lint only checks the main code of the program together
  105. with all subs defined in package main. The B<-u> option lets you
  106. include other package names whose subs are then checked by Lint.
  107.  
  108. =back
  109.  
  110. =head1 BUGS
  111.  
  112. This is only a very preliminary version.
  113.  
  114. This module doesn't work correctly on thread-enabled perls.
  115.  
  116. =head1 AUTHOR
  117.  
  118. Malcolm Beattie, mbeattie@sable.ox.ac.uk.
  119.  
  120. =cut
  121.  
  122. use strict;
  123. use B qw(walkoptree_slow main_root walksymtable svref_2object parents
  124.          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
  125.         );
  126.  
  127. my $file = "unknown";        # shadows current filename
  128. my $line = 0;            # shadows current line number
  129. my $curstash = "main";        # shadows current stash
  130.  
  131. # Lint checks
  132. my %check;
  133. my %implies_ok_context;
  134. BEGIN {
  135.     map($implies_ok_context{$_}++,
  136.     qw(scalar av2arylen aelem aslice helem hslice
  137.        keys values hslice defined undef delete));
  138. }
  139.  
  140. # Lint checks turned on by default
  141. my @default_checks = qw(context);
  142.  
  143. my %valid_check;
  144. # All valid checks
  145. BEGIN {
  146.     map($valid_check{$_}++,
  147.     qw(context implicit_read implicit_write dollar_underscore
  148.        private_names undefined_subs regexp_variables));
  149. }
  150.  
  151. # Debugging options
  152. my ($debug_op);
  153.  
  154. my %done_cv;        # used to mark which subs have already been linted
  155. my @extra_packages;    # Lint checks mainline code and all subs which are
  156.             # in main:: or in one of these packages.
  157.  
  158. sub warning {
  159.     my $format = (@_ < 2) ? "%s" : shift;
  160.     warn sprintf("$format at %s line %d\n", @_, $file, $line);
  161. }
  162.  
  163. # This gimme can't cope with context that's only determined
  164. # at runtime via dowantarray().
  165. sub gimme {
  166.     my $op = shift;
  167.     my $flags = $op->flags;
  168.     if ($flags & OPf_WANT) {
  169.     return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
  170.     }
  171.     return undef;
  172. }
  173.  
  174. sub B::OP::lint {}
  175.  
  176. sub B::COP::lint {
  177.     my $op = shift;
  178.     if ($op->name eq "nextstate") {
  179.     $file = $op->file;
  180.     $line = $op->line;
  181.     $curstash = $op->stash->NAME;
  182.     }
  183. }
  184.  
  185. sub B::UNOP::lint {
  186.     my $op = shift;
  187.     my $opname = $op->name;
  188.     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
  189.     my $parent = parents->[0];
  190.     my $pname = $parent->name;
  191.     return if gimme($op) || $implies_ok_context{$pname};
  192.     # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
  193.     # null out the parent so we have to check for a parent of pp_null and
  194.     # a grandparent of pp_enteriter or pp_delete
  195.     if ($pname eq "null") {
  196.         my $gpname = parents->[1]->name;
  197.         return if $gpname eq "enteriter" || $gpname eq "delete";
  198.     }
  199.     warning("Implicit scalar context for %s in %s",
  200.         $opname eq "rv2av" ? "array" : "hash", $parent->desc);
  201.     }
  202.     if ($check{private_names} && $opname eq "method") {
  203.     my $methop = $op->first;
  204.     if ($methop->name eq "const") {
  205.         my $method = $methop->sv->PV;
  206.         if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
  207.         warning("Illegal reference to private method name $method");
  208.         }
  209.     }
  210.     }
  211. }
  212.  
  213. sub B::PMOP::lint {
  214.     my $op = shift;
  215.     if ($check{implicit_read}) {
  216.     if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
  217.         warning('Implicit match on $_');
  218.     }
  219.     }
  220.     if ($check{implicit_write}) {
  221.     if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
  222.         warning('Implicit substitution on $_');
  223.     }
  224.     }
  225. }
  226.  
  227. sub B::LOOP::lint {
  228.     my $op = shift;
  229.     if ($check{implicit_read} || $check{implicit_write}) {
  230.     if ($op->name eq "enteriter") {
  231.         my $last = $op->last;
  232.         if ($last->name eq "gv" && $last->gv->NAME eq "_") {
  233.         warning('Implicit use of $_ in foreach');
  234.         }
  235.     }
  236.     }
  237. }
  238.  
  239. sub B::SVOP::lint {
  240.     my $op = shift;
  241.     if ($check{dollar_underscore} && $op->name eq "gvsv"
  242.     && $op->gv->NAME eq "_")
  243.     {
  244.     warning('Use of $_');
  245.     }
  246.     if ($check{private_names}) {
  247.     my $opname = $op->name;
  248.     if ($opname eq "gv" || $opname eq "gvsv") {
  249.         my $gv = $op->gv;
  250.         if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
  251.         warning('Illegal reference to private name %s', $gv->NAME);
  252.         }
  253.     } elsif ($opname eq "method_named") {
  254.         my $method = $op->gv->PV;
  255.         if ($method =~ /^_./) {
  256.         warning("Illegal reference to private method name $method");
  257.         }
  258.     }
  259.     }
  260.     if ($check{undefined_subs}) {
  261.     if ($op->name eq "gv"
  262.         && $op->next->name eq "entersub")
  263.     {
  264.         my $gv = $op->gv;
  265.         my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
  266.         no strict 'refs';
  267.         if (!defined(&$subname)) {
  268.         $subname =~ s/^main:://;
  269.         warning('Undefined subroutine %s called', $subname);
  270.         }
  271.     }
  272.     }
  273.     if ($check{regexp_variables} && $op->name eq "gvsv") {
  274.     my $name = $op->gv->NAME;
  275.     if ($name =~ /^[&'`]$/) {
  276.         warning('Use of regexp variable $%s', $name);
  277.     }
  278.     }
  279. }
  280.  
  281. sub B::GV::lintcv {
  282.     my $gv = shift;
  283.     my $cv = $gv->CV;
  284.     #warn sprintf("lintcv: %s::%s (done=%d)\n",
  285.     #         $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
  286.     return if !$$cv || $done_cv{$$cv}++;
  287.     my $root = $cv->ROOT;
  288.     #warn "    root = $root (0x$$root)\n";#debug
  289.     walkoptree_slow($root, "lint") if $$root;
  290. }
  291.  
  292. sub do_lint {
  293.     my %search_pack;
  294.     walkoptree_slow(main_root, "lint") if ${main_root()};
  295.     
  296.     # Now do subs in main
  297.     no strict qw(vars refs);
  298.     local(*glob);
  299.     for my $sym (keys %main::) {
  300.     next if $sym =~ /::$/;
  301.     *glob = $main::{$sym};
  302.         svref_2object(\*glob)->EGV->lintcv;
  303.     }
  304.  
  305.     # Now do subs in non-main packages given by -u options
  306.     map { $search_pack{$_} = 1 } @extra_packages;
  307.     walksymtable(\%{"main::"}, "lintcv", sub {
  308.     my $package = shift;
  309.     $package =~ s/::$//;
  310.     #warn "Considering $package\n";#debug
  311.     return exists $search_pack{$package};
  312.     });
  313. }
  314.  
  315. sub compile {
  316.     my @options = @_;
  317.     my ($option, $opt, $arg);
  318.     # Turn on default lint checks
  319.     for $opt (@default_checks) {
  320.     $check{$opt} = 1;
  321.     }
  322.   OPTION:
  323.     while ($option = shift @options) {
  324.     if ($option =~ /^-(.)(.*)/) {
  325.         $opt = $1;
  326.         $arg = $2;
  327.     } else {
  328.         unshift @options, $option;
  329.         last OPTION;
  330.     }
  331.     if ($opt eq "-" && $arg eq "-") {
  332.         shift @options;
  333.         last OPTION;
  334.     } elsif ($opt eq "D") {
  335.             $arg ||= shift @options;
  336.         foreach $arg (split(//, $arg)) {
  337.         if ($arg eq "o") {
  338.             B->debug(1);
  339.         } elsif ($arg eq "O") {
  340.             $debug_op = 1;
  341.         }
  342.         }
  343.     } elsif ($opt eq "u") {
  344.         $arg ||= shift @options;
  345.         push(@extra_packages, $arg);
  346.     }
  347.     }
  348.     foreach $opt (@default_checks, @options) {
  349.     $opt =~ tr/-/_/;
  350.     if ($opt eq "all") {
  351.         %check = %valid_check;
  352.     }
  353.     elsif ($opt eq "none") {
  354.         %check = ();
  355.     }
  356.     else {
  357.         if ($opt =~ s/^no_//) {
  358.         $check{$opt} = 0;
  359.         }
  360.         else {
  361.         $check{$opt} = 1;
  362.         }
  363.         warn "No such check: $opt\n" unless defined $valid_check{$opt};
  364.     }
  365.     }
  366.     # Remaining arguments are things to check
  367.     
  368.     return \&do_lint;
  369. }
  370.  
  371. 1;
  372.