view release on metacpan or  search on metacpan

lib/App/cpangrep.pm  view on Meta::CPAN

        my $search = search($query)
            or return 2;

        if ($list) {
            display_list($search);
        } else {
            display($search);
        }
        return 0;
    }
    return 0;
}

sub help {
    return <<'    USAGE';
usage: cpangrep [--debug] <query>

The query is a Perl regular expression without look-ahead/look-behind.
Several operators are supported as well for advanced use.

See <http://grep.cpan.me/about#re> for more information.

Multiple query arguments will be joined with spaces for convenience.

  -l            List only matching filenames.  Note that omitted results are
                not mentioned, but your pattern is likely to match many more
                files than output.

  --color       Enable colored output even if STDOUT isn't a terminal
  --no-color    Disable colored output
  --no-pager    Disable output through a pager

  --server      Specifies an alternate server to use, for example:
                    --server http://localhost:5000

  --debug       Print debug messages to stderr
  --help        Show this help and exit
  --version     Show version

    USAGE
}

sub search_url     { "$SERVER/?q="    . uri_escape(shift) }
sub search_api_url { "$SERVER/api?q=" . uri_escape(shift) }

sub search {
    my $query = shift;
    my $ua    = LWP::UserAgent->new(
        agent => "cpangrep/$VERSION",
    );
    $ua->env_proxy;

    my $response = $ua->get( search_api_url($query) );

    if (not $response->is_success) {
        warn "Request failed: ", $response->status_line, "\n";
        return;
    }

    my $content = $response->decoded_content;
    debug("Successfully received " . length($content) . " bytes");

    my $result = eval { decode_json($content) };
    if ($@ or not $result) {
        warn "Error decoding JSON response: $@\n";
        debug($content);
        return;
    }
    return $result;
}

sub display {
    my $search  = shift or return;
    my $results = $search->{results} || [];
    printf "%d result%s in %d file%s.",
        $search->{count}, ($search->{count} != 1 ? "s" : ""),
        scalar @$results, (@$results        != 1 ? "s" : "");

    my $display_total = sum map { scalar @{$_->{results}} }
                            map { @{$_->{files}} }
                                @$results;
    printf "  Showing first %d results.", $display_total
        if $display_total and $display_total != $search->{count};
    print "\n\n";

    for my $result (@$results) {
        my $fulldist = $result->{dist};
           $fulldist =~ s{^(?=(([A-Z])[A-Z]))}{$2/$1/};
        my $dist = CPAN::DistnameInfo->new($fulldist);

        for my $file (@{$result->{files}}) {
            print colored(["GREEN"], join("/", $dist->cpanid, $dist->distvname, $file->{file})), "\n";

            for my $match (@{$file->{results}}) {
                my $snippet = $match->{text};

                my ($start, $len) = @{$match->{match}};
                $len -= $start;

                # XXX TODO: Track down the grep.cpan.me api bug that causes
                # this.  An example that fails for me today:
                #
                #   cpangrep dist:App-Prefix file:Changes '^\s*\[.+?\]\s*$'
                #
                # -trs, 29 Jan 2014
                if (length $snippet < $start + $len) {
                    warn colored("API returned an out of bounds match; skipping! (use --debug to see details)", "RED"),
                         color("reset"), "\n";
                    if ($DEBUG) {
                        require Data::Dumper;
                        debug("snippet: «$snippet» (length ", length $snippet, ")");
                        debug("reported match starts at «$start», length «$len» (ends at «@{[$start+$len]}»)");
                        debug("raw match response: ", Data::Dumper::Dumper($match));
                    }
                    next;
                }

                substr($snippet, $start, $len) = colored(substr($snippet, $start, $len), "BOLD RED");

                if ($match->{line}) {