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