File Coverage

blib/lib/Complete/Util.pm
Criterion Covered Total %
statement 268 315 85.0
branch 160 224 71.4
condition 51 79 64.5
subroutine 15 19 78.9
pod 9 10 90.0
total 503 647 77.7


line stmt bran cond sub pod time code
1             package Complete::Util;
2              
3 7     7   479035 use 5.010001;
  7         92  
4 7     7   38 use strict;
  7         13  
  7         203  
5 7     7   35 use warnings;
  7         16  
  7         220  
6 7     7   12280 use Log::ger;
  7         382  
  7         35  
7              
8 7     7   4964 use Complete::Common qw(:all);
  7         2842  
  7         1009  
9 7     7   71 use Exporter qw(import);
  7         14  
  7         29859  
10              
11             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
12             our $DATE = '2022-09-08'; # DATE
13             our $DIST = 'Complete-Util'; # DIST
14             our $VERSION = '0.612'; # VERSION
15              
16             our @EXPORT_OK = qw(
17             hashify_answer
18             arrayify_answer
19             combine_answers
20             modify_answer
21             ununiquify_answer
22             answer_has_entries
23             answer_num_entries
24             complete_array_elem
25             complete_hash_key
26             complete_comma_sep
27             );
28              
29             our %SPEC;
30              
31             our $COMPLETE_UTIL_TRACE = $ENV{COMPLETE_UTIL_TRACE} // 0;
32              
33             our %arg0_answer = (
34             answer => {
35             summary => 'Completion answer structure',
36             schema => ['any*' => of => ['array*','hash*']],
37             req => 1,
38             pos => 0,
39             },
40             );
41              
42             $SPEC{':package'} = {
43             v => 1.1,
44             summary => 'General completion routine',
45             description => <<'_',
46              
47             This package provides some generic completion routines that follow the
48             convention. (If you are looking for bash/shell tab completion
49             routines, take a look at the See Also section.) The main routine is
50             `complete_array_elem` which tries to complete a word using choices from elements
51             of supplied array. For example:
52              
53             complete_array_elem(word => "a", array => ["apple", "apricot", "banana"]);
54              
55             The routine will first try a simple substring prefix matching. If that fails,
56             will try some other methods like word-mode, character-mode, or fuzzy matching.
57             These methods can be disabled using settings.
58              
59             There are other utility routines e.g. for converting completion answer structure
60             from hash to array/array to hash, combine or modify answer, etc. These routines
61             are usually used by the other more specific or higher-level completion modules.
62              
63             _
64             };
65              
66             $SPEC{hashify_answer} = {
67             v => 1.1,
68             summary => 'Make sure we return completion answer in hash form',
69             description => <<'_',
70              
71             This function accepts a hash or an array. If it receives an array, will convert
72             the array into `{words=>$ary}' first to make sure the completion answer is in
73             hash form.
74              
75             Then will add keys from `meta` to the hash.
76              
77             _
78             args => {
79             %arg0_answer,
80             meta => {
81             summary => 'Metadata (extra keys) for the hash',
82             schema => 'hash*',
83             pos => 1,
84             },
85             },
86             args_as => 'array',
87             result_naked => 1,
88             result => {
89             schema => 'hash*',
90             },
91             };
92             sub hashify_answer {
93 0     0 1 0 my $ans = shift;
94 0 0       0 return unless defined $ans;
95 0 0       0 if (ref($ans) ne 'HASH') {
96 0         0 $ans = {words=>$ans};
97             }
98 0 0       0 if (@_) {
99 0         0 my $meta = shift;
100 0         0 for (keys %$meta) {
101 0         0 $ans->{$_} = $meta->{$_};
102             }
103             }
104 0         0 $ans;
105             }
106              
107             $SPEC{arrayify_answer} = {
108             v => 1.1,
109             summary => 'Make sure we return completion answer in array form',
110             description => <<'_',
111              
112             This is the reverse of `hashify_answer`. It accepts a hash or an array. If it
113             receives a hash, will return its `words` key.
114              
115             _
116             args => {
117             %arg0_answer,
118             },
119             args_as => 'array',
120             result_naked => 1,
121             result => {
122             schema => 'array*',
123             },
124             };
125             sub arrayify_answer {
126 0     0 1 0 my $ans = shift;
127 0 0       0 return unless defined $ans;
128 0 0       0 if (ref($ans) eq 'HASH') {
129 0         0 $ans = $ans->{words};
130             }
131 0         0 $ans;
132             }
133              
134             $SPEC{answer_num_entries} = {
135             v => 1.1,
136             summary => 'Get the number of entries in an answer',
137             description => <<'_',
138              
139             It is equivalent to:
140              
141             ref $answer eq 'ARRAY' ? (@$answer // 0) : (@{$answer->{words}} // 0);
142              
143             _
144             args => {
145             %arg0_answer,
146             },
147             args_as => 'array',
148             result_naked => 1,
149             result => {
150             schema => 'int*',
151             },
152             };
153             sub answer_num_entries {
154 7     7 1 104 my $ans = shift;
155 7 50       17 return unless defined $ans;
156 7 100 100     29 return ref($ans) eq 'HASH' ? (@{$ans->{words} // []} // 0) : (@$ans // 0);
  4   50     29  
      50        
157             }
158              
159             $SPEC{answer_has_entries} = {
160             v => 1.1,
161             summary => 'Check if answer has entries',
162             description => <<'_',
163              
164             It is equivalent to:
165              
166             ref $answer eq 'ARRAY' ? (@$answer ? 1:0) : (@{$answer->{words}} ? 1:0);
167              
168             _
169             args => {
170             %arg0_answer,
171             },
172             args_as => 'array',
173             result_naked => 1,
174             result => {
175             schema => 'int*',
176             },
177             };
178             sub answer_has_entries {
179 5     5 1 101 my $ans = shift;
180 5 50       14 return unless defined $ans;
181 5 100 100     24 return ref($ans) eq 'HASH' ? (@{$ans->{words} // []} ? 1:0) : (@$ans ? 1:0);
  3 100       24  
    100          
182             }
183              
184             sub __min(@) { ## no critic: Subroutines::ProhibitSubroutinePrototypes
185 6     6   6 my $m = $_[0];
186 6         10 for (@_) {
187 12 100       24 $m = $_ if $_ < $m;
188             }
189 6         13 $m;
190             }
191              
192             our $code_editdist;
193             our $editdist_flex;
194              
195             # straight copy of Wikipedia's "Levenshtein Distance"
196             sub __editdist {
197 0     0   0 my @a = split //, shift;
198 0         0 my @b = split //, shift;
199              
200             # There is an extra row and column in the matrix. This is the distance from
201             # the empty string to a substring of the target.
202 0         0 my @d;
203 0         0 $d[$_][0] = $_ for 0 .. @a;
204 0         0 $d[0][$_] = $_ for 0 .. @b;
205              
206 0         0 for my $i (1 .. @a) {
207 0         0 for my $j (1 .. @b) {
208 0 0       0 $d[$i][$j] = (
209             $a[$i-1] eq $b[$j-1]
210             ? $d[$i-1][$j-1]
211             : 1 + __min(
212             $d[$i-1][$j],
213             $d[$i][$j-1],
214             $d[$i-1][$j-1]
215             )
216             );
217             }
218             }
219              
220 0         0 $d[@a][@b];
221             }
222              
223             my %complete_array_elem_args = (
224             %arg_word,
225             array => {
226             schema => ['array*'=>{of=>'str*'}],
227             req => 1,
228             pos => 1,
229             slurpy => 1,
230             },
231             summaries => {
232             schema => ['array*'=>{of=>'str*'}],
233             },
234             exclude => {
235             schema => ['array*'],
236             },
237             replace_map => {
238             schema => ['hash*', each_value=>['array*', of=>'str*']],
239             description => <<'_',
240              
241             You can supply correction entries in this option. An example is when array if
242             `['mount','unmount']` and `umount` is a popular "typo" for `unmount`. When
243             someone already types `um` it cannot be completed into anything (even the
244             current fuzzy mode will return *both* so it cannot complete immediately).
245              
246             One solution is to add replace_map `{'unmount'=>['umount']}`. This way, `umount`
247             will be regarded the same as `unmount` and when user types `um` it can be
248             completed unambiguously into `unmount`.
249              
250             _
251             tags => ['experimental'],
252             },
253             );
254              
255             $SPEC{complete_array_elem} = {
256             v => 1.1,
257             summary => 'Complete from array',
258             description => <<'_',
259              
260             Try to find completion from an array of strings. Will attempt several methods,
261             from the cheapest and most discriminating to the most expensive and least
262             discriminating.
263              
264             First method is normal/exact string prefix matching (either case-sensitive or
265             insensitive depending on the `$Complete::Common::OPT_CI` variable or the
266             `COMPLETE_OPT_CI` environment variable). If at least one match is found, return
267             result. Else, proceed to the next method.
268              
269             Word-mode matching (can be disabled by setting
270             `$Complete::Common::OPT_WORD_MODE` or `COMPLETE_OPT_WORD_MODE` environment
271             varialbe to false). Word-mode matching is described in . If
272             at least one match is found, return result. Else, proceed to the next method.
273              
274             Prefix char-mode matching (can be disabled by settings
275             `$Complete::Common::OPT_CHAR_MODE` or `COMPLETE_OPT_CHAR_MODE` environment
276             variable to false). Prefix char-mode matching is just like char-mode matching
277             (see next paragraph) except the first character must match. If at least one
278             match is found, return result. Else, proceed to the next method.
279              
280             Char-mode matching (can be disabled by settings
281             `$Complete::Common::OPT_CHAR_MODE` or `COMPLETE_OPT_CHAR_MODE` environment
282             variable to false). Char-mode matching is described in . If
283             at least one match is found, return result. Else, proceed to the next method.
284              
285             Fuzzy matching (can be disabled by setting `$Complete::Common::OPT_FUZZY` or
286             `COMPLETE_OPT_FUZZY` to false). Fuzzy matching is described in
287             . If at least one match is found, return result. Else,
288             return empty string.
289              
290             Will sort the resulting completion list, so you don't have to presort the array.
291              
292             _
293             args => {
294             %complete_array_elem_args,
295             },
296             result_naked => 1,
297             result => {
298             schema => 'array',
299             },
300             };
301             sub complete_array_elem {
302 46     46 1 29245 my %args = @_;
303              
304 46 50       126 my $array0 = $args{array} or die "Please specify array";
305 46         73 my $summaries = $args{summaries};
306 46   50     94 my $word = $args{word} // "";
307              
308 46         62 my $ci = $Complete::Common::OPT_CI;
309 46         61 my $map_case = $Complete::Common::OPT_MAP_CASE;
310 46         64 my $word_mode = $Complete::Common::OPT_WORD_MODE;
311 46         63 my $char_mode = $Complete::Common::OPT_CHAR_MODE;
312 46         61 my $fuzzy = $Complete::Common::OPT_FUZZY;
313              
314 46 50       87 log_trace("[computil] entering complete_array_elem(), word=<%s>", $word)
315             if $COMPLETE_UTIL_TRACE;
316              
317 46         61 my $res;
318              
319 46 100       87 unless (@$array0) {
320 1         2 $res = []; goto RETURN_RES;
  1         6  
321             }
322              
323             # normalize
324 45 100       89 my $wordn = $ci ? uc($word) : $word; $wordn =~ s/_/-/g if $map_case;
  45 100       78  
325              
326 45         65 my $excluden;
327 45 100       87 if ($args{exclude}) {
328 3         6 $excluden = {};
329 3         4 for my $el (@{$args{exclude}}) {
  3         7  
330 7 100       17 my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
  7 100       12  
331 7   50     24 $excluden->{$eln} //= 1;
332             }
333             }
334              
335 45         69 my $rmapn;
336             my $rev_rmapn; # to replace back to the original words back in the result
337 45 100       97 if (my $rmap = $args{replace_map}) {
338 4         11 $rmapn = {};
339 4         8 $rev_rmapn = {};
340 4         11 for my $k (keys %$rmap) {
341 4 100       9 my $kn = $ci ? uc($k) : $k; $kn =~ s/_/-/g if $map_case;
  4 50       9  
342 4         8 my @vn;
343 4         4 for my $v (@{ $rmap->{$k} }) {
  4         9  
344 4 100       9 my $vn = $ci ? uc($v) : $v; $vn =~ s/_/-/g if $map_case;
  4 50       7  
345 4         7 push @vn, $vn;
346 4   33     19 $rev_rmapn->{$vn} //= $k;
347             }
348 4         12 $rmapn->{$kn} = \@vn;
349             }
350             }
351              
352 45         147 my @words; # the answer
353             my @wordsumms; # summaries for each item in @words
354 45         0 my @array ; # original array + rmap entries
355 45         0 my @arrayn; # case- & map-case-normalized form of $array + rmap entries
356 45         0 my @arraysumms; # summaries for each item in @array (or @arrayn)
357              
358             # normal string prefix matching. we also fill @array & @arrayn here (which
359             # will be used again in word-mode, fuzzy, and char-mode matching) so we
360             # don't have to calculate again.
361 45 50       83 log_trace("[computil] Trying normal string-prefix matching ...") if $COMPLETE_UTIL_TRACE;
362 45         55 for my $i (0..$#{$array0}) {
  45         136  
363 178         248 my $el = $array0->[$i];
364 178 100       273 my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
  178 100       287  
365 178 100 100     307 next if $excluden && $excluden->{$eln};
366 173         233 push @array , $el;
367 173         251 push @arrayn, $eln;
368 173 100       270 push @arraysumms, $summaries->[$i] if $summaries;
369 173 100       339 if (0==index($eln, $wordn)) {
370 60         79 push @words, $el;
371 60 100       101 push @wordsumms, $summaries->[$i] if $summaries;
372             }
373 173 100 100     381 if ($rmapn && $rmapn->{$eln}) {
374 4         6 for my $vn (@{ $rmapn->{$eln} }) {
  4         7  
375 4         7 push @array , $el;
376 4         6 push @arrayn, $vn;
377             # we add the normalized form, because we'll just revert it back
378             # to the original word in the final result
379 4 100       12 if (0==index($vn, $wordn)) {
380 3         6 push @words, $vn;
381 3 50       7 push @wordsumms, $summaries->[$i] if $summaries;
382             }
383             }
384             }
385             }
386 45 50 66     159 log_trace("[computil] Result from normal string-prefix matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
387              
388             # word-mode matching
389             {
390 45 100 66     64 last unless $word_mode && !@words;
  45         110  
391 2         16 my @split_wordn = $wordn =~ /(\w+)/g;
392 2 100       8 unshift @split_wordn, '' if $wordn =~ /\A\W/;
393 2 50       6 last unless @split_wordn > 1;
394 2         4 my $re = '\A';
395 2         4 for my $i (0..$#split_wordn) {
396 4 100       10 $re .= '(?:\W+\w+)*\W+' if $i;
397 4         12 $re .= quotemeta($split_wordn[$i]).'\w*';
398             }
399 2         132 $re = qr/$re/;
400 2 50       9 log_trace("[computil] Trying word-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
401              
402 2         8 for my $i (0..$#array) {
403 8         8 my $match;
404             {
405 8 100       12 if ($arrayn[$i] =~ $re) {
  8         46  
406 4         8 $match++;
407 4         5 last;
408             }
409             # try splitting CamelCase into Camel-Case
410 4         8 my $tmp = $array[$i];
411 4 50       15 if ($tmp =~ s/([a-z0-9_])([A-Z])/$1-$2/g) {
412 0 0       0 $tmp = uc($tmp) if $ci; $tmp =~ s/_/-/g if $map_case; # normalize again
  0 0       0  
413 0 0       0 if ($tmp =~ $re) {
414 0         0 $match++;
415 0         0 last;
416             }
417             }
418             }
419 8 100       16 next unless $match;
420 4         9 push @words, $array[$i];
421 4 50       9 push @wordsumms, $arraysumms[$i] if $summaries;
422             }
423 2 50 33     10 log_trace("[computil] Result from word-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
424             }
425              
426             # prefix char-mode matching
427 45 50 100     125 if ($char_mode && !@words && length($wordn) && length($wordn) <= 7) {
      66        
      66        
428 4         15 my $re = join(".*", map {quotemeta} split(//, $wordn));
  7         30  
429 4         54 $re = qr/\A$re/;
430 4 50       15 log_trace("[computil] Trying prefix char-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
431 4         10 for my $i (0..$#array) {
432 16 100       65 if ($arrayn[$i] =~ $re) {
433 1         3 push @words, $array[$i];
434 1 50       3 push @wordsumms, $arraysumms[$i] if $summaries;
435             }
436             }
437 4 50 66     17 log_trace("[computil] Result from prefix char-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
438             }
439              
440             # char-mode matching
441 45 50 100     108 if ($char_mode && !@words && length($wordn) && length($wordn) <= 7) {
      66        
      66        
442 3         18 my $re = join(".*", map {quotemeta} split(//, $wordn));
  5         15  
443 3         30 $re = qr/$re/;
444 3 50       10 log_trace("[computil] Trying char-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
445 3         9 for my $i (0..$#array) {
446 13 100       48 if ($arrayn[$i] =~ $re) {
447 2         4 push @words, $array[$i];
448 2 50       5 push @wordsumms, $arraysumms[$i] if $summaries;
449             }
450             }
451 3 50 66     19 log_trace("[computil] Result from char-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
452             }
453              
454             # fuzzy matching
455 45 100 66     91 if ($fuzzy && !@words) {
456 1 50       5 log_trace("[computil] Trying fuzzy matching ...") if $COMPLETE_UTIL_TRACE;
457 1   33     6 $code_editdist //= do {
458 1   50     5 my $env = $ENV{COMPLETE_UTIL_LEVENSHTEIN} // '';
459 1 50       7 if ($env eq 'xs') {
    50          
    50          
    50          
460 0         0 require Text::Levenshtein::XS;
461 0         0 $editdist_flex = 0;
462 0         0 \&Text::Levenshtein::XS::distance;
463             } elsif ($env eq 'flexible') {
464 0         0 require Text::Levenshtein::Flexible;
465 0         0 $editdist_flex = 1;
466 0         0 \&Text::Levenshtein::Flexible::levenshtein_l;
467             } elsif ($env eq 'pp') {
468 0         0 $editdist_flex = 0;
469 0         0 \&__editdist;
470 1         534 } elsif (eval { require Text::Levenshtein::Flexible; 1 }) {
  1         791  
471 1         2 $editdist_flex = 1;
472 1         5 \&Text::Levenshtein::Flexible::levenshtein_l;
473             } else {
474 0         0 $editdist_flex = 0;
475 0         0 \&__editdist;
476             }
477             };
478              
479 1         2 my $factor = 1.3;
480 1         2 my $x = -1;
481 1         1 my $y = 1;
482              
483             # note: we cannot use Text::Levenshtein::Flexible::levenshtein_l_all()
484             # because we perform distance calculation on the normalized array but we
485             # want to get the original array elements
486              
487 1         2 my %editdists;
488             ELEM:
489 1         4 for my $i (0..$#array) {
490 3         7 my $eln = $arrayn[$i];
491              
492 3         7 for my $l (length($wordn)-$y .. length($wordn)+$y) {
493 3 50       8 next if $l <= 0;
494 3         6 my $chopped = substr($eln, 0, $l);
495 3         7 my $maxd = __min(
496             __min(length($chopped), length($word))/$factor,
497             $fuzzy,
498             );
499 3         5 my $d;
500 3 50       7 unless (defined $editdists{$chopped}) {
501 3 50       6 if ($editdist_flex) {
502 3         12 $d = $code_editdist->($wordn, $chopped, $maxd);
503 3 100       9 next ELEM unless defined $d;
504             } else {
505 0         0 $d = $code_editdist->($wordn, $chopped);
506             }
507 1         3 $editdists{$chopped} = $d;
508             } else {
509 0         0 $d = $editdists{$chopped};
510             }
511             #say "D: d($word,$chopped)=$d (maxd=$maxd)";
512 1 50       5 next unless $d <= $maxd;
513 1         12 push @words, $array[$i];
514 1 50       5 push @wordsumms, $arraysumms[$i] if $summaries;
515 1         3 next ELEM;
516             }
517             }
518 1 50 33     25 log_trace("[computil] Result from fuzzy matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
519             }
520              
521             # replace back the words from replace_map
522 45 100 66     105 if ($rmapn && @words) {
523 4         7 my @wordsn;
524 4         9 for my $el (@words) {
525 4 100       9 my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
  4 50       10  
526 4         9 push @wordsn, $eln;
527             }
528 4         8 for my $i (0..$#words) {
529 4 100       12 if (my $w = $rev_rmapn->{$wordsn[$i]}) {
530 3         6 $words[$i] = $w;
531             }
532             }
533             }
534              
535             # sort results and insert summaries
536             $res = [
537             map {
538 71 100       195 $summaries ?
539             {word=>$words[$_], summary=>$wordsumms[$_]} :
540             $words[$_]
541             }
542             sort {
543 45 100       157 $ci ?
  47         130  
544             lc($words[$a]) cmp lc($words[$b]) :
545             $words[$a] cmp $words[$b] }
546             0 .. $#words
547             ];
548              
549 46 50       99 RETURN_RES:
550             log_trace("[computil] leaving complete_array_elem(), res=%s", $res)
551             if $COMPLETE_UTIL_TRACE;
552 46         192 $res;
553             }
554              
555             $SPEC{complete_hash_key} = {
556             v => 1.1,
557             summary => 'Complete from hash keys',
558             args => {
559             %arg_word,
560             hash => { schema=>['hash*'=>{}], req=>1 },
561             summaries => { schema=>['hash*'=>{}] },
562             summaries_from_hash_values => { schema=>'true*' },
563             },
564             result_naked => 1,
565             result => {
566             schema => 'array',
567             },
568             args_rels => {
569             choose_one => ['summaries', 'summaries_from_hash_values'],
570             },
571             };
572             sub complete_hash_key {
573 4     4 1 2461 my %args = @_;
574 4 50       14 my $hash = $args{hash} or die "Please specify hash";
575 4   50     11 my $word = $args{word} // "";
576 4         6 my $summaries = $args{summaries};
577 4         7 my $summaries_from_hash_values = $args{summaries_from_hash_values};
578              
579 4         13 my @keys = keys %$hash;
580 4         9 my @summaries;
581             my $has_summary;
582 4 100       13 if ($summaries) {
    100          
583 1         2 $has_summary++;
584 1         3 for (@keys) { push @summaries, $summaries->{$_} }
  5         9  
585             } elsif ($summaries_from_hash_values) {
586 1         5 $has_summary++;
587 1         2 for (@keys) { push @summaries, $hash->{$_} }
  5         9  
588             }
589              
590             complete_array_elem(
591 4         11 word=>$word, array=>\@keys,
592             (summaries=>\@summaries) x !!$has_summary,
593             );
594             }
595              
596             my %complete_comma_sep_args = (
597             %complete_array_elem_args,
598             sep => {
599             schema => 'str*',
600             default => ',',
601             },
602             uniq => {
603             summary => 'Whether list should contain unique elements',
604             description => <<'_',
605              
606             When this option is set to true, if the formed list in the current word already
607             contains an element, the element will not be offered again as completion answer.
608             For example, if `elems` is `[1,2,3,4]` and `word` is `2,3,` then without `uniq`
609             set to true the completion answer is:
610              
611             2,3,1
612             2,3,2
613             2,3,3
614             2,3,4
615              
616             but with `uniq` set to true, the completion answer becomes:
617              
618             2,3,1
619             2,3,4
620              
621             See also the `remaining` option for a more general mechanism of offering fewer
622             elements.
623              
624             _
625             schema => ['bool*', is=>1],
626             },
627             remaining => {
628             schema => ['code*'],
629             summary => 'What elements should remain for completion',
630             description => <<'_',
631              
632             This is a more general mechanism if the `uniq` option does not suffice. Suppose
633             you are offering completion for sorting fields. The elements are field names as
634             well as field names prefixed with dash (`-`) to mean sorting with a reverse
635             order. So for example `elems` is `["name","-name","age","-age"]`. When current
636             word is `name`, it doesn't make sense to offer `name` nor `-name` again as the
637             next sorting field. So we can set `remaining` to this code:
638              
639             sub {
640             my ($seen_elems, $elems) = @_;
641              
642             my %seen;
643             for (@$seen_elems) {
644             (my $nodash = $_) =~ s/^-//;
645             $seen{$nodash}++;
646             }
647              
648             my @remaining;
649             for (@$elems) {
650             (my $nodash = $_) =~ s/^-//;
651             push @remaining, $_ unless $seen{$nodash};
652             }
653              
654             \@remaining;
655             }
656              
657             As you can see above, the code is given `$seen_elems` and `$elems` as arguments
658             and is expected to return remaining elements to offer.
659              
660             _
661             tags => ['hidden-cli'],
662             },
663             );
664             $complete_comma_sep_args{elems} = delete $complete_comma_sep_args{array};
665              
666             $SPEC{complete_comma_sep} = {
667             v => 1.1,
668             summary => 'Complete a comma-separated list string',
669             args => {
670             %complete_comma_sep_args,
671             },
672             result_naked => 1,
673             result => {
674             schema => 'array',
675             },
676             };
677             sub complete_comma_sep {
678 19     19 1 13798 my %args = @_;
679 19   50     58 my $word = delete $args{word} // "";
680 19   50     67 my $sep = delete $args{sep} // ',';
681 19 50       44 my $elems = delete $args{elems} or die "Please specify elems";
682 19         32 my $uniq = delete $args{uniq};
683 19         29 my $remaining = delete $args{remaining};
684              
685 19         29 my $ci = $Complete::Common::OPT_CI;
686              
687 19         81 my @mentioned_elems = split /\Q$sep\E/, $word, -1;
688 19 100       52 my $cae_word = @mentioned_elems ? pop(@mentioned_elems) : '';
689              
690 19         28 my $remaining_elems;
691 19 100       40 if ($remaining) {
    100          
692 3         11 $remaining_elems = $remaining->(\@mentioned_elems, $elems);
693             } elsif ($uniq) {
694 6         7 my %mem;
695 6         11 $remaining_elems = [];
696 6         13 for (@mentioned_elems) {
697 10 50       15 if ($ci) { $mem{lc $_}++ } else { $mem{$_}++ }
  0         0  
  10         20  
698             }
699 6         12 for (@$elems) {
700 18 50       49 push @$remaining_elems, $_ unless ($ci ? $mem{lc $_} : $mem{$_});
    100          
701             }
702             } else {
703 10         13 $remaining_elems = $elems;
704             }
705              
706 19         132 my $cae_res = complete_array_elem(
707             %args,
708             word => $cae_word,
709             array => $remaining_elems,
710             );
711              
712 19         48 my $prefix = join($sep, @mentioned_elems);
713 19 100       41 $prefix .= $sep if @mentioned_elems;
714 19         35 $cae_res = [map { "$prefix$_" } @$cae_res];
  31         75  
715              
716             # add trailing comma for convenience, where appropriate
717             {
718 19 100       26 last unless @$cae_res == 1;
  19         38  
719 5 100       18 last if @$remaining_elems <= 1;
720 4         15 $cae_res = [{word=>"$cae_res->[0]$sep", is_partial=>1}];
721             }
722 19         57 $cae_res;
723             }
724              
725             $SPEC{combine_answers} = {
726             v => 1.1,
727             summary => 'Given two or more answers, combine them into one',
728             description => <<'_',
729              
730             This function is useful if you want to provide a completion answer that is
731             gathered from multiple sources. For example, say you are providing completion
732             for the Perl tool , which accepts a filename (a tarball like
733             `*.tar.gz`), a directory, or a module name. You can do something like this:
734              
735             combine_answers(
736             complete_file(word=>$word),
737             complete_module(word=>$word),
738             );
739              
740             But if a completion answer has a metadata `final` set to true, then that answer
741             is used as the final answer without any combining with the other answers.
742              
743             _
744             args => {
745             answers => {
746             schema => [
747             'array*' => {
748             of => ['any*', of=>['hash*','array*']], # XXX answer_t
749             min_len => 1,
750             },
751             ],
752             req => 1,
753             pos => 0,
754             greedy => 1,
755             },
756             },
757             args_as => 'array',
758             result_naked => 1,
759             result => {
760             schema => 'hash*',
761             description => <<'_',
762              
763             Return a combined completion answer. Words from each input answer will be
764             combined, order preserved and duplicates removed. The other keys from each
765             answer will be merged.
766              
767             _
768             },
769             };
770             sub combine_answers {
771 10     10 1 27521 require List::Util;
772              
773 10 100       30 return unless @_;
774 9 100       25 return $_[0] if @_ < 2;
775              
776 8         23 my $final = {words=>[]};
777 8         12 my $encounter_hash;
778             my $add_words = sub {
779 17     17   22 my $words = shift;
780 17         29 for my $entry (@$words) {
781 29         101 push @{ $final->{words} }, $entry
782             unless List::Util::first(
783             sub {
784             (ref($entry) ? $entry->{word} : $entry)
785             eq
786 75 100       172 (ref($_) ? $_->{word} : $_)
    100          
787 34 100       74 }, @{ $final->{words} }
  34         79  
788             );
789             }
790 8         32 };
791              
792             ANSWER:
793 8         19 for my $ans (@_) {
794 20 100       59 if (ref($ans) eq 'ARRAY') {
    50          
795 9         16 $add_words->($ans);
796             } elsif (ref($ans) eq 'HASH') {
797 11         19 $encounter_hash++;
798              
799 11 100       23 if ($ans->{final}) {
800 3         10 $final = $ans;
801 3         8 last ANSWER;
802             }
803              
804 8   50     28 $add_words->($ans->{words} // []);
805 8         19 for (keys %$ans) {
806 17 100       35 if ($_ eq 'words') {
    100          
807 8         14 next;
808             } elsif ($_ eq 'static') {
809 6 100       12 if (exists $final->{$_}) {
810 4   66     17 $final->{$_} &&= $ans->{$_};
811             } else {
812 2         5 $final->{$_} = $ans->{$_};
813             }
814             } else {
815 3         7 $final->{$_} = $ans->{$_};
816             }
817             }
818             }
819             }
820              
821 8 100       43 $encounter_hash ? $final : $final->{words};
822             }
823              
824             $SPEC{modify_answer} = {
825             v => 1.1,
826             summary => 'Modify answer (add prefix/suffix, etc)',
827             args => {
828             answer => {
829             schema => ['any*', of=>['hash*','array*']], # XXX answer_t
830             req => 1,
831             pos => 0,
832             },
833             suffix => {
834             schema => 'str*',
835             },
836             prefix => {
837             schema => 'str*',
838             },
839             },
840             result_naked => 1,
841             result => {
842             schema => 'undef',
843             },
844             };
845             sub modify_answer {
846 3     3 1 111 my %args = @_;
847              
848 3         7 my $answer = $args{answer};
849 3 100       22 my $words = ref($answer) eq 'HASH' ? $answer->{words} : $answer;
850              
851 3 50       9 if (defined(my $prefix = $args{prefix})) {
852 3         7 for (@$words) {
853 9 100       15 if (ref $_ eq 'HASH') {
854 1         5 $_->{word} = "$prefix$_->{word}";
855             } else {
856 8         17 $_ = "$prefix$_";
857             }
858             }
859             }
860 3 50       8 if (defined(my $suffix = $args{suffix})) {
861 3         4 for (@$words) {
862 9 100       17 if (ref $_ eq 'HASH') {
863 1         3 $_->{word} = "$_->{word}$suffix";
864             } else {
865 8         13 $_ = "$_$suffix";
866             }
867             }
868             }
869 3         44 $answer;
870             }
871              
872             $SPEC{ununiquify_answer} = {
873             v => 1.1,
874             summary => 'If answer contains only one item, make it two',
875             description => <<'_',
876              
877             For example, if answer is `["a"]`, then will make answer become `["a","a "]`.
878             This will prevent shell from automatically adding space.
879              
880             _
881             args => {
882             answer => {
883             schema => ['any*', of=>['hash*','array*']], # XXX answer_t
884             req => 1,
885             pos => 0,
886             },
887             },
888             result_naked => 1,
889             result => {
890             schema => 'undef',
891             },
892             tags => ['hidden'],
893             };
894             sub ununiquify_answer {
895 0     0 0   my %args = @_;
896              
897 0           my $answer = $args{answer};
898 0 0         my $words = ref($answer) eq 'HASH' ? $answer->{words} : $answer;
899              
900 0 0         if (@$words == 1) {
901 0           push @$words, "$words->[0] ";
902             }
903 0           undef;
904             }
905              
906             1;
907             # ABSTRACT: General completion routine
908              
909             __END__