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