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_functions {

    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 @functions;
    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 @functions, /^=item (-?\w+)/;
    }

    return @functions;
}

sub filter {
    my ($word, @list) = @_;

    my $pattern = qr/\A${\quotemeta $word}/;

    return grep { /$pattern/ } @list;
}

sub get_suggestions {
    my (@args) = @_;
    my $word = pop @args;

    if (@args) {
        if ($args[-1] eq '-f') {
            return filter(
                $word,
                get_functions
            );
        }
    }

    if ($word =~ /^-/) {
        return filter(
            $word,
            qw/-h -D -t -u -m -l -F -i -v -V -T -r -d -o -M -w -n -X -L/
        );

    } else {
        return get_package_suggestions($word);
    }
}

my ($cmd, @args) = get_command_line();

print "$_\n" for get_suggestions(@args);