File Coverage

blib/lib/PPIx/Grep.pm

Criterion	Covered	Total	%
statement	76	261	29.1
branch	5	88	5.6
condition	0	3	0.0
subroutine	24	52	46.1
pod	5	5	100.0
total	110	409	26.8

package PPIx::Grep;

use 5.008001;
use utf8;

use strict;
use warnings;

use version; our $VERSION = qv('v0.0.6');

use English qw<-no_match_vars>;
use Carp qw< confess >;
use Readonly;

use Exporter qw< import >;

our @EXPORT_OK =
    qw<
        run
        set_print_format
    >;
our %EXPORT_TAGS    = (
    all => [@EXPORT_OK],
);

use File::Next ();
use Getopt::Long ();
use List::MoreUtils qw< any none >;
use PPI::Document ();
use PPIx::Shorthand qw< get_ppi_class >;
use String::Format qw< stringf >;


Readonly my $NUMBER_OF_PPI_LOCATION_COMPONENTS => 3;
Readonly my $PPI_LINE_NUMBER        => 0;
Readonly my $PPI_CHARACTER_NUMBER   => 1;
Readonly my $PPI_COLUMN_NUMBER      => 2;
Readonly my @OPTIONS => qw<
    format=s
    match=s
    help|h|?
    version|V
>;
#    usage
#    man
#    chomp
#    ignore-case|i
#    files-with-matches|l
#    files-without-match|L
#    no-filename|h
#    with-filename|H
#    line-number|n
#    invert-match|v
#    tab-length
Readonly my $EXIT_CODE_FOUND      => 0;
Readonly my $EXIT_CODE_NOT_FOUND  => 1;
Readonly my $EXIT_CODE_ERROR      => 2;

Readonly my %ignored_directories =>
    map { $_ => 1 }
    qw<
        .bzr
        .cdv
        ~.dep
        ~.dot
        ~.nib
        ~.plst
        .git
        .hg
        .pc
        .svn
        blib
        CVS
        RCS
        SCCS
        _darcs
        _sgbak
        autom4te.cache
        cover_db
        _build
    >;


my $stdout       = *STDOUT;
my $stderr       = *STDERR;
my $match        = undef;
my $print_format = "%f:%l:%c:%s\n";


sub run {
    my @argv = @_;

    binmode _get_stdout(), ':utf8';
    binmode _get_stderr(), ':utf8';

    my %options = _initialize_from_command_line(\@argv);
    if (_handle_info_requests(\%options)) {
        return $EXIT_CODE_ERROR;
    } # end if

    if (@argv < 2) {
        _emit_usage_message();
        return $EXIT_CODE_ERROR;
    } # end if

    my ($pattern, @paths) = @argv;
    my @ppi_classes = _derive_ppi_classes($pattern)
        or return $EXIT_CODE_ERROR;

    my $file_error = 0;
    my $iterator = File::Next::files(
        {
            file_filter => sub {
                    not _is_ignored_file($_)
                and _is_perl_file($File::Next::name, $file_error)
            },
            descend_filter => sub { not _is_ignored_directory($_) },
        },
        @paths,
    );

    my $return_code = $EXIT_CODE_NOT_FOUND;
    while ( defined ( my $file = $iterator->() ) ) {
        my $found_something =
            _search_and_emit(
                $file,
                $file,
                _build_query(\@ppi_classes),
                _get_stdout()
            );

        if (not defined $found_something) {
            $return_code = $EXIT_CODE_ERROR;
        } elsif ( $EXIT_CODE_ERROR != $return_code and $found_something ) {
            $return_code = $EXIT_CODE_FOUND;
        } # end if
    } # end foreach

    if ($file_error) {
        $return_code = $EXIT_CODE_ERROR;
    }

    return $return_code;
} # end run()


sub _initialize_from_command_line {
    my ($argv) = @_;
    my %values;

    Getopt::Long::Configure( qw< bundling permute no_getopt_compat> );
    if ( Getopt::Long::GetOptionsFromArray($argv, \%values, @OPTIONS) ) {
        _set_options(\%values) or return;

        return %values;
    } # end if

    return;
} # end _initialize_from_command_line()


sub _handle_info_requests {
    my ($options) = @_;

    if ($options->{help}) {
        _emit_usage_message();

        return 1;
    } # end if

    if ($options->{version}) {
        _emit_version();

        return 1;
    } # end if

    return;
} # end _handle_info_requests()


sub _emit_usage_message {
    print {_get_stderr()} <<'END_USAGE';  ## no critic (RequireCheckedSyscalls)
ppigrep [--match regex] [--format format] PPI-class file [...]

ppigrep { -h | --help | -V | --version }

--format escapes:
    %f – The name of the file.
    %l – The starting line number of the element.
    %c – The starting character within the first line of the element.
    %C – The starting column within the first line of the element.
    %L – The class of the element, with the 'PPI::' prefix removed.
    %s – The source-code/content for the element.
    %S – The source-code/content for the element, Ced.
    %W – The source-code/content for the element, whitespace shrunk.

(Note: file argument is required-- STDIN is not yet handled.)
END_USAGE

    return;
} # end _emit_usage_message()

sub _emit_version {
    print {_get_stderr()} <<"END_VERSION";  ## no critic (RequireCheckedSyscalls)
ppigrep $VERSION, Copyright ©2007-2008, Elliot Shank .
END_VERSION

    return;
} # end _emit_usage_message()


sub _derive_ppi_classes {
    my ($pattern) = @_;

    my @ppi_classes;
    foreach my $subpattern ( split m/,/xms, $pattern ) {
        my $ppi_class = get_ppi_class($subpattern);
        if (not $ppi_class) {
            print
                {_get_stderr()}
                qq;
            return;
        } # end if

        push @ppi_classes, $ppi_class;
    } # end foreach

    if (not @ppi_classes) {
        print
            {_get_stderr()}
            qq;

        return;
    } # end if

    return @ppi_classes;
} # end _derive_ppi_classes()


sub _build_query {
    my ($ppi_classes) = @_;

    my $ppi_class;
    if ( 1 == @{$ppi_classes} ) {
        $ppi_class = $ppi_classes->[0]
    } # end if

    if ( my $match = _get_match() ) {
        if ($ppi_class) {
            return sub {
                my (undef, $element) = @_;

                return 0 if not $element->isa($ppi_class);
                return 1 if $element->content() =~ $match;
                return 0;
            };
        } # end if

        return sub {
            my (undef, $element) = @_;

            return 0 if none { $element->isa($_) } @{$ppi_classes};
            return 1 if $element->content() =~ $match;
            return 0;
        };
    } # end if

    return $ppi_class if ($ppi_class);

    return sub {
        my (undef, $element) = @_;

        return 1 if any { $element->isa($_) } @{$ppi_classes};
        return 0;
    };
} # end _build_query()


sub _search_and_emit {
    my ($source, $source_description, $query, $destination) = @_;

    my $document = _create_document($source, $source_description)
        or return;
    $document->index_locations();

    my $elements = $document->find($query);
    if ($elements) {
        foreach my $element ( @{$elements} ) {
            my $location = $element->location();
            my @location_components;
            if ($location) {
                @location_components = @{$location};
            } else {
                @location_components = (q<>) x $NUMBER_OF_PPI_LOCATION_COMPONENTS;
            } # end if

            print
                {$destination}
                _format_element($element, $source, \@location_components);
        } # end foreach

        return 1;
    } # end if

    return 0;
} # end _search_and_emit()

sub _create_document {
    my ($source, $source_description) = @_;

    if ( not -e $source ) {
        print {_get_stderr()} qq<"$source_description" does not exist.\n>;
        return;
    } # end if

    if ( not -r $source ) {
        print {_get_stderr()} qq<"$source_description" is not readable.\n>;
        return;
    } # end if

    if ( -d $source ) {
        print {_get_stderr()} qq<"$source_description" is a directory.\n>;
        return;
    } # end if

    if ( -z $source ) {
        # PPI barfs on empty documents for some reason.
        return PPI::Document->new();
    }

    my $document = PPI::Document->new($source, readonly => 1);
    if (not $document) {
        print {_get_stderr()} qq;
        return;
    } # end if

    return $document;
} # _create_document()


sub _set_options {
    my ($options) = @_;

    my $match = $options->{match};
    if ($match) {
        my $compiled_match;

        eval { $compiled_match = qr/$match/; 1; } ## no critic (RegularExpressions)
            or do {
                if ($EVAL_ERROR) {
                    (my $error = $EVAL_ERROR) =~
                        s< \s+ at \s+ \S+ \s+ line \s+ \d+ .* ><>xms;
                    chomp $error;

                    print {_get_stderr()} qq;

                    return;
                }

                print {_get_stderr()} qq;
                return;
            };

        set_match( $compiled_match );
    } # end if

    my $format = $options->{format};
    if ($format) {
        set_print_format( "$format\n" );
    } # end if

    return 1;
} # end _set_options()


sub _get_stdout {
    return $stdout;
} # end _get_stdout()

sub set_stdout {
    my ($destination) = @_;

    $stdout = $destination;

    return;
} # end set_stdout()


sub _get_stderr {
    return $stderr;
} # end _get_stderr()

sub set_stderr {
    my ($destination) = @_;

    $stderr = $destination;

    return;
} # end set_stderr()


sub _get_match {
    return $match;
} # end _get_match()

sub set_match {
    my ($new_pattern) = @_;

    $match = $new_pattern;

    return;
} # end set_match()


sub _get_print_format {
    return $print_format;
} # end _get_print_format()

sub set_print_format {
    my ($new_format) = @_;

    $print_format = $new_format;

    return;
} # end set_print_format()

Readonly my $PPI_PREFIX_LENGTH => length 'PPI::';

sub _format_element {
    my ($element, $filename, $location_components) = @_;

    my %format_specification = (
        f => $filename,
        l => $location_components->[$PPI_LINE_NUMBER],
        c => $location_components->[$PPI_CHARACTER_NUMBER],
        C => $location_components->[$PPI_COLUMN_NUMBER],
        L => sub { substr $element->class(), $PPI_COLUMN_NUMBER },
        s => sub { $element->content() },
        S => sub { _invoke_method($element, $_[0]) },
        t => sub { my $source = $element->content(); chomp $source; $source },
        T => sub { my $source = _invoke_method($element, $_[0]); chomp $source; $source },
        w => sub { _strip( $element ) },
        W => sub { _strip( _invoke_method($element, $_[0]) ) },
    );

    return stringf(_get_print_format(), %format_specification);
} # end _format_element()

# Invoke an arbitrary method safely on an element.
sub _invoke_method {
    my ($element, $method_name) = @_;

    my $value;
    local $EVAL_ERROR = undef;
    eval { $value = $element->$method_name(); 1; } or return '';

    if (not defined $value) {
        return '';
    } # end if

    return $value;
} # end _invoke_method()

sub _strip {
    my ($element) = @_;

    my $source = "$element"; # no content(): may be a plain string.
    $source =~ s< \A \s+ ><>xms;
    $source =~ s< \s+ \z ><>xms;
    $source =~ s< \s+ >< >xmsg;

    return $source;
} # end _strip()


sub _is_ignored_directory {
    my ($directory) = @_;

    return 1 if $ignored_directories{$directory};
    return 0;
}

sub _is_ignored_file {
    my ($file) = @_;

    return 1 if $file =~ qr< (?: [.] bak | ~ ) \z >xms;
    return 1 if $file =~ qr< [#] .+ [#] \z       >xms;
    return 1 if $file =~ qr< [._] .* \.swp \z    >xms;
    return $file =~ qr< core [.] \d+ \z      >xms;
}

sub _is_perl_file {
    my ($file, $error) = @_;

    return 1 if $file =~ m/ [.] (?: p (?: l x? | m ) | t | PL ) \z /xms; ## no critic (ProhibitSingleCharAlternation)
    return 0 if index($file, q<.>) >= 0;
    return _is_perl_program($file, $error);
}

sub _is_perl_program {
    my ($file, $error) = @_;

    if (open my $handle, '<', $file) {
        my $first_line = <$handle>;

        if (not close $handle) {
            print {*STDERR} qq;
            ${$error} = 1;
            return 0;
        }

        return $first_line =~ m< \A [#]! .* \bperl >xms;
    }

    print {*STDERR} qq;
    ${$error} = 1;
    return 0;
}


1; # Magic true value required at end of module.

__END__