File Coverage

blib/lib/Getopt/Long/Subcommand.pm
Criterion Covered Total %
statement 84 141 59.5
branch 32 68 47.0
condition 15 28 53.5
subroutine 9 12 75.0
pod 1 1 100.0
total 141 250 56.4


line stmt bran cond sub pod time code
1             package Getopt::Long::Subcommand;
2              
3             our $DATE = '2017-08-12'; # DATE
4             our $VERSION = '0.102'; # VERSION
5              
6 1     1   46290 use 5.010001;
  1         3  
7 1     1   5 use strict;
  1         1  
  1         18  
8 1     1   4 use warnings;
  1         2  
  1         1127  
9             #use Log::ger;
10              
11             require Exporter;
12             our @ISA = qw(Exporter);
13             ## no critic (Modules::ProhibitAutomaticExportation)
14             our @EXPORT = qw(
15             GetOptions
16             );
17             ## use critic
18              
19             # XXX completion & configure are actually only allowed at the top-level
20             my @known_cmdspec_keys = qw(
21             options
22             subcommands
23             default_subcommand
24             summary description
25             completion
26             configure
27             );
28              
29             sub _cmdspec_opts_to_gl_ospec {
30 40     40   144 my ($cmdspec_opts, $is_completion, $res) = @_;
31             return { map {
32 40 50       164 if ($is_completion) {
  62         174  
33             # we don't want side-effects during completion (handler printing or
34             # existing, etc), so we set an empty coderef for all handlers.
35 0     0   0 ($_ => sub{});
36             } else {
37 62         133 my $k = $_;
38 62         142 my $v = $cmdspec_opts->{$k};
39 62 50       226 my $handler = ref($v) eq 'HASH' ? $v->{handler} : $v;
40 62 50       191 if (ref($handler) eq 'CODE') {
41 62         132 my $orig_handler = $handler;
42             $handler = sub {
43 7     7   3398 my ($cb, $val) = @_;
44 7         35 $orig_handler->($cb, $val, $res);
45 62         335 };
46             }
47 62         337 ($k => $handler);
48             }
49             } keys %$cmdspec_opts };
50             }
51              
52             sub _gl_getoptions {
53 40     40   61848 require Getopt::Long;
54              
55 40         15963 my ($ospec, $configure, $pass_through, $res) = @_;
56              
57             my @configure = @{
58 40   100     379 $configure //
  40         312  
59             ['no_ignore_case', 'no_getopt_compat', 'gnu_compat', 'bundling']
60             };
61 40 100       163 if ($pass_through) {
62             push @configure, 'pass_through'
63 34 50       98 unless grep { $_ eq 'pass_through' } @configure;
  136         519  
64             } else {
65 6         21 @configure = grep { $_ ne 'pass_through' } @configure;
  21         73  
66             }
67             #log_trace('[comp][glsubc] Performing Getopt::Long::GetOptions (configure: %s)',
68             # $pass_through, \@configure);
69              
70 40         249 my $old_conf = Getopt::Long::Configure(@configure);
71 40 100   0   4691 local $SIG{__WARN__} = sub {} if $pass_through;
72              
73             # ugh, this is ugly. the problem we're trying to solve: in the case of 'subc
74             # --help', 'subc' is consumed first by Getopt::Long and thus removed from
75             # @ARGV. when --help handler wants to find out the subcommand name ('subc'),
76             # it doesn't have anywhere to look for. so we give it in $res which is
77             # passed as the third argument to the handler.
78 40         173 local $res->{_non_options_argv} = [];
79              
80             #log_trace('[comp][glsubc] @ARGV before Getopt::Long::GetOptions: %s', \@ARGV);
81             #log_trace('[comp][glsubc] spec for Getopt::Long::GetOptions: %s', $ospec);
82             my $gl_res = Getopt::Long::GetOptions(
83             %$ospec,
84 59     59   10491 '<>' => sub { push @{ $res->{_non_options_argv} }, $_[0] },
  59         284  
85 40         487 );
86 40         2413 @ARGV = @{ $res->{_non_options_argv} };
  40         192  
87              
88             #log_trace('[comp][glsubc] @ARGV after Getopt::Long::GetOptions: %s', \@ARGV);
89 40         320 Getopt::Long::Configure($old_conf);
90 40         1336 $gl_res;
91             }
92              
93             sub _GetOptions {
94 40     40   138 my ($cmdspec, $is_completion, $res, $stash) = @_;
95              
96 40   100     195 $res //= {success=>undef};
97 40   100     212 $stash //= {
98             path => '', # for displaying error message
99             level => 0,
100             };
101              
102             # check command spec
103             {
104             #log_trace("[comp][glsubc] Checking cmdspec keys: %s", [keys %$cmdspec]);
105 40         89 for my $k (keys %$cmdspec) {
  40         176  
106 679         2163 (grep { $_ eq $k } @known_cmdspec_keys)
107             or die "Unknown command specification key '$k'" .
108 97 0       247 ($stash->{path} ? " (under $stash->{path})" : "") . "\n";
    50          
109             }
110             }
111              
112             my $has_subcommands = $cmdspec->{subcommands} &&
113 40   66     201 keys(%{$cmdspec->{subcommands}});
114             #log_trace("TMP:has_subcommands=%s", $has_subcommands);
115 40   66     163 my $pass_through = $has_subcommands || $is_completion;
116              
117             my $ospec = _cmdspec_opts_to_gl_ospec(
118 40         164 $cmdspec->{options}, $is_completion, $res);
119 40 100       207 unless (_gl_getoptions(
120             $ospec, $cmdspec->{configure}, $pass_through, $res)) {
121 1         5 $res->{success} = 0;
122 1         11 return $res;
123             }
124              
125             # for doing completion
126 39 50       247 if ($is_completion) {
127 0   0     0 $res->{comp_ospec} //= {};
128 0         0 for (keys %$ospec) {
129 0         0 $res->{comp_ospec}{$_} = $ospec->{$_};
130             }
131             }
132              
133 39 100       129 if ($has_subcommands) {
134             # for doing completion of subcommand names
135 34 50       113 if ($is_completion) {
136             $res->{comp_subcommand_names}[$stash->{level}] =
137 0         0 [sort keys %{$cmdspec->{subcommands}}];
  0         0  
138             }
139              
140 34   100     195 $res->{subcommand} //= [];
141              
142 34         88 my $push;
143             my $sc_name;
144              
145 34 50       175 if (defined $res->{subcommand}[ $stash->{level} ]) {
    100          
    50          
146             # subcommand has been set, e.g. by option handler
147 0         0 $sc_name = $res->{subcommand}[ $stash->{level} ];
148             } elsif (@ARGV) {
149 29         85 $sc_name = shift @ARGV;
150 29         207 $push++; # we need to push to $res->{subcommand} later
151             } elsif (defined $cmdspec->{default_subcommand}) {
152 0         0 $sc_name = $cmdspec->{default_subcommand};
153 0         0 $push++;
154             } else {
155             # no subcommand
156 5         18 $res->{success} = 1;
157 5         43 return $res;
158             }
159              
160             # for doing completion of subcommand names
161 29 50       96 if ($is_completion) {
162 0         0 push @{ $res->{comp_subcommand_name} }, $sc_name;
  0         0  
163             }
164              
165 29         93 my $sc_spec = $cmdspec->{subcommands}{$sc_name};
166 29 100       99 unless ($sc_spec) {
167             warn "Unknown subcommand '$sc_name'".
168 7 100       306 ($stash->{path} ? " for $stash->{path}":"")."\n"
    50          
169             unless $is_completion;
170 7         43 $res->{success} = 0;
171 7         71 return $res;
172             };
173 22 50       72 push @{ $res->{subcommand} }, $sc_name if $push;
  22         89  
174 22 100       126 local $stash->{path} = ($stash->{path} ? "/" : "") . $sc_name;
175 22         79 local $stash->{level} = $stash->{level}+1;
176 22         92 _GetOptions($sc_spec, $is_completion, $res, $stash);
177             }
178 27   100     118 $res->{success} //= 1;
179              
180             #log_trace('[comp][glsubc] Final @ARGV: %s', \@ARGV) unless $stash->{path};
181             #log_trace('[comp][glsubc] TMP: stash=%s', $stash);
182             #log_trace('[comp][glsubc] TMP: res=%s', $res);
183 27         189 $res;
184             }
185              
186             sub GetOptions {
187 18     18 1 101425 my %cmdspec = @_;
188              
189             # figure out if we run in completion mode
190 18         64 my ($is_completion, $shell, $words, $cword);
191             CHECK_COMPLETION:
192             {
193 18 50       101 if ($ENV{COMP_SHELL}) {
  18 50       103  
194 0         0 ($shell = $ENV{COMP_SHELL}) =~ s!.+/!!;
195             } elsif ($ENV{COMMAND_LINE}) {
196 0         0 $shell = 'tcsh';
197             } else {
198 18         56 $shell = 'bash';
199             }
200              
201 18 50 33     142 if ($ENV{COMP_LINE} || $ENV{COMMAND_LINE}) {
202 0 0       0 if ($ENV{COMP_LINE}) {
    0          
203 0         0 $is_completion++;
204 0         0 require Complete::Bash;
205 0         0 ($words, $cword) = @{ Complete::Bash::parse_cmdline(
  0         0  
206             undef, undef, {truncate_current_word=>1}) };
207 0         0 ($words, $cword) = @{ Complete::Bash::join_wordbreak_words(
  0         0  
208             $words, $cword) };
209             } elsif ($ENV{COMMAND_LINE}) {
210 0         0 $is_completion++;
211 0         0 require Complete::Tcsh;
212 0         0 $shell = 'tcsh';
213 0         0 ($words, $cword) = @{ Complete::Tcsh::parse_cmdline() };
  0         0  
214             } else {
215 0         0 last CHECK_COMPLETION;
216             }
217              
218 0         0 shift @$words; $cword--; # strip program name
  0         0  
219 0         0 @ARGV = @$words;
220             }
221             }
222              
223 18         83 my $res = _GetOptions(\%cmdspec, $is_completion);
224              
225 18 50       73 if ($is_completion) {
226 0         0 my $ospec = $res->{comp_ospec};
227 0         0 require Complete::Getopt::Long;
228             my $compres = Complete::Getopt::Long::complete_cli_arg(
229             words => $words, cword => $cword, getopt_spec=>$ospec,
230             extras => {
231             stash => $res->{stash},
232             },
233             bundling => do {
234 0 0       0 if (!$cmdspec{configure}) {
    0          
    0          
235 0         0 1;
236 0         0 } elsif (grep { $_ eq 'bundling' } @{ $cmdspec{configure} }) {
  0         0  
237 0         0 1;
238 0         0 } elsif (grep { $_ eq 'no_bundling' } @{ $cmdspec{configure} }) {
  0         0  
239 0         0 0;
240             } else {
241 0         0 0;
242             }
243             },
244             completion => sub {
245 0     0   0 my %args = @_;
246              
247 0   0     0 my $word = $args{word} // '';
248 0         0 my $type = $args{type};
249 0         0 my $stash = $args{stash};
250              
251             # complete subcommand names
252 0 0 0     0 if ($type eq 'arg' &&
253 0   0     0 $args{argpos} < @{$res->{comp_subcommand_names}//[]}) {
254 0         0 require Complete::Util;
255             return Complete::Util::complete_array_elem(
256             array => $res->{comp_subcommand_names}[$args{argpos}],
257 0         0 word => $res->{comp_subcommand_name}[$args{argpos}],
258             );
259             }
260              
261 0         0 $args{getopt_res} = $res;
262 0         0 $args{subcommand} = $res->{comp_subcommand_name};
263 0 0       0 $cmdspec{completion}->(%args) if $cmdspec{completion};
264             },
265 0         0 );
266              
267 0 0       0 if ($shell eq 'bash') {
    0          
268 0         0 print Complete::Bash::format_completion($compres);
269             } elsif ($shell eq 'tcsh') {
270 0         0 print Complete::Tcsh::format_completion($compres);
271             } else {
272 0         0 die "Unknown shell '$shell'";
273             }
274              
275 0         0 exit 0;
276             }
277              
278             # cleanup unneeded details
279 18         104 $res;
280             }
281              
282             1;
283             # ABSTRACT: Process command-line options, with subcommands and completion
284              
285             __END__