File Coverage

blib/lib/Getopt/App/Complete.pm
Criterion Covered Total %
statement 55 55 100.0
branch 17 18 94.4
condition 8 10 80.0
subroutine 11 11 100.0
pod 2 2 100.0
total 93 96 96.8


line stmt bran cond sub pod time code
1             package Getopt::App::Complete;
2 2     2   463 use feature qw(:5.16);
  2         5  
  2         154  
3 2     2   11 use strict;
  2         4  
  2         36  
4 2     2   9 use warnings;
  2         4  
  2         41  
5 2     2   9 use utf8;
  2         4  
  2         9  
6 2     2   46 use Cwd qw(abs_path);
  2         5  
  2         133  
7 2     2   17 use File::Basename qw(basename);
  2         4  
  2         204  
8 2     2   11 use Exporter qw(import);
  2         4  
  2         206  
9              
10             our @EXPORT_OK = qw(complete_reply generate_completion_script);
11              
12             require Getopt::App;
13 2     2   13 our $call_maybe = do { no warnings qw(once); $Getopt::App::call_maybe };
  2         4  
  2         832  
14             our $argv_index = 0;
15              
16             sub complete_reply {
17 10     10 1 17 my $app = shift;
18 10   100     80 my $subcommands = $app->$call_maybe('getopt_subcommands') || [];
19 10         276 my ($script, @argv) = split /\s+/, $ENV{COMP_LINE};
20              
21             # Recurse into subcommand
22 10 100 100     66 if ($argv[$argv_index] and $argv[$argv_index] =~ m!^\w! and @$subcommands) {
      66        
23 4         32 for my $subcommand (@$subcommands) {
24 15 100       34 next unless $argv[$argv_index] eq $subcommand->[0];
25 3         6 local $argv_index = $argv_index + 1;
26 3         21 return Getopt::App::_subcommand_run($app, $subcommand, [@argv[$argv_index - 1, $#argv]]);
27             }
28             }
29              
30             # List matching subcommands
31 7 100       65 my $got = substr($ENV{COMP_LINE}, 0, $ENV{COMP_POINT}) =~ m!(\S+)$! ? $1 : '';
32 7         20 for my $subcommand (@$subcommands) {
33 24 100       194 say $subcommand->[0] if index($subcommand->[0], $got) == 0;
34             }
35              
36             # List matching command line options
37 2     2   14 no warnings q(once);
  2         3  
  2         993  
38 7 50       24 for (@{$Getopt::App::OPTIONS || []}) {
  7         28  
39 21         46 my $opt = $_;
40 21         100 $opt =~ s!(=[si][@%]?|\!|\+|\s)(.*)!!;
41 21         71 ($opt) = sort { length $b <=> length $a } split /\|/, $opt; # use --version instead of -v
  3         16  
42 21 100       63 $opt = length($opt) == 1 ? "-$opt" : "--$opt";
43 21 100       52 next unless index($opt, $got) == 0;
44 13         261 say $opt;
45             }
46              
47 7         99 return 0;
48             }
49              
50             sub generate_completion_script {
51 4     4 1 9003 my $script_path = abs_path($0);
52 4         166 my $script_name = basename($0);
53 4 100 50     35 my $shell = ($ENV{SHELL} || 'bash') =~ m!\bzsh\b! ? 'zsh' : 'bash';
54              
55 4 100       10 if ($shell eq 'zsh') {
56 3         16 my $function = '_' . $script_name =~ s!\W!_!gr;
57 3         48 return <<"HERE";
58             $function() {
59             read -l; local l="\$REPLY";
60             read -ln; local p="\$REPLY";
61             reply=(\$(COMP_LINE="\$l" COMP_POINT="\$p" COMP_SHELL="zsh" $script_path));
62             };
63              
64             compctl -f -K $function $script_name;
65             HERE
66             }
67             else {
68 1         13 return "complete -o default -C $script_path $script_name;\n";
69             }
70             }
71              
72             1;
73              
74             =encoding utf8
75              
76             =head1 NAME
77              
78             Getopt::App::Complete - Add auto-completion to you Getopt::App script
79              
80             =head1 SYNOPSIS
81              
82             use Getopt::App -complete;
83              
84             run(
85             'h # Print help',
86             'completion-script # Print autocomplete script',
87             sub {
88             my ($app, @args) = @_;
89             return print generate_completion_script() if $app->{'completion-script'};
90             return print extract_usage() if $app->{h};
91             },
92             );
93              
94             =head1 DESCRIPTION
95              
96             L contains helper functions for adding auto-completion to
97             your L powered script.
98              
99             This module is currently EXPERIMENTAL.
100              
101             =head1 EXPORTED FUNCTIONS
102              
103             =head2 complete_reply
104              
105             $int = complete_reply($app_obj);
106              
107             This function is the default behaviour when L is called with
108             C and C set.
109              
110             This function will print completion options based on C and
111             C to STDOUT and is aware of subcommands.
112              
113             =head2 generate_completion_script
114              
115             $str = generate_completion_script();
116              
117             This function will detect if the C or C shell is in use and return
118             the appropriate initialization commands.
119              
120             =head1 SEE ALSO
121              
122             L
123              
124             =cut