#!/usr/bin/perl -w ############################################################ # $Id: gc,v 1.3 2005/10/24 15:26:13 nicolaw Exp $ # gc - Perl Code Grepper (grep_code) # Copyright: (c)2005 Nicola Worthington. All rights reserved. ############################################################ # This file is part of gc (grep_code) # # gc is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # gc is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with gc; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################ ############################################################ # gc # Written by Nicola Worthington # Based on grep_code.pl by Nicola Worthington # Modified on 2005-10-24 use strict; use vars qw($VERSION); $VERSION = sprintf('%d.%02d', q$Revision: 1.3 $ =~ /(\d+)/g); our $AUTHOR = 'Nicola Worthington '; (our $SELF = $0) =~ s/^.*\///g; # Version thingie defined $ARGV[0] && $ARGV[0] eq '-v' && print("$SELF version $VERSION by $AUTHOR\n") && exit 0; # Define ANSI colours my %c = qw(black 30 red 31 green 32 yellow 33 blue 34 magenta 35 cyan 36 white 37); our %COLOUR = map { ("$_" => "\x1b[0m\x1b[$c{$_}m", "br$_" => "\x1b[0m\x1b[1m\x1b[$c{$_}m", "bg$_" => "\x1b[".($c{$_}+10).'m'); } keys %c; @COLOUR{qw(normal bright)} = ("\x1b[0m","\x1b[1m"); undef %c; # Read .rc file our $CFG = read_config("$ENV{HOME}/.gcrc"); # Slurp and pre-process the data my $data = my $rawdata = get_data(); # Highlight things for my $match (grep(/^highlight_\S+$/,sort keys %{$CFG})) { my ($colour,$regex) = split(/\s+/,$CFG->{$match},2); $data =~ s/($regex)/$COLOUR{$colour}$1$COLOUR{normal}/smg; } # Process comments if ($CFG->{comment_remove}) { $data =~ s{^([ \t]*\#.*?)$}{}smg; } elsif (length $CFG->{comment_prefix} || $CFG->{comment_colour}) { my $prefix = $COLOUR{$CFG->{comment_colour}}.$CFG->{comment_prefix}; #$data =~ s{(^[ \t]*\#)}{$prefix$1}smg; $data =~ s{(^[ \t]*\#.*?$)}{my $m=$1;$m=~s/\x1b\[.+?m//g;$prefix.$m;}smeg; } # Process POD if ($CFG->{pod_remove}) { $data =~ s{(^=[a-z]+\d?.+?^=cut)}{my $m=$1;$m=~s/[^\n]+//smg;$m}smeg; } elsif (length $CFG->{pod_prefix} || $CFG->{pod_colour}) { my $prefix = $COLOUR{$CFG->{pod_colour}}.$CFG->{pod_prefix}; $data =~ s{(^=[a-z]+\d?.+?^=cut)}{ my $m=$1;$m=~s/\x1b\[.+?m//g;$m=~s/^/$prefix/g;$m;}smeg; } # Output data our @roll; our $print; our $line_number = 0; for (split(/\n/,$data)) { $line_number++; if (!m/\x1b\[/i && !$print) { push @roll, $_; shift @roll if @roll > $CFG->{context}; } elsif (!m/\x1b\[/i && $print) { print_line($line_number,$_); $print--; } elsif (m/\x1b\[/i) { print_line($line_number-$#roll-1,shift @roll) while @roll; print_line($line_number,$_); $print = $CFG->{context}; } } print $COLOUR{normal}; # Search and output document for musthave_ requirments print(('-'x80)."\n") if grep(/^musthave_\S+$/,keys %{$CFG}); for my $match (grep(/^musthave_\S+$/,keys %{$CFG})) { if (my (@res) = $rawdata =~ m/$CFG->{$match}/smg) { print "$COLOUR{brgreen}Positive match for '$match': @res$COLOUR{normal}\n"; } else { print "$COLOUR{brred}Could not find match for '$match'$COLOUR{normal}\n" } } ############################################################ # Subroutines sub print_line { my ($line_number,$line) = @_; printf("%s%7d%s %s\n", ($line =~ m/\x1b\[/?$COLOUR{$CFG->{linenum_colour}}. $COLOUR{$CFG->{linenum_highlight}}: $COLOUR{$CFG->{linenum_colour}}), $line_number, ($line =~ m/\x1b\[/?$COLOUR{normal}: $COLOUR{$CFG->{context_colour}}), $line ); } sub get_data { local $/ = undef; if (@_ && $_[0]) { return (read_file($_[0]))[0]; } elsif (key_ready()) { my $data = ; return $data; } elsif (@ARGV) { return (read_file(pop(@ARGV)))[0]; } else { die "Supply with STDIN or arguments, stupid!\n"; } } sub read_file { open(FH,"<$_[0]")||die "Unable to open file handle FH for file '$_[0]': $!"; my @data = ; close(FH)||die "Unable to close file handle FH for file '$_[0]': $!"; return @data; } sub key_ready { my ($rin, $nfd) = ('',''); vec($rin, fileno(STDIN), 1) = 1; return $nfd = select($rin,undef,undef,0); } sub read_config { my @data; if (-e $_[0]) { @data = read_file($_[0]); } else { @data = ; if (open(RC,">$_[0]")) { print(RC $_) for @data; close(RC); } } chomp @data; my %data; for (@data) { next if /^\s*(\#|;)/ || /^\s*$/; if (/^\s*(\S+)(?:\s+|\s*=>?\s*)("|')?(.+?)\2?\s*$/) { $data{lc($1)} = $3; } } return set_defaults(\%data); } sub set_defaults { my $data = shift; my %defaults = (qw(linenum_colour bryellow linenum_highlight bgred pod_colour brcyan comment_colour blue context 3), ('pod_prefix','###POD### ','comment_prefix','###COMMENT### ')); $data->{$_} ||= $defaults{$_} for keys %defaults; return $data; } ############################################################ # POD documentation =pod =head1 NAME gc - Grep Code =head1 SYNOPSYS gc Module.pm cat ~/script.pl | gc for i in `find ~ -type f -name "*.pm"`;do echo $i; gc $i; echo "";done =head1 DESCRIPTION This code needs to be tidied up and documented for public release. =head1 VERSION $Id: gc,v 1.3 2005/10/24 15:26:13 nicolaw Exp $ $Revision: 1.3 $ =head1 AUTHOR $Author: nicolaw $ Nicola Elizabeth Worthington =cut ############################################################ # .gcrc __DATA__ ############################################################ # # $Revision: 1.3 $ # $Author: nicolaw $ # # This is a default .gcrc file. It is not a production ready # version. It will however give you a pretty reasonable basic # grep of perl code. # ############################################################ # Colours # BRIGHT BACKGROUND # black brblack (grey) bgblack # red brred bgred # green brgreen bggreen # yellow (brown) bryellow bgyellow (brown) # blue brblue bgblue # magenta brmagenta bgmagenta # cyan brcyan bgcyan # white brwhite bgwhite # ############################################################ # General configuration context 3 context_colour brblack linenum_colour bryellow linenum_highlight bgred pod_prefix "###POD### " pod_colour blue pod_remove true comment_prefix "###COMMENT### " comment_colour blue comment_remove true ############################################################ # Directives beginning with "musthave_" should be followed # by a perl regular expression musthave_version \(?\$VERSION\)?\s*=\s*.*?; musthave_strict ^use strict\b.*?; musthave_contact (?:^=head\d AUTHOR|\$Author: nicolaw $|^\s*\#[^\n]*(?i)(?:contact|author|maintainer|written\s*by).*?$) ############################################################ # Directives beginning with "highlight_" should be followed # by a colour and a perl regular expression highlight_01modules cyan ((use\s+)?(English|Apache::File|FileHandle::(\S+)?|IO::(\S+)?|File::(\S+)?|CGI::(\S+)?|AutoLoader(\s+.+?)?;|Exporter(\s+.+?)?;)) highlight_02fileio red \b(open|opendir|sysopen|opendbm|unlink|mkdir|rmdir|chmod|tie|rename)\b highlight_03bbckw red \b(BBC::KW(::\S+)?|(add_|set_)?ok2(read|write))\b highlight_04process red \b(exit|system|fork|exec|require|kill|sleep|use|eval|do)\b highlight_05backticks brred ` highlight_06paths green (/home/system|/proc|/dev|/tmp|/var/tmp|/usr|\.cfg|\.conf|\.cnf|\.ini) highlight_07urls green (http://|https://|file://|ftp://) highlight_08regex magenta (gx|/ee) highlight_09core magenta (^package\s+\S+?;|CORE::(\S+)?|UNIVERSAL::(\S+)?|main::(\S+)?|overload) highlight_10env yellow ([\$\%\@\{]?ENV\}?|[\$\%\@\{]?INC\}?|[\$\@\{]?ISA\}?|[\$\@\{]?EXPORT_OK\}?|[\$\@\{]?EXPORT\}?|[\$\%\@\{]?EXPORT_TAGS\}?|\$VERSION|\$AUTOLOAD) highlight_12debug brblue (\bwarn\b|\bSTDERR\b|\bDEBUG\b|\bVERBOSE\b|\bDEV\b|\bTEST\b|\bLIVE\b) highlight_11sql bryellow (INSERT\s+INTO|DELETE\s+FROM|DROP\s+TABLE|CREATE\s+TABLE|ALTER\s+TABLE|UPDATE\s+\S+\s+SET)