examples/find_naughty.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 # Walk through a perl script and look for 'naughty match variables'
   5 # $`, $&, and $', which may cause poor performance.
   6 #
   7 # usage:
   8 # find_naughty file1 [file2 [...]]
   9 # find_naughty <file.pl
  10 #
  11 # Author: Steve Hancock, July 2003
  12 #
  13 # TODO:
  14 # - recursive processing might be nice
  15 #
  16 # Inspired by the discussion of naughty match variables at:
  17 # http://www.perlmonks.org/index.pl?node_id=276549
  18 #
  19 use Getopt::Std;
  20 use IO::File;
  21 $| = 1;
  22 use vars qw($opt_h);
  23 my $usage = <<EOM;
  24 usage:
  25   find_naughty file1 [file2 [...]]
  26   find_naughty <file.pl
  27 EOM
  28 getopts('h') or die "$usage";
  29 if ($opt_h) { die $usage }
  30
  31 unless (@ARGV) { unshift @ARGV, '-' }    # stdin
  32 foreach my $source (@ARGV) {
  33     PerlTokenSearch::find_naughty(
  34         _source   => $source,
  35     );
  36 }
  37
  38 #####################################################################
  39 #
  40 # The PerlTokenSearch package is an interface to perltidy which accepts a
  41 # source filehandle and looks for selected variables.
  42 #
  43 # It works by making a a callback object with a write_line() method to
  44 # receive tokenized lines from perltidy.
  45 #
  46 # Usage:
  47 #
  48 #   PerlTokenSearch::find_naughty(
  49 #       _source         => $fh,             # required source
  50 #   );
  51 #
  52 # _source is any source that perltidy will accept, including a
  53 # filehandle or reference to SCALAR or ARRAY
  54 #
  55 #####################################################################
  56
  57 package PerlTokenSearch;
  58 use Carp;
  59 use Perl::Tidy;
  60
  61 sub find_naughty {
  62
  63     my %args = ( @_ );
  64     print "Testing File: $args{_source}\n";
  65
  66     # run perltidy, which will call $formatter's write_line() for each line
  67     perltidy(
  68         'source'    => $args{_source},
  69         'formatter' => bless( \%args, __PACKAGE__ ),    # callback object
  70         'argv' => "-npro -se",    # -npro : ignore .perltidyrc,
  71                                   # -se   : errors to STDOUT
  72     );
  73 }
  74
  75 sub write_line {
  76
  77     # This is called back from perltidy line-by-line
  78     # We're looking for $`, $&, and $'
  79     my ( $self, $line_of_tokens ) = @_;
  80     my $source            = $self->{_source};
  81
  82     # pull out some stuff we might need
  83     my $line_type         = $line_of_tokens->{_line_type};
  84     my $input_line_number = $line_of_tokens->{_line_number};
  85     my $input_line        = $line_of_tokens->{_line_text};
  86     my $rtoken_type       = $line_of_tokens->{_rtoken_type};
  87     my $rtokens           = $line_of_tokens->{_rtokens};
  88     chomp $input_line;
  89
  90     # skip comments, pod, etc
  91     return if ( $line_type ne 'CODE' );
  92
  93     # loop over tokens looking for $`, $&, and $'
  94     for ( my $j = 0 ; $j < @$rtoken_type ; $j++ ) {
  95
  96         # we only want to examine token types 'i' (identifier)
  97         next unless $$rtoken_type[$j] eq 'i';
  98
  99         # pull out the actual token text
 100         my $token = $$rtokens[$j];
 101
 102         # and check it
 103         if ( $token =~ /^\$[\`\&\']$/ ) {
 104             print STDERR
 105               "$source:$input_line_number: $token\n";
 106         }
 107     }
 108 }
 109
 110 # optional routine, called once after the last line of a file
 111 sub finish_formatting {
 112     my $self = shift;
 113     return;
 114 }