add pure perl perldoc completion helper

CHANGES

@@ -1,4 +1,7 @@
 bash-completion (2.x)
+  [ Guillaume Rousse ]
+  * added pure-perl perldoc completion helper, using work from Aristotle 
+    Pagaltzis (pagaltzis@gmx.de)
 
   [ David Paleino ]
   * Fixed "service" completion, thanks to John Hedges (Debian: #586210)

configure.ac

@@ -2,5 +2,6 @@ AC_PREREQ([2.59])
 AC_INIT([bash-completion], [1.99])
 AM_INIT_AUTOMAKE([foreign dejagnu dist-bzip2 -Wall -Werror])
 AC_SUBST(bashcompdir, $sysconfdir/bash_completion.d)
-AC_CONFIG_FILES([Makefile contrib/Makefile test/Makefile])
+AC_SUBST(helpersdir, $datadir/bash-completion/helpers)
+AC_CONFIG_FILES([Makefile contrib/Makefile helpers/Makefile test/Makefile])
 AC_OUTPUT

contrib/perl

@@ -1,127 +0,0 @@
-# bash completion for perl
-
-have perl &&
-{
-_perlmodules()
-{
-    COMPREPLY=( $( compgen -P "$prefix" -W "$( perl -e 'sub mods { my ($base,$dir)=@_; return if  $base !~ /^\Q$ENV{cur}/; chdir($dir) or return; for (glob(q[*.pm])) {s/\.pm$//; print qq[$base$_\n]}; mods(/^(?:[.\d]+|$Config{archname}-$Config{osname}|auto)$/ ? undef : qq[${base}${_}::],qq[$dir/$_]) for grep {-d} glob(q[*]); } mods(undef,$_) for @INC;' )" -- "$cur" ) )
-    __ltrim_colon_completions "$1"
-}
-
-_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
-
-    # only handle module completion for now
-    case $prev in
-        -I|-x)
-            local IFS=$'\t\n'
-            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 -o filenames 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)
-            COMPREPLY=( $( compgen -W 'chomp chop chr crypt hex index lc \
-                lcfirst length oct ord pack q qq reverse rindex sprintf \
-                substr tr uc ucfirst y m pos quotemeta s split study qr abs \
-                atan2 cos exp hex int log oct rand sin sqrt srand pop push \
-                shift splice unshift grep join map qw reverse sort unpack \
-                delete each exists keys values binmode close closedir \
-                dbmclose dbmopen die eof fileno flock format getc print \
-                printf read readdir rewinddir say seek seekdir select syscall \
-                sysread sysseek syswrite tell telldir truncate warn write \
-                pack read syscall sysread syswrite unpack vec -X chdir chmod \
-                chown chroot fcntl glob ioctl link lstat mkdir open opendir \
-                readlink rename rmdir stat symlink umask unlink utime caller \
-                continue do dump eval exit goto last next redo return \
-                sub wantarray break caller import local my our state package \
-                use defined formline reset scalar undef \
-                alarm exec fork getpgrp getppid getpriority kill pipe qx \
-                setpgrp setpriority sleep system times wait waitpid \
-                import no package require use bless dbmclose dbmopen package \
-                ref tie tied untie use accept bind connect getpeername \
-                getsockname getsockopt listen recv send setsockopt shutdown \
-                socket socketpair msgctl msgget msgrcv msgsnd semctl semget \
-                semop shmctl shmget shmread shmwrite endgrent endhostent \
-                endnetent endpwent getgrent getgrgid getgrnam getlogin \
-                getpwent getpwnam getpwuid setgrent setpwent endprotoent \
-                endservent gethostbyaddr gethostbyname gethostent \
-                getnetbyaddr getnetbyname getnetent getprotobyname \
-                getprotobynumber getprotoent getservbyname getservbyport \
-                getservent sethostent setnetent setprotoent setservent \
-                gmtime localtime time times lock' -- "$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:
-# mode: shell-script
-# sh-basic-offset: 4
-# sh-indent-comment: t
-# indent-tabs-mode: nil
-# End:
-# ex: ts=4 sw=4 et filetype=sh

contrib/perl.in

@@ -0,0 +1,61 @@
+# bash completion for perl
+
+have perl &&
+{
+_perlmodules()
+{
+    COMPREPLY=( $( compgen -P "$prefix" -W "$( perl -e 'sub mods { my ($base,$dir)=@_; return if  $base !~ /^\Q$ENV{cur}/; chdir($dir) or return; for (glob(q[*.pm])) {s/\.pm$//; print qq[$base$_\n]}; mods(/^(?:[.\d]+|$Config{archname}-$Config{osname}|auto)$/ ? undef : qq[${base}${_}::],qq[$dir/$_]) for grep {-d} glob(q[*]); } mods(undef,$_) for @INC;' )" -- "$cur" ) )
+    __ltrim_colon_completions "$1"
+}
+
+_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
+
+    # only handle module completion for now
+    case $prev in
+        -I|-x)
+            local IFS=$'\t\n'
+            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 -o filenames perl
+
+complete -C @helpersdir@/perldoc -o nospace -o default perldoc
+}
+
+# Local variables:
+# mode: shell-script
+# sh-basic-offset: 4
+# sh-indent-comment: t
+# indent-tabs-mode: nil
+# End:
+# ex: ts=4 sw=4 et filetype=sh

helpers/Makefile.am

@@ -0,0 +1,3 @@
+helpers_SCRIPTS = perldoc
+
+EXTRA_DIST = $(helpers_SCRIPTS)

helpers/perldoc

@@ -0,0 +1,102 @@
+#!/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;
+}
+
+sub usage {
+	die map "\n$_\n", (
+		"To use, issue the following command in bash:",
+		"\tcomplete -C perldoc-complete -o nospace -o default perldoc",
+		"You probably want to put that line in your ~/.bashrc file.\n",
+	);
+}
+
+usage() if not exists $ENV{'COMP_LINE'};
+
+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 );