File Coverage

blib/lib/Getopt/Complete/Options.pm
Criterion Covered Total %
statement 51 162 31.4
branch 11 70 15.7
condition 4 42 9.5
subroutine 9 16 56.2
pod 0 9 0.0
total 75 299 25.0


line stmt bran cond sub pod time code
1             package Getopt::Complete::Options;
2              
3 2     2   15 use strict;
  2         5  
  2         72  
4 2     2   10 use warnings;
  2         5  
  2         80  
5              
6             our $VERSION = $Getopt::Complete::VERSION;
7              
8 2     2   3090 use IPC::Open2;
  2         12566  
  2         144  
9 2     2   2283 use Data::Dumper;
  2         18728  
  2         166  
10 2     2   2347 use Getopt::Complete::LazyOptions;
  2         5  
  2         5966  
11              
12             sub new {
13 1     1 0 13 my $class = shift;
14 1         8 my $self = bless {
15             sub_commands => [],
16             option_specs => {},
17             completion_handlers => {},
18             parse_errors => undef,
19             }, $class;
20              
21             # process the params into normalized completion handlers
22             # if there are problems, the ->errors method will return a list.
23 1         6 $self->_init(@_);
24 1         10 return $self;
25             }
26              
27             sub sub_commands {
28 0     0 0 0 return @{ shift->{sub_commands} };
  0         0  
29             }
30              
31             sub option_names {
32 0     0 0 0 return keys %{ shift->{completion_handlers} };
  0         0  
33             }
34              
35             sub option_specs {
36 1 50   1 0 6 Carp::confess("Bad params") if @_ > 1;
37 1         1 my $self = shift;
38 1         2 my @specs;
39 1         2 for my $key (keys %{ $self->{option_specs} }) {
  1         6  
40 1 50       5 next if $key eq '<>';
41 1         2 my $value = $self->{option_specs}{$key};
42 1         4 push @specs, $key . $value;
43             }
44 1         7 return @specs;
45             }
46              
47             sub option_spec {
48 0     0 0 0 my $self = shift;
49 0         0 my $name = shift;
50 0 0       0 Carp::confess("Bad params") if not defined $name;
51 0         0 return $self->{option_specs}{$name};
52             }
53              
54             sub has_option {
55 0     0 0 0 my $self = shift;
56 0         0 my $name = shift;
57 0         0 return exists $self->{completion_handlers}{$name};
58             }
59              
60             sub completion_handler {
61 2     2 0 3 my $self = shift;
62 2         3 my $name = shift;
63 2 50       6 Carp::confess("Bad params") if not defined $name;
64 2         9 return $self->{completion_handlers}{$name};
65             }
66              
67             sub _init {
68 1     1   1 my $self = shift;
69            
70 1         7 my $completion_handlers = $self->{completion_handlers} = {};
71 1         2 my $option_specs = $self->{option_specs} = {};
72              
73 1         2 my @parse_errors;
74 1         6 while (my $key = shift @_) {
75 1         2 my $handler = shift @_;
76            
77 1         10 my ($name,$spec) = ($key =~ /^([\w|-|\>][\w|-]*|\<\>|)(\W.*|)/);
78 1 50       6 if (not defined $name) {
79 0         0 push @parse_errors, __PACKAGE__ . " is unable to parse '$key' from spec!";
80 0         0 next;
81             }
82 1 50 33     7 if ($handler and not ref $handler) {
83 0         0 my $code;
84 0 0       0 if ($handler =~ /::/) {
85             # fully qualified
86 0         0 eval {
87 0         0 $code = \&{ $handler };
  0         0  
88             };
89 0 0       0 unless (ref($code)) {
90 0         0 push @parse_errors, __PACKAGE__ . " $key! references callback $handler which is not found! Did you use its module first?!";
91             }
92             }
93             else {
94 0         0 $code = Getopt::Complete::Compgen->can($handler);
95 0 0       0 unless (ref($code)) {
96 0         0 push @parse_errors, __PACKAGE__ . " $key! references builtin $handler which is not found! Select from:"
97 0         0 . join(", ", map { my $short = substr($_,0,1); "$_($short)" } @Getopt::Complete::Compgen::builtins);
  0         0  
98             }
99             }
100 0 0       0 if (ref($code)){
101 0         0 $handler = $code;
102             }
103             }
104 1 50       5 if (substr($name,0,1) eq '>') {
105             # a "sub-command": make a sub-options tree, which may happen recursively
106 0         0 my $word = substr($name,1);
107 0 0 0     0 if (ref($handler) eq 'ARRAY') {
    0          
108 0         0 $handler = Getopt::Complete::Options->new(@$handler);
109             }
110             elsif (ref($handler) eq 'CODE' or ref($handler) eq 'SCALAR') {
111             # be lazy about actually resolving this
112 0         0 $handler = Getopt::Complete::LazyOptions->new($handler);
113             }
114             else {
115 0         0 die "expected arrayref or code for $name value!";
116             }
117 0   0     0 $handler->{command} = ($self->{command} || '') . " " . $word;
118 0         0 $completion_handlers->{$name} = $handler;
119 0         0 push @{ $self->{sub_commands} }, $word;
  0         0  
120 0         0 next;
121             }
122              
123 1         2 $completion_handlers->{$name} = $handler;
124 1 50       3 if ($name eq '<>') {
125 0         0 next;
126             }
127 1 50       3 if ($name eq '-') {
128 0 0 0     0 if ($spec and $spec ne '!') {
129 0         0 push @parse_errors, __PACKAGE__ . " $key errors: $name is implicitly stand-alone!";
130             }
131 0   0     0 $spec ||= '!';
132             }
133 1   50     2 $spec ||= '=s';
134 1         2 $option_specs->{$name} = $spec;
135 1 50 33     10 if ($spec =~ /[\!\+]/ and defined $completion_handlers->{$key}) {
136 0         0 push @parse_errors, __PACKAGE__ . " error on option $key: ! and + expect an undef completion list, since they do not have values!";
137 0         0 next;
138             }
139 1 50 33     7 if (ref($completion_handlers->{$key}) eq 'ARRAY' and @{ $completion_handlers->{$key} } == 0) {
  0         0  
140 0         0 push @parse_errors, __PACKAGE__ . " error on option $key: an empty arrayref will never be valid!";
141             }
142             }
143            
144 1         3 $self->{parse_errors} = \@parse_errors;
145            
146 1 50       4 return (@parse_errors ? () : 1);
147             }
148              
149             sub handle_shell_completion {
150 0     0 0   my $self = shift;
151 0 0         if ($ENV{COMP_CWORD}) {
152 0           my ($command,$current,$previous,$other) = $self->parse_completion_request(\@ARGV,$ENV{COMP_CWORD});
153 0 0         unless ($command) {
154             # parse error
155             # this typically only happens when there are mismatched quotes, which means something you can't complete anyway
156             # don't complete anything...
157 0           exit;
158             }
159 0           my $args = Getopt::Complete::Args->new(options => $self, argv => $other);
160 0           my @matches;
161             my @printable_matches;
162 0 0         unless ($args->errors) {
163 0           @matches = $args->resolve_possible_completions($command,$current,$previous);
164 0           @printable_matches = $args->translate_completions_for_shell_display($current, @matches);
165             }
166 0           print join("\n",@printable_matches),"\n";
167 0           exit;
168             }
169 0           return 1;
170             }
171              
172             sub _expand_token {
173 0     0     my $self = shift;
174 0           my $token = shift;
175              
176 0 0         return '' unless $token;
177              
178 0           my ($reader, $writer);
179 0           my $pid = open2($reader,$writer,'bash 2>/dev/null');
180 0 0         return unless $pid;
181 0           print $writer "echo $token";
182 0           close $writer;
183 0           my $result = join("",<$reader>);
184 0           chomp $result;
185 0   0       return $result || $token;
186             }
187              
188             sub parse_completion_request {
189 0     0 0   my $self = shift;
190 0           my ($comp_words, $comp_cword) = @_;
191              
192 0           @$comp_words = map($self->_expand_token($_), @$comp_words);
193              
194 0           my @left = @$comp_words[0..$comp_cword];
195 0           my $want_new_word = (!defined $left[-1]); #if starting new word, last value will be undef
196 0 0         my $left = join(" ", map(defined($_) ? $_ : '', @left)); #want an extra space at end if $want_new_word
197 0 0         if($want_new_word) {
198 0           pop @left;
199             }
200             # find options for last sub-command if it has a completion handler
201             # skipping first command but old code didn't but it also never seemed to trigger before
202 0           my @sub_cmds = @left[1..$#left];
203 0   0       while (@sub_cmds and my $delegate = $self->completion_handler('>' . $sub_cmds[0])) {
204 0           shift @sub_cmds;
205 0           $self = $delegate;
206             }
207              
208 0           my @right = @$comp_words[($comp_cword+1)..$#$comp_words];
209 0           my $right = join(" ", @right);
210              
211 0 0         unless (@left) {
212             # parse error
213 0           return;
214             }
215            
216 0           my $command = shift @left;
217 0           my $current;
218 0 0 0       if (substr($left, -1) ne ' ' || substr($left, -2) eq '\ ') {
219             # we're at the end of the final word in the @left list, and are trying to complete it
220 0           $current = pop @left;
221             }
222             else {
223 0           $current = '';
224             }
225 0           $left =~ s/\\ / /g;
226 0 0 0       my $previous = ( (@left and $left[-1] =~ /^-{1,2}/ and not $left[-1] =~ /^-{1,2}[\w\-]+\=/) ? (pop @left) : ()) ;
227             # TODO: this might be a good spot to make sure we don't complete a new sub-command
228 0           my @other_options = (@left,@right);
229              
230             # it's hard to spot the case in which the previous word is "boolean", and has no value specified
231 0 0         if ($previous) {
232 0           my ($name) = ($previous =~ /^-+(.*)/);
233 0           my $spec = $self->option_spec($name);
234 0 0 0       if ($spec and $spec =~ /[\!\+]/) {
    0          
235 0           push @other_options, $previous;
236 0           $previous = undef;
237             }
238             elsif ($name =~ /no-(.*)/) {
239             # Handle a case of an option which natively starts with "--no-"
240             # and is set to boolean. There is one of everything in this world.
241 0           $name =~ s/^no-//;
242 0           $spec = $self->option_spec($name);
243 0 0 0       if ($spec and $spec =~ /[\!\+]/) {
244 0           push @other_options, $previous;
245 0           $previous = undef;
246             }
247             }
248            
249             }
250              
251 0           my $quote;
252 0 0         if ($current =~ /^([\'\"])/) {
253 0           $quote = $1;
254 0           $current = substr($current,1);
255 0 0 0       if (substr($current,-1,1) eq $quote and not substr($current,-2,1) eq '\\') {
256 0           $current = substr($current,0,length($current)-1);
257             };
258             }
259 0           return ($command,$current,$previous,\@other_options, $quote);
260             }
261              
262             1;
263              
264             =pod
265              
266             =head1 NAME
267              
268             Getopt::Complete::Options - a command-line options specification
269              
270             =head1 VERSION
271              
272             This document describes Getopt::Complete 0.26
273              
274             =head1 SYNOPSIS
275              
276             This is used internally by Getopt::Complete during compile.
277              
278             my $opts = Getopt::Complete::Options->new(
279             'myfile=s' => 'f',
280             'mydir=s@' => 'd',
281             '<>' => ['one','two','three']
282             );
283              
284             $opts->option_names;
285             # myfile mydir
286            
287             $opts->option_spec("mydir")
288             # '=s@'
289            
290             $opts->option_handler("myfile")
291             # 'f'
292            
293             $opts->option_handler("<>")
294             # ['one','two','three'];
295              
296             $opts->handle_shell_completion;
297             # if it detects it is talking to the shell completer, it will respond and then exit
298              
299             # this method is used by the above, then makes a Getopt::Complete::Args.
300             ($text_typed,$option_name,$remainder_of_argv) = $self->parse_completion_request($comp_words,$comp_cword);
301              
302             =head1 DESCRIPTION
303              
304             Objects of this class are used to construct a Getop::Complete::Args from a list of
305             command-line arguments. It specifies what options are available to the command
306             line, helping to direct the parser.
307              
308             It also specifies what values are valid for those options, and provides an API
309             for access by the shell to do tab-completion.
310              
311             The valid values list is also used by Getopt::Complete::Args to validate its
312             option values, and produce the error list it generates.
313              
314             =head1 SEE ALSO
315              
316             L, L, L
317              
318             =head1 COPYRIGHT
319              
320             Copyright 2010 Scott Smith and Washington University School of Medicine
321              
322             =head1 AUTHORS
323              
324             Scott Smith (sakoht at cpan .org)
325              
326             =head1 LICENSE
327              
328             This program is free software; you can redistribute it and/or modify it under
329             the same terms as Perl itself.
330              
331             The full text of the license can be found in the LICENSE file included with this
332             module.
333              
334             =cut
335