Imported Upstream version 20120701

[perltidy.git] / examples / find_naughty.pl

diff --git a/examples/find_naughty.pl b/examples/find_naughty.pl
new file mode 100644 (file)
index 0000000..fc5a750
--- /dev/null
+++ b/examples/find_naughty.pl
@@ -0,0 +1,114 @@
+#!/usr/bin/perl -w
+use strict;
+
+# Walk through a perl script and look for 'naughty match variables'
+# $`, $&, and $', which may cause poor performance.
+#
+# usage:
+# find_naughty file1 [file2 [...]]
+# find_naughty <file.pl 
+#
+# Author: Steve Hancock, July 2003
+#
+# TODO:
+# - recursive processing might be nice
+#
+# Inspired by the discussion of naughty match variables at:
+# http://www.perlmonks.org/index.pl?node_id=276549
+#
+use Getopt::Std;
+use IO::File;
+$| = 1;
+use vars qw($opt_h);
+my $usage = <<EOM;
+usage:
+  find_naughty file1 [file2 [...]]
+  find_naughty <file.pl 
+EOM
+getopts('h') or die "$usage";
+if ($opt_h) { die $usage }
+
+unless (@ARGV) { unshift @ARGV, '-' }    # stdin
+foreach my $source (@ARGV) {
+    PerlTokenSearch::find_naughty(
+        _source   => $source,
+    );
+}
+
+#####################################################################
+#
+# The PerlTokenSearch package is an interface to perltidy which accepts a
+# source filehandle and looks for selected variables.
+#
+# It works by making a a callback object with a write_line() method to
+# receive tokenized lines from perltidy.  
+#
+# Usage:
+#
+#   PerlTokenSearch::find_naughty(
+#       _source         => $fh,             # required source
+#   );
+#
+# _source is any source that perltidy will accept, including a
+# filehandle or reference to SCALAR or ARRAY
+#
+#####################################################################
+
+package PerlTokenSearch;
+use Carp;
+use Perl::Tidy;
+
+sub find_naughty {
+
+    my %args = ( @_ );
+    print "Testing File: $args{_source}\n";
+
+    # run perltidy, which will call $formatter's write_line() for each line
+    perltidy(
+        'source'    => $args{_source},
+        'formatter' => bless( \%args, __PACKAGE__ ),    # callback object
+        'argv' => "-npro -se",    # -npro : ignore .perltidyrc,
+                                  # -se   : errors to STDOUT
+    );
+}
+
+sub write_line {
+
+    # This is called back from perltidy line-by-line
+    # We're looking for $`, $&, and $'
+    my ( $self, $line_of_tokens ) = @_;
+    my $source            = $self->{_source};
+
+    # pull out some stuff we might need
+    my $line_type         = $line_of_tokens->{_line_type};
+    my $input_line_number = $line_of_tokens->{_line_number};
+    my $input_line        = $line_of_tokens->{_line_text};
+    my $rtoken_type       = $line_of_tokens->{_rtoken_type};
+    my $rtokens           = $line_of_tokens->{_rtokens};
+    chomp $input_line;
+
+    # skip comments, pod, etc
+    return if ( $line_type ne 'CODE' );
+
+    # loop over tokens looking for $`, $&, and $'
+    for ( my $j = 0 ; $j < @$rtoken_type ; $j++ ) {
+
+        # we only want to examine token types 'i' (identifier)
+        next unless $$rtoken_type[$j] eq 'i';
+
+        # pull out the actual token text
+        my $token = $$rtokens[$j];
+
+        # and check it
+        if ( $token =~ /^\$[\`\&\']$/ ) {
+            print STDERR
+              "$source:$input_line_number: $token\n";
+        }
+    }
+}
+
+# optional routine, called once after the last line of a file
+sub finish_formatting {
+    my $self = shift;
+    return;
+}