File Coverage

blib/lib/Getopt/Complete/Args.pm
Criterion Covered Total %
statement 63 236 26.6
branch 15 122 12.3
condition 2 47 4.2
subroutine 13 23 56.5
pod 5 11 45.4
total 98 439 22.3


line stmt bran cond sub pod time code
1             package Getopt::Complete::Args;
2              
3 2     2   11 use strict;
  2         4  
  2         49  
4 2     2   10 use warnings;
  2         2  
  2         69  
5              
6             our $VERSION = $Getopt::Complete::VERSION;
7              
8 2     2   1140 use Getopt::Long;
  2         18447  
  2         9  
9 2     2   271 use Scalar::Util;
  2         4  
  2         477  
10              
11             sub new {
12 1     1 0 2 my $class = shift;
13 1         4 my $self = bless {
14             'options' => undef,
15             'values' => {},
16             'errors' => [],
17             'argv' => undef,
18             @_,
19             }, $class;
20              
21 1 50       5 unless ($self->{argv}) {
22 0         0 die "No argv passed to " . __PACKAGE__ . " constructor!";
23             }
24            
25 1         2 my $options = $self->{options};
26              
27 1 50       3 unless ($options) {
28 0         0 die "No options passed to " . __PACKAGE__ . " constructor!";
29             }
30              
31 1         3 my $type = ref($options);
32 1 50       7 if (not $type) {
    50          
    50          
    50          
33 0         0 die "Expected Getopt::Complete::Options, or a constructor ARRAY/HASH for ''options''. Got: $type $options.";
34             }
35             elsif ($type eq 'ARRAY') {
36 0         0 $self->{options} = Getopt::Complete::Options(@$options);
37             }
38             elsif ($type eq 'HASH') {
39 0         0 $self->{options} = Getopt::Complete::Options(%$options);
40             }
41             elsif (Scalar::Util::blessed($options)) {
42 1 50       15 if (not $options->isa("Getopt::Complete::Options")) {
43 0         0 die "Expected Getopt::Complete::Options, or a constructor ARRAY/HASH for ''options''. Got: $options.";
44             }
45             }
46             else {
47 0         0 die "Expected Getopt::Complete::Options, or a constructor ARRAY/HASH for ''options''. Got reference $options.";
48             }
49            
50 1         4 $self->_init();
51              
52 1         3 return $self;
53             }
54              
55             sub options {
56 4     4 1 14 shift->{options};
57             }
58              
59             sub argv {
60 0     0 1 0 @{ shift->{argv} };
  0         0  
61             }
62              
63             sub errors {
64 1     1 0 3 @{ shift->{errors} }
  1         3  
65             }
66              
67             for my $method (qw/sub_commands option_names option_specs option_spec completion_handler/) {
68 2     2   13 no strict 'refs';
  2         3  
  2         2179  
69             *{$method} = sub {
70 0     0   0 my $self = shift;
71 0         0 my $options = $self->options;
72 0         0 return $options->$method(@_);
73             }
74             }
75              
76             sub has_value {
77 0     0 0 0 my $self = shift;
78 0         0 my $name = shift;
79 0         0 return exists $self->{'values'}{$name};
80             }
81              
82             sub value {
83 0     0 1 0 my $self = shift;
84 0         0 my $name = shift;
85 0         0 my $value = $self->{'values'}{$name};
86 0         0 return $value;
87             }
88              
89             sub bare_args {
90 0     0 1 0 my $self = shift;
91 0         0 my $name = shift;
92 0         0 my $value = $self->{'values'}{'<>'};
93 0         0 return $value;
94             }
95              
96             sub parent_sub_commands {
97 0     0 1 0 my $self = shift;
98 0         0 my $name = shift;
99 0         0 my $value = $self->{'values'}{'>'};
100 0         0 return $value;
101             }
102              
103             sub _init {
104 1     1   1 my $self = shift;
105            
106             # as long as the first word is a valid sub-command, drill down to the subordinate options list,
107             # and also shift the args into a special buffer
108             # (if you have sub-commands AND bare arguments, and the arg is a valid sub-command ...don't do that
109 1         1 local @ARGV = @{ $self->{argv} };
  1         3  
110 1         2 my @sub_command_path;
111 1   33     3 while (@ARGV and my $delegate = $self->options->completion_handler('>' . $ARGV[0])) {
112 0         0 push @sub_command_path, shift @ARGV;
113 0         0 $self->{options} = $delegate;
114             }
115              
116 1         2 my %values;
117             my @errors;
118              
119 1         1 do {
120 1     1   6 local $SIG{__WARN__} = sub { push @errors, @_ };
  1         220  
121 1         3 my $retval = Getopt::Long::GetOptions(\%values,$self->options->option_specs);
122 1 50 33     18 if (!$retval and @errors == 0) {
123 0         0 push @errors, "unknown error processing arguments!";
124             }
125 1 50       30 if ($ENV{COMP_LINE}) {
126             # we want to allow unknown option if the user puts them in, we just
127             # didn't help complete it
128 0         0 @errors = grep { $_ !~ /^Unknown option:/ } @errors;
  0         0  
129             }
130             };
131              
132 1 50       4 if (@ARGV) {
133 0 0       0 if ($self->options->has_option('<>')) {
134 0   0     0 my $a = $values{'<>'} ||= [];
135 0         0 push @$a, @ARGV;
136             }
137             else {
138             # in order to allow bare-args we only block unexpected arguments
139             # for commands with sub-commands
140 0 0       0 if ( $self->sub_commands ) {
141 0         0 for my $arg (@ARGV) {
142 0         0 push @errors, "unexpected sub-command: $arg";
143             }
144             }
145             }
146             }
147              
148 1 50       2 if (@sub_command_path) {
149 0         0 $values{'>'} = \@sub_command_path;
150             }
151              
152 1         3 %{ $self->{'values'} } = %values;
  1         2  
153            
154 1 50       2 if (my @more_errors = $self->_validate_values()) {
155 0         0 push @errors, @more_errors;
156             }
157              
158 1         1 @{ $self->{'errors'} } = @errors;
  1         2  
159              
160 1 50       5 return (@errors ? () : 1);
161             }
162              
163              
164             sub _validate_values {
165 1     1   2 my $self = shift;
166              
167 1         1 my @failed;
168 1         2 for my $key (keys %{ $self->options->{completion_handlers} }) {
  1         2  
169 1         5 my $completion_handler= $self->options->completion_handler($key);
170 1         2 my $completions;
171 1 50       4 if (ref($completion_handler) eq 'CODE') {
    50          
172             # defer setting $completions
173             }
174             elsif (ref($completion_handler) eq 'ARRAY') {
175 0         0 $completions = $completion_handler;
176 0         0 $completion_handler = undef;
177             }
178             else {
179             #warn "unexpected completion specification for $key: $completion_handler???";
180 1         2 next;
181             }
182              
183 0         0 my ($name,$spec) = ($key =~ /^([\w|-|\>][\w|-]*|\<\>|)(\W.*|)/);
184             #my ($dashes,$name,$spec) = ($key =~ /^(\-*?)([\w|-]*|\<\>|)(\W.*|)/);
185 0 0       0 if (not defined $name) {
186 0         0 print STDERR "key $key is unparsable in " . __PACKAGE__ . " spec inside of $0 !!!";
187 0         0 next;
188             }
189 0 0 0     0 if ($name eq '<>' and not $spec) {
190 0         0 $spec = '=s@';
191             }
192              
193 0         0 my $value_returned = $self->value($name);
194 0 0       0 my @values = (ref($value_returned) ? @$value_returned : $value_returned);
195            
196 0         0 my $all_valid_values;
197 0         0 for my $value (@values) {
198 0 0       0 next if not defined $value;
199 0 0       0 next if not defined $completions;
200 0         0 my @valid_values_shown_in_message;
201 0 0       0 if ($completion_handler) {
202             # we pass in the value as the "completeme" word, so that the callback
203             # can be as optimal as possible in determining if that value is acceptable.
204 0         0 $completions = $completion_handler->(undef,$value,$key,$self->{'values'});
205 0 0 0     0 if (not defined $completions or not ref($completions) eq 'ARRAY' or @$completions == 0) {
      0        
206             # if not, we give it the chance to give us the full list of options
207 0         0 $completions = $completion_handler->(undef,undef,$key,$self->{'values'});
208             }
209 0 0       0 unless (ref($completions) eq 'ARRAY') {
210 0         0 warn "unexpected completion specification for $key: $completions???";
211 0         0 next;
212             }
213             }
214 0         0 my @valid_values = @$completions;
215 0         0 @valid_values_shown_in_message = @valid_values;
216            
217 0 0       0 if (ref($valid_values[-1]) eq 'ARRAY') {
218 0         0 push @valid_values, @{ pop(@valid_values) };
  0         0  
219 0         0 pop @valid_values_shown_in_message;
220             }
221 0 0       0 unless (grep { $_ eq $value } map { /(.*)\t$/ ? $1 : $_ } @valid_values) {
  0 0       0  
  0         0  
222 0 0       0 my $msg = ($key eq '<>' ? "invalid argument $value." : "$key has invalid value $value.");
223 0 0       0 if (@valid_values_shown_in_message) {
224 0 0       0 $msg .= " Select from: " . join(", ", map { /^(.+)\t$/ ? $1 : $_ } @valid_values_shown_in_message);
  0         0  
225             }
226 0         0 push @failed, $msg;
227             }
228             }
229             }
230 1         3 return @failed;
231             }
232              
233             sub resolve_possible_completions {
234 0     0 0   my ($self, $command, $current, $previous) = @_;
235              
236 0           my $all = $self->{values};
237              
238 0 0         $previous = '' if not defined $previous;
239              
240 0           my @possibilities;
241              
242 0           my ($dashes,$resolve_values_for_option_name) = ($previous =~ /^(-{1,2})(.*)/);
243 0           my $is_option_name = 0;
244 0 0         if (not length $previous) {
245             # no specific option is before this: a sub-command, a bare argument, or an option name
246 0 0 0       if ($current =~ /^(-+)/
      0        
      0        
247             or (
248             $current eq ''
249             and not ($self->sub_commands)
250             and not ($self->options->has_option('<>'))
251             )
252             ) {
253             # the incomplete word is an option name
254 0           $is_option_name = 1;
255              
256 0           my @args = $self->option_names;
257            
258             # We only show the negative version of boolean options
259             # when the user already has "--no-" on the line.
260             # Otherwise, we just include --no- as a possible (partial) completion
261 2     2   13 no warnings; #########
  2         4  
  2         1898  
262             my %boolean =
263 0           map { $_ => 1 }
264 0           grep { not $self->has_value($_) }
265 0           grep { $self->option_spec($_) =~ /\!/ }
266 0 0         grep { $_ ne '<>' and substr($_,0,1) ne '>' }
  0            
267             @args;
268              
269 0 0         my $show_negative_booleans = ($current =~ /^--no-/ ? 1 : 0);
270             @possibilities =
271 0 0         map { length($_) ? ('--' . $_) : ('-') }
272             map {
273 0 0         ($self->option_spec($_) =~ /\=/ ? "$_=\t" : $_ )
274             }
275             map {
276 0 0 0       ($show_negative_booleans and $boolean{$_} and not substr($_,0,3) eq 'no-')
277             ? ($_, 'no-' . $_)
278             : $_
279             }
280             grep {
281 0   0       not (defined $self->value($_) and not $self->option_spec($_) =~ /@/)
282             }
283 0 0         grep { $_ ne '<>' and substr($_,0,1) ne '>' }
  0            
284             @args;
285 0 0 0       if (%boolean and not $show_negative_booleans) {
286             # a partial completion for negating booleans when we're NOT
287             # already showing the complete list
288 0           push @possibilities, "--no-\t";
289             }
290 0 0         if ($current =~ /-{1,2}(.+?)=(.*)/) {
291             # using the --key=value syntax..
292 0           my ($option,$value) = ($1,$2);
293 0           @possibilities = $self->reduce_possibilities_for_current_word('--' . $option, @possibilities);
294 0 0 0       if (!@possibilities || @possibilities == 1 and length($current) >= $possibilities[0]) {
      0        
295             # the key portion is complete
296             # continue below as though were were doing a regular value completion
297 0           $resolve_values_for_option_name = $option;
298 0 0         $current = ($value eq "\t" ? '' : $value);
299 0           @possibilities = ();
300             }
301             }
302             }
303             else {
304             # bare argument or sub-command
305 0           $resolve_values_for_option_name = '<>';
306             }
307             }
308            
309 0 0         if ($resolve_values_for_option_name) {
310             # either a value for a named option, or a bare argument.
311 0 0 0       if (my $handler = $self->completion_handler($resolve_values_for_option_name)) {
    0          
312             # the incomplete word is a value for some option (possible the option '<>' for bare args)
313 0 0 0       if (defined($handler) and not ref($handler) eq 'ARRAY') {
314 0           $handler = $handler->($command,$current,$previous,$all);
315             }
316 0 0         unless (ref($handler) eq 'ARRAY') {
317 0           die "values for $previous must be an arrayref! got $handler\n";
318             }
319 0           @possibilities = @$handler;
320             }
321             elsif ($resolve_values_for_option_name && !$self->sub_commands) {
322 0           my $handler = Getopt::Complete::files->($command,$current,$previous,$all);
323 0           @possibilities = @$handler;
324             }
325             else {
326             # no possibilities
327 0           @possibilities = ();
328             }
329              
330 0 0         if ($resolve_values_for_option_name eq '<>') {
331 0           push @possibilities, $self->sub_commands;
332 0 0         if (grep { $_ ne '<>' and substr($_,0,1) ne '>' } $self->option_names) {
  0 0          
333             # do a partial completion on dashes if there are any non-bare (option) arguments
334             #push @possibilities, "--\t"
335             }
336             }
337             }
338              
339 0           my @matches = $self->reduce_possibilities_for_current_word($current,@possibilities);
340 0           return @matches;
341             }
342              
343             sub reduce_possibilities_for_current_word {
344 0     0 0   my ($self, $current, @possibilities) = @_;
345            
346 0 0         my $uncompletable_valid_possibilities = pop @possibilities if ref($possibilities[-1]);
347            
348             # Determine which possibilities will actually match the current word
349             # The shell does this for us, but we need to do it to predict a few things
350             # and to adjust what we show the shell.
351             # This loop also determines which options should complete with a space afterward,
352             # and which options can be abbreviated when showing a list for the user.
353 0           my @matches;
354             my @nospace;
355 0           my @abbreviated_matches;
356 0           for my $p (@possibilities) {
357 0           my $i =index($p,$current);
358 0 0         if ($i == 0) {
359 0           push @matches, $p;
360             }
361             }
362 0           return @matches;
363             }
364              
365             sub translate_completions_for_shell_display {
366 0     0 0   my ($self, $current, @matches) = @_;
367              
368 0 0         my $uncompletable_valid_matches = pop @matches if ref($matches[-1]);
369            
370             # Determine which matches will actually match the current word
371             # The shell does this for us, but we need to do it to predict a few things
372             # and to adjust what we show the shell.
373             # This loop also determines which options should complete with a space afterward,
374             # and which options can be abbreviated when showing a list for the user.
375 0           my @printable;
376             my @nospace;
377 0           my @abbreviated_printable;
378 0           for my $p (@matches) {
379 0           my $m;
380 0 0         if (substr($p,length($p)-1,1) eq "\t") {
381             # a partial match: no space at the end so the user can "drill down"
382 0           $m = substr($p,0,length($p)-1);
383 0           $nospace[$#printable+1] = 1;
384             }
385             else {
386 0           $m = $p;
387 0           $nospace[$#printable+1] = 0;
388             }
389 0 0         if (substr($m,0,1) eq "\t") {
390             # abbreviatable...
391             # (nothing does this currently, and the code below which uses it does not work yet)
392 0           my ($prefix,$abbreviation) = ($m =~ /^\t(.*)\t(.*)$/);
393 0           push @printable, $prefix . $abbreviation;
394 0           push @abbreviated_printable, $abbreviation;
395             }
396             else {
397 0           push @printable, $m;
398 0           push @abbreviated_printable, $m;
399             }
400             }
401              
402 0 0         if (@printable == 1) {
403             # there is one match
404             # the shell will complete it if it is not already complete, and put a space at the end
405 0 0         if ($nospace[0]) {
406             # We don't want a space, and there is no way to tell bash that, so we trick it.
407 0 0         if ($printable[0] eq $current) {
408             # It IS done completing the word: return nothing so it doesn't stride forward with a space
409             # It will think it has a bad completion, effectively.
410 0           @printable = ();
411             }
412             else {
413             # It is NOT done completing the word.
414             # We return 2 items which start with the real value, but have an arbitrary ending.
415             # It will show everything but that ending, and then stop.
416 0           push @printable, $printable[0];
417 0           $printable[0] .= 'A';
418 0           $printable[1] .= 'B';
419             }
420             }
421             else {
422             # we do want a space, so just let this go normally
423             }
424             }
425             else {
426             # There are multiple printable to the text already typed.
427             # If all of them have a prefix in common, the shell will complete that much.
428             # If not, it will show a list.
429             # We may not want to show the complete text of each word, but a shortened version,
430 0           my $first_mismatch = eval {
431 0           my $pos;
432 2     2   13 no warnings;
  2         4  
  2         554  
433 0           for ($pos=0; $pos < length($printable[0]); $pos++) {
434 0           my $expected = substr($printable[0],$pos,1);
435 0           for my $match (@printable[1..$#printable]) {
436 0 0         if (substr($match,$pos,1) ne $expected) {
437 0           return $pos;
438             }
439             }
440             }
441 0           return $pos;
442             };
443            
444              
445             # NOTE: nothing does this currently, and the code below does not work.
446             # Enable to get file/directory completions to be short, like is default in the shell.
447 0           if (0) {
448             my $current_length = length($current);
449             if (@printable and ($first_mismatch == $current_length)) {
450             # No partial completion will occur: the shell will show a list now.
451             # Attempt abbreviation of the displayed options:
452              
453             my @printable = @abbreviated_printable;
454              
455             #my $cut = $current;
456             #$cut =~ s/[^\/]+$//;
457             #my $cut_length = length($cut);
458             #my @printable =
459             # map { substr($_,$cut_length) }
460             # @printable;
461              
462             # If there are > 1 abbreviated items starting with the same character
463             # the shell won't realize they're abbreviated, and will do completion
464             # instead of listing options. We force some variation into the list
465             # to prevent this.
466             my $first_c = substr($printable[0],0,1);
467             my @distinct_firstchar = grep { substr($_,0,1) ne $first_c } @printable[1,$#printable];
468             unless (@distinct_firstchar) {
469             # this puts an ugly space at the beginning of the completion set :(
470             push @printable,' ';
471             }
472             }
473             else {
474             # some partial completion will occur, continue passing the list so it can do that
475             }
476             }
477             }
478              
479 0           for (@printable) {
480 0           s/ /\\ /g;
481             }
482              
483 0           return @printable;
484             }
485              
486             sub __install_as_default__ {
487 0     0     my $self = shift;
488 0           *Getopt::Complete::ARGS = \$self;
489 0           *Getopt::Complete::ARGS = \%{ $self->{values} };
  0            
490             }
491              
492             1;
493              
494             =pod
495              
496             =head1 NAME
497              
498             Getopt::Complete::Args - a set of option/value pairs
499              
500             =head1 VERSION
501              
502             This document describes Getopt::Complete::Args 0.25.
503              
504             =head1 SYNOPSIS
505              
506             This is used internally by Getopt::Complete during compile.
507              
508             A hand-built implementation might use the objects directly, and
509             look like this:
510              
511             # process @ARGV...
512            
513             my $args = Getopt::Complete::Args->new(
514             options => [ # or pass a Getopt::Complete::Options directly
515             'myfiles=s@' => 'f',
516             'name' => 'u',
517             'age=n' => undef,
518             'fast!' => undef,
519             'color' => ['red','blue','yellow'],
520             ]
521             argv => \@ARGV
522             );
523              
524             $args->options->handle_shell_completion; # support 'complete -C myprogram myprogram'
525              
526             if (my @e = $args->errors) {
527             for my $e (@e) {
528             warn $e;
529             }
530             exit 1;
531             }
532              
533             # on to normal running of the program...
534              
535             for my $name ($args->option_names) {
536             my $spec = $args->option_spec($name);
537             my $value = $args->value($name);
538             print "option $name has specification $spec and value $value\n";
539             }
540              
541             =head1 DESCRIPTION
542              
543             An object of this class describes a set of option/value pairs, built from a L
544             object and a list of command-line arguments (@ARGV).
545              
546             This is the class of the $Getopt::Complete::ARGS object, and $ARGS alias created at compile time.
547             It is also the source of the %ARGS hash injected into both of those namepaces at compile time.
548              
549             =head1 METHODS
550              
551             =over 4
552              
553             =item argv
554              
555             Returns the list of original command-line arguments.
556              
557             =item options
558              
559             Returns the L object which was used to parse the command-line.
560              
561             =item value($option_name)
562              
563             Returns the value for a given option name after parsing.
564              
565             =item bare_args
566              
567             Returns the bare arguments. The same as ->value('<>')
568              
569             =item parent_sub_commands
570              
571             When using a tree of sub-commands, gives the list of sub-commands selected, in order to
572             get to this point. The options and option/value pairs apply to just this particular sub-command.
573              
574             The same as ->value('>').
575              
576             Distinct from ->sub_commands(), which returns the list of next possible choices when
577             drilling down.
578              
579             =item option_spec($name)
580              
581             Returns the GetOptions specification for the parameter in question.
582              
583             =item completion_handler($name)
584              
585             Returns the arrayref or code ref which handles resolving valid completions.
586              
587             =item sub_commands
588              
589             The list of sub-commands which are options at this level of a command tree.
590              
591             This is distinct from sub_command_path, which are the sub-commands which were chosen
592             to get to this level in the tree.
593              
594             =back
595              
596             =head1 SEE ALSO
597              
598             L, L, L
599              
600             =head1 COPYRIGHT
601              
602             Copyright 2010 Scott Smith and Washington University School of Medicine
603              
604             =head1 AUTHORS
605              
606             Scott Smith (sakoht at cpan .org)
607              
608             =head1 LICENSE
609              
610             This program is free software; you can redistribute it and/or modify it under
611             the same terms as Perl itself.
612              
613             The full text of the license can be found in the LICENSE file included with this
614             module.
615              
616             =cut
617