1package Bash::Completion::Plugins::Perldoc; 2{ 3 $Bash::Completion::Plugins::Perldoc::VERSION = '0.008'; 4} 5 6# ABSTRACT: complete perldoc command 7 8# for the part of the code that is heavily 9# inspired by Aristotle's code: 10# 11# Copyright (c) 2010 Aristotle Pagaltzis {{{ 12# 13# Permission is hereby granted, free of charge, to any person obtaining 14# a copy of this software and associated documentation files (the 15# "Software"), to deal in the Software without restriction, including 16# without limitation the rights to use, copy, modify, merge, publish, 17# distribute, sublicense, and/or sell copies of the Software, and to 18# permit persons to whom the Software is furnished to do so, subject to 19# the following conditions: 20# 21# The above copyright notice and this permission notice shall be 22# included in all copies or substantial portions of the Software. 23# 24# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 25# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 26# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 27# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 28# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 29# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 30# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE." 31# }}} 32 33use strict; 34use warnings; 35 36use parent 'Bash::Completion::Plugin'; 37 38use Bash::Completion::Utils 39 qw( command_in_path match_perl_modules prefix_match ); 40use File::Spec::Functions qw/ catfile rel2abs catdir splitpath no_upwards /; 41use List::MoreUtils qw/ apply uniq /; 42 43 44sub should_activate { 45 my @commands = ('perldoc'); 46 return [grep { command_in_path($_) } @commands]; 47} 48 49 50 51sub generate_bash_setup { return [qw( nospace default )] } 52 53 54 55sub complete { 56 my ($class, $req) = @_; 57 58 my @args = $req->args; 59 pop @args; # last is the word 60 61 my $function = @args && $args[-1] eq '-f' 62 ? \&get_function_suggestions 63 : \&get_package_suggestions 64 ; 65 66 $req->candidates( $function->( $req->word ) ); 67} 68 69sub slurp_dir { 70 opendir my $dir, shift or return; 71 no_upwards readdir $dir; 72} 73 74sub suggestion_from_name { 75 my ( $file_rx, $path, $name ) = @_; 76 return if not $name =~ /$file_rx/; 77 return $name.'::', $name.':: ' if -d catdir $path, $name; 78 return $1; 79} 80 81sub suggestions_from_path { 82 my ( $file_rx, $path ) = @_; 83 map { suggestion_from_name( $file_rx, $path, $_ ) } slurp_dir( $path ); 84} 85 86sub get_package_suggestions { 87 my ( $pkg ) = @_; 88 89 my @segment = split /::|:\z/, $pkg, -1; 90 my $file_rx = qr/\A(${\quotemeta pop @segment}\w*)(?:\.pm|\.pod)?\z/; 91 92 my $home = rel2abs $ENV{'HOME'}; 93 my $cwd = rel2abs do { require Cwd; Cwd::cwd() }; 94 95 my @suggestion = 96 uniq 97 map { ( my $x = $_ ) =~ s/::\s$/::/; $x } 98 map { suggestions_from_path $file_rx, $_ } 99 uniq 100 map { catdir $_, @segment } 101 grep { $home ne $_ and $cwd ne $_ } 102 map { $_, ( catdir $_, 'pod' ) } 103 map { rel2abs $_ } 104 @INC; 105 106 # fixups 107 if ( $pkg eq '' ) { 108 my $total = @suggestion; 109 @suggestion = grep { not /^perl/ } @suggestion; 110 my $num_hidden = $total - @suggestion; 111 push @suggestion, "perl* ($num_hidden hidden)" if $num_hidden; 112 } 113 elsif ( $pkg =~ /(?<!:):\z/ ) { 114 @suggestion = map { ":$_" } @suggestion; 115 } 116 117 return @suggestion; 118} 119 120sub get_function_suggestions { 121 my ( $func ) = @_; 122 123 my $perlfunc; 124 for ( @INC, undef ) { 125 return if not defined; 126 $perlfunc = catfile( $_, qw( pod perlfunc.pod ) ); 127 last if -r $perlfunc; 128 } 129 130 open my $fh, '<', $perlfunc or return; 131 132 my @suggestion; 133 my $nest_level = -1; 134 while ( <$fh> ) { 135 next if 1 .. /^=head2 Alphabetical Listing of Perl Functions$/; 136 ++$nest_level if /^=over/; 137 --$nest_level if /^=back/; 138 next if $nest_level; 139 push @suggestion, /^=item (-?\w+)/; 140 } 141 142 my $func_rx = qr/\A${\quotemeta $func}/; 143 144 return grep { /$func_rx/ } @suggestion; 145} 146 1471; 148 149 150 151=pod 152 153=head1 NAME 154 155Bash::Completion::Plugins::Perldoc - complete perldoc command 156 157=head1 VERSION 158 159version 0.008 160 161=head1 SYNOPSIS 162 163 ## not to be used directly 164 165=head1 DESCRIPTION 166 167A plugin for the C<perldoc> command. Completes module names, and 168function names if the V<-f> parameter is used. 169 170Heavily based on Aristotle's perldoc-complete 171 172=head1 METHODS 173 174=head2 should_activate 175 176Activate this C<Bash::Completion::Plugins::Perldoc> plugin if we can 177find the C<perldoc> command. 178 179=head2 generate_bash_setup 180 181Make sure we use bash C<complete> options C<nospace> and C<default>. 182 183=head2 complete 184 185Completion logic for C<perldoc>. Completes Perl modules only for now. 186 187=head1 SEE ALSO 188 189=over 190 191=item Aristotle's perldoc-complete - https://github.com/ap/perldoc-complete 192 193=back 194 195=head1 AUTHOR 196 197Pedro Melo <melo@cpan.org> 198 199=head1 COPYRIGHT AND LICENSE 200 201This software is Copyright (c) 2011 by Pedro Melo. 202 203This is free software, licensed under: 204 205 The Artistic License 2.0 (GPL Compatible) 206 207=cut 208 209 210__END__ 211 212