#!/usr/bin/perl
## no critic VersionVar
use strict;
use warnings;

use Getopt::Long 'GetOptions';
use autouse 'File::Find'      => 'find';
use autouse 'Pod::Usage'      => 'pod2usage';
use autouse 'Term::ANSIColor' => 'colored';

use autouse 'IPC::Open3' => 'open3';
$SIG{CHLD} = 'IGNORE';

use vars qw( $TextOnly );

main();
exit;

sub main {

    # Fetch parameters.
    GetOptions(
        man  => sub { pod2usage( -verbose => 2 ) },
        help => sub { pod2usage( -verbose => 1 ) },

        t        => \$TextOnly,
        l        => \my ($filename_only),
        w        => \my ($word),
        i        => \my ($ignore_case),
        Q        => \my ($quotemeta),
        h        => \my ($no_filename),
        n        => \my ($line_no),
        R        => \my ($no_recursive),
        v        => \my ($invert_match),
        plain    => \my ($no_ansicolor),
        'name=s' => \my ($filename_rx),
        )
        or pod2usage( -verbose => 0 );
    my ( $match, @srcs ) = @ARGV;
    if ( not @srcs ) {
        @srcs = '.';    ## no critic Noisy
    }

    # Validate parameters.
    if ( not defined $match ) {
        pod2usage( -verbose => 0 );
    }

    # Pre-process the pattern and then compile it.
    if ($quotemeta) {
        $match = quotemeta $match;
    }
    if ($word) {
        $match = "\\b$match\\b";
    }
    if ($ignore_case) {
        $match = "(?i)$match";
    }
    my $match_rx = qr/$match/;

    # Get a function which formats the output for whatever was
    # requested. All info is passed through the globals
    # $File::Find::rel_name, $., and $_. The input will contain
    # whatever linebreak is currently active so most things don't need
    # to add one.
    my $prev_file = '';
    my $formatter = (
        $line_no && $no_filename
        ? sub { "$.:" . shift }
        : $line_no ? sub {
            if ( $File::Find::name ne $prev_file ) {
                $prev_file = $File::Find::name;
                return ( ( $prev_file eq '' ? '' : "\n" )
                    . colored( $File::Find::name, 'bold green' ) . "\n
+$.:"
                        . shift );
            }
            else {
                return "$.:" . shift;
            }
            }
        : $no_filename   ? sub {shift}
        : $filename_only ? sub {
            if ( $File::Find::name ne $prev_file ) {
                $prev_file = $File::Find::name;
                return ( ( $prev_file eq '' ? '' : "\n" )
                    . colored( $File::Find::name, 'bold green' )
                        . "\n" );
            }
            else {
                return;
            }
            }
        : sub {
            if ( $File::Find::name ne $prev_file ) {
                $prev_file = $File::Find::name;
                return ( ( $prev_file eq '' ? '' : "\n" )
                    . colored( $File::Find::name, 'bold green' ) . "\n
+"
                        . shift );
            }
            else {
                return shift;
            }
        }
    );

    my $grep_file_fn = sub {
        grep_file(
            ignore_rcs   => 1,
            plain        => $no_ansicolor,
            match_rx     => $match_rx,
            filename_rx  => $filename_rx,
            formatter    => $formatter,
            invert_match => $invert_match,
            match_once   => $filename_only
        );
    };

    # Here's the main loop. For each source directory/file, search it.
    for my $src (@srcs) {

        # Examine all files in $src.
        if ($no_recursive) {

            # Mimic the API of File::Find for grep_file().
            # local $File::Find::dir = unimplemented
            ## no critic
            local $File::Find::name = $src;
            local $_                = $src;

            $grep_file_fn->();
        }
        else {
            find( $grep_file_fn, $src );
        }
    }

    return 0;
}

sub open_file_harder {
    my ($filename) = @_;
    return if not defined $filename;

    if ( my ($extension) = $filename =~ /(\.[^.]+)\z/mx ) {
        my @readers = (
            [ qr/\.t(?:ar\.)?gz\z/ => qw( gzcat ),    $filename ],
            [ qr/\.zip\z/,         => qw( unzip -p ), $filename ],
            [ qr/\.Z\z/            => qw( zcat ),     $filename ],
            [ qr/\.gz\z/           => qw( gzcat ),    $filename ],
            [ qr/\.bz2\z/          => qw( bzcat ),    $filename ],
        );
        for my $reader (@readers) {
            my ( $pattern, @command ) = @{$reader};
            if ( $extension =~ $pattern ) {
                open3( undef, my $fh, undef, @command );
                return $fh;
            }
        }
    }

    open my $fh, '<', $filename
        or die "Couldn't open $filename: $!";
    return $fh;
}

sub grep_file {
    my %p            = @_;
    my $match_rx     = $p{match_rx};
    my $formatter    = $p{formatter};
    my $invert_match = $p{invert_match};
    my $plain        = $p{plain};
    my $match_once   = $p{match_once};

    my $filename = $_;

    # Ignore CVS stuff.
    return if $File::Find::name =~ m{/CVS/?};

    # If there is a pattern required of filenames, try that one
    # first. This requires no checks to the FS so I'm doing this
    # before the next stuff.
    return
        if defined $p{filename_rx}
        and not $filename =~ $p{filename_rx};

    # Ignore non-existant files.
    return if not -f $filename;

    # Ignore non-text files if that's what was requested.
    return if $TextOnly and not -T _;

    eval {
        my $fh = open_file_harder($filename);

    LINE: while ( my $line = <$fh> ) {

            # If the line matches the pattern print it as a formatted
            # line.
            my $matched;

            if ($plain) {
                $matched = ( $line =~ /$match_rx/mx );
            }
            else {
                $matched = ( $line =~ /$match_rx/mx );

                $line
                    =~ s/((?:$match_rx)+)/ colored( "$1", 'yellow on_b
+lack' ) /gemx;
            }

            # Given    Match         then exclusive or is great here.
            #            0   1
            #          +---+---+
            # Invert 0 |   | X |
            #        1 | X |   |
            if ( $matched xor $invert_match ) {
                print $formatter->($line);
                last LINE if $match_once;
            }
        }
    };

    return 1;
}

__END__

=head1 NAME

dgrep - A recursive grep that uses perl regular expressions.

=head1 SYNOPSIS

dgrep [options] [file ...]

 Options:
   -help      Prints this help message
   -man       Prints the manual

   -t         Searches only `text' files
   -w         Matches only "words" using \b...\b
   -i         Case-insensitive matching
   -Q         Ignore perl meta-characters

   -v         Invert output, match lines that don't match the pattern
   -h         Exclude filename from output
   -n         Include line number in output

   -R         Disable recursion, no directories.
   -plain     Disable highliting of matched text
   -name EXPR Only open files matching this regular expression

=head1 OPTIONS

=over 4

=item B<-help>

Prints a simple message on usage and then exits.

=item B<-man>

Prints the manual and then exits.

=item B<-t>

Only `text' files are searched.

=item B<-w>

When matching, the pattern is surrounded by perl\'s \b assertion. That
is, the match must be on a "word" boundary, either starting or
finishing. To perl, "word" is locale specific but generally means any
alphanumeric character and underscore.

=item B<-i>

Match without regard to casing. This is affected by locale.

=item B<-Q>

Pattern is a literal string. All regex metacharacters will be escaped
using the quotemeta() function.

=item B<-v>

Print only lines which do B<not> match the pattern. This is equivalent
to grep\'s -v parameter.

=item B<-h>

Omit the filename from the output when a line is matched. This is
semi-equivalent to grep\'s -h parameter.

=item B<-n>

Print the line number.

=item B<-R>

Do not recurse into any subdirectories.

=item B<-plain>

C<dgrep> automatically inserts ANSI escape codes to highlight matched
text. Use the C<-plain> option to disable that.

=item B<-name> EXPR

C<dgrep> usually searches every file and directory, recursively. When
C<-name EXPR> is used, only filenames matching this regular expression
are searched.

=back

=head1 DESCRIPTION

B<dgrep> is an "improved" version of the grep that comes with the Sun
box. It is normally recursive, accepts perl regular expressions, and
optionally prints the filename the match was found in.

=cut
[download]