bash-completion/completions/helpers/perldoc

#!/usr/bin/env perl
use strict;
use File::Spec::Functions qw( rel2abs catdir catfile no_upwards );

sub uniq { my %seen; grep { not $seen{$_}++ } @_ }

sub get_command_line {
    my $comp = substr $ENV{'COMP_LINE'}, 0, $ENV{'COMP_POINT'};
    return split /[ \t]+/, $comp, -1; # if not good enough, use Text::ParseWords
}

sub slurp_dir {
    opendir my $dir, shift or return;
    no_upwards readdir $dir;
}

sub suggestion_from_name {
    my ( $file_rx, $path, $name ) = @_;
    return if not $name =~ /$file_rx/;
    return $name.'::' if -d catdir $path, $name;
    return $1;
}

sub suggestions_from_path {
    my ( $file_rx, $path ) = @_;
    map { suggestion_from_name $file_rx, $path, $_ } slurp_dir $path;
}

sub get_package_suggestions {
    my ( $pkg ) = @_;

    my @segment = split /::|:\z/, $pkg, -1;
    my $file_rx = qr/\A(${\quotemeta pop @segment}\w*)(?:\.pm|\.pod)?\z/;

    my $home = rel2abs $ENV{'HOME'};
    my $cwd = rel2abs do { require Cwd; Cwd::cwd() };

    my @suggestion =
        map { suggestions_from_path $file_rx, $_ }
        uniq map { catdir $_, @segment }
        grep { $home ne $_ and $cwd ne $_ }
        map { $_, ( catdir $_, 'pod' ) }
        map { rel2abs $_ }
        @INC;

    # fixups
    if ( $pkg eq '' ) {
        my $total = @suggestion;
        @suggestion = grep { not /^perl/ } @suggestion;
        my $num_hidden = $total - @suggestion;
        push @suggestion, "perl* ($num_hidden hidden)" if $num_hidden;
    }
    elsif ( $pkg =~ /(?<!:):\z/ ) {
        @suggestion = map { ":$_" } @suggestion;
    }

    return @suggestion;
}

sub get_function_suggestions {
    my ( $func ) = @_;

    my $perlfunc;
    for ( @INC, undef ) {
        return if not defined;
        $perlfunc = catfile $_, qw( pod perlfunc.pod );
        last if -r $perlfunc;
    }

    open my $fh, '<', $perlfunc or return;

    my @suggestion;
    my $nest_level = -1;
    while ( <$fh> ) {
        next if 1 .. /^=head2 Alphabetical Listing of Perl Functions$/;
        ++$nest_level if /^=over/;
        --$nest_level if /^=back/;
        next if $nest_level;
        push @suggestion, /^=item (-?\w+)/;
    }

    my $func_rx = qr/\A${\quotemeta $func}/;

    return grep { /$func_rx/ } @suggestion;
}

my ( $cmd, @arg ) = get_command_line();
my $word = pop @arg;

print "$_\n" for ( @arg and @arg[-1] eq '-f' )
    ? get_function_suggestions( $word )
    : get_package_suggestions( $word );