Skip to content

Commit

Permalink
Switch back to a shell completion function for perl and perldoc
Browse files Browse the repository at this point in the history 
completions, using an external helper just for functions and modules
completions. This is overally slower, as our helper outputs all available
modules at once, rather than just one piece of namespace, but this is
more in line with other completions
  • Loading branch information
@guillomovitch
guillomovitch committed Nov 7, 2010
1 parent fd8ade0 commit 4254f3a
Show file tree
Hide file tree
Showing 2 changed files with 133 additions and 161 deletions.
201 changes: 42 additions & 159 deletions completions/helpers/perl
View file
Original file line number Diff line number Diff line change
@@ -1,103 +1,50 @@
#!/usr/bin/env perl
use strict;
use File::Spec::Functions qw( rel2abs catdir catfile no_upwards splitpath );
use Config;
use File::Spec::Functions;

sub uniq { my %seen; grep { not $seen{$_}++ } @_ }
my %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 print_modules_real {
my ($base, $dir, $word) = @_;

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;
}
# returns immediatly if the base doesn't match
return if $base && $base !~ /^\Q$word/;

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

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;
}
chdir($dir) or return;

# only add eventual prefix on first segment
if ($prefix && !@segment) {
@suggestion = map { $prefix . $_ } @suggestion;
# print each file
foreach my $file (glob('*.pm')) {
$file =~ s/\.pm$//;
my $module = $base . $file;
next if $module !~ /^\Q$word/;
next if $seen{$module}++;
print $module . "\n";
}

return @suggestion;
}

sub get_file_suggestions {
my ($path) = @_;

my $dir;
if ($path) {
(undef, $dir, undef) = splitpath($path);
$dir = '.' if !$dir;
} else {
$dir = '.';
# recurse in each subdirectory
foreach my $directory (grep { -d } glob('*')) {
my $subdir = $dir . '/' . $directory;
if ($directory =~ /^(?:[.\d]+|$Config{archname}|auto)$/) {
# exclude subdirectory name from base
print_modules_real(undef, $subdir, $word);
} else {
# add subdirectory name to base
print_modules_real($base . $directory . '::', $subdir, $word);
}
}

my $dh;
return unless opendir ($dh, $dir);
my @files = readdir($dh);
closedir $dh;

@files = map { catfile $dir, $_ } @files if $dir ne '.';

return filter($path, @files);
}

sub get_directory_suggestions {
my ($path, $prefix) = @_;

my @suggestions =
grep { -d $_}
get_file_suggestions($path);
sub print_modules {
my ($word) = @_;

if ($prefix) {
@suggestions = map { $prefix . $_ } @suggestions;
foreach my $directory (@INC) {
print_modules_real(undef, $directory, $word);
}

return @suggestions;
}

sub get_functions {
sub print_functions {
my ($word) = @_;

my $perlfunc;
for ( @INC, undef ) {
Expand All @@ -108,90 +55,26 @@ sub get_functions {

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+)/;
next unless /^=item (-?\w+)/;
my $function = $1;
next if $function !~ /^\Q$word/;
next if $seen{$function}++;
print $function . "\n";
}

return @functions;
}

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

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

return grep { /$pattern/ } @list;
if ($type eq 'functions') {
print_functions($word);
} elsif ($type eq 'modules') {
print_modules($word);
}

sub get_perldoc_suggestions {
my (@args) = @_;
my $cur = pop @args;
my $prev = pop @args;

if ($prev) {
if ($prev eq '-f') {
return filter(
$cur,
get_functions
);
}
}

if ($cur =~ /^-/) {
return filter(
$cur,
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($cur);
}
}

sub get_perl_suggestions {
my (@args) = @_;
my $cur = pop @args;
my $prev = pop @args;
my $prefix;

if ($cur =~ /^(-\S)(\S*)/) {
$prev = $1;
$cur = $2;
$prefix = $prev;
}

if ($prev) {
if ($prev eq '-I' || $prev eq '-x') {
return get_directory_suggestions($cur, $prefix);
}
if ($prev eq '-m' || $prev eq '-M') {
return get_package_suggestions($cur, $prefix);
}
}

if ($cur =~ /^-/) {
return filter(
$cur,
qw/
-C -s -T -u -U -W -X -h -v -V -c -w -d -D
-p -n -a -F -l -0 -I -m -M -P -S -x -i -e
/
);
} else {
return get_file_suggestions($cur);
}
}

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

print "$_\n" for
$cmd eq 'perl' ? get_perl_suggestions(@args) :
$cmd eq 'perldoc' ? get_perldoc_suggestions(@args) :
() ;

93 changes: 91 additions & 2 deletions completions/perl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,9 +2,98 @@

have perl &&
{
complete -C ${BASH_SOURCE[0]%/*}/helpers/perl -o nospace -o default perl
_perlmodules()
{
COMPREPLY=( $( compgen -P "$prefix" -W "$( ${BASH_SOURCE[0]%/*}/helpers/perl modules $cur )" -- "$cur" ) )
__ltrim_colon_completions "$1"
}

_perlfunctions()
{
COMPREPLY=( $( compgen -P "$prefix" -W "$( ${BASH_SOURCE[0]%/*}/helpers/perl functions $cur )" -- "$cur" ) )
}

_perl()
{
local cur prev prefix temp
local optPrefix optSuffix

COMPREPLY=()
_get_comp_words_by_ref -n : cur prev
prefix=""

# If option not followed by whitespace, reassign prev and cur
if [[ "$cur" == -?* ]]; then
temp=$cur
prev=${temp:0:2}
cur=${temp:2}
optPrefix=-P$prev
optSuffix=-S/
prefix=$prev
fi

complete -C ${BASH_SOURCE[0]%/*}/helpers/perl -o nospace -o default perldoc
# only handle module completion for now
case $prev in
-I|-x)
local IFS=$'\n'
_compopt_o_filenames
COMPREPLY=( $( compgen -d $optPrefix $optSuffix -- "$cur" ) )
return 0
;;
-m|-M)
_perlmodules "$cur"
return 0
;;
esac

if [[ "$cur" == -* ]]; then
COMPREPLY=( $( compgen -W '-C -s -T -u -U -W -X -h -v -V -c -w -d \
-D -p -n -a -F -l -0 -I -m -M -P -S -x -i -e ' -- "$cur" ) )
else
_filedir
fi
}
complete -F _perl -o nospace perl

_perldoc()
{
local cur prev prefix temp

COMPREPLY=()
_get_comp_words_by_ref -n : cur prev
prefix=""

# completing an option (may or may not be separated by a space)
if [[ "$cur" == -?* ]]; then
temp=$cur
prev=${temp:0:2}
cur=${temp:2}
prefix=$prev
fi

# complete builtin perl functions
case $prev in
-f)
_perlfunctions "$cur"
return 0
;;
esac

if [[ "$cur" == -* ]]; then
COMPREPLY=( $( compgen -W '-h -v -t -u -m -l -F -X -f -q' -- "$cur" ))
else
# return available modules (unless it is clearly a file)
if [[ "$cur" != */* ]]; then
_perlmodules "$cur"
COMPREPLY=( "${COMPREPLY[@]}" $( compgen -W \
'$( PAGER=/bin/cat man perl | \
sed -ne "/perl.*Perl overview/,/perlwin32/p" | \
awk "\$NF=2 { print \$1}" | command grep perl )' -- "$cur" ) )
fi
_filedir '@(pl|PL|pm|PM|pod|POD)'
fi
}
complete -F _perldoc -o bashdefault perldoc
}

# Local variables:
Expand Down

0 comments on commit 4254f3a

Please sign in to comment.